Branch data Line data Source code
1 : : /* Maintain binary trees of symbols.
2 : : Copyright (C) 2000-2023 Free Software Foundation, Inc.
3 : : Contributed by Andy Vaught
4 : :
5 : : This file is part of GCC.
6 : :
7 : : GCC is free software; you can redistribute it and/or modify it under
8 : : the terms of the GNU General Public License as published by the Free
9 : : Software Foundation; either version 3, or (at your option) any later
10 : : version.
11 : :
12 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : : for more details.
16 : :
17 : : You should have received a copy of the GNU General Public License
18 : : along with GCC; see the file COPYING3. If not see
19 : : <http://www.gnu.org/licenses/>. */
20 : :
21 : :
22 : : #include "config.h"
23 : : #include "system.h"
24 : : #include "coretypes.h"
25 : : #include "options.h"
26 : : #include "gfortran.h"
27 : : #include "parse.h"
28 : : #include "match.h"
29 : : #include "constructor.h"
30 : :
31 : :
32 : : /* Strings for all symbol attributes. We use these for dumping the
33 : : parse tree, in error messages, and also when reading and writing
34 : : modules. */
35 : :
36 : : const mstring flavors[] =
37 : : {
38 : : minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
39 : : minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
40 : : minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
41 : : minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
42 : : minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
43 : : minit ("UNION", FL_UNION), minit ("STRUCTURE", FL_STRUCT),
44 : : minit (NULL, -1)
45 : : };
46 : :
47 : : const mstring procedures[] =
48 : : {
49 : : minit ("UNKNOWN-PROC", PROC_UNKNOWN),
50 : : minit ("MODULE-PROC", PROC_MODULE),
51 : : minit ("INTERNAL-PROC", PROC_INTERNAL),
52 : : minit ("DUMMY-PROC", PROC_DUMMY),
53 : : minit ("INTRINSIC-PROC", PROC_INTRINSIC),
54 : : minit ("EXTERNAL-PROC", PROC_EXTERNAL),
55 : : minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
56 : : minit (NULL, -1)
57 : : };
58 : :
59 : : const mstring intents[] =
60 : : {
61 : : minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
62 : : minit ("IN", INTENT_IN),
63 : : minit ("OUT", INTENT_OUT),
64 : : minit ("INOUT", INTENT_INOUT),
65 : : minit (NULL, -1)
66 : : };
67 : :
68 : : const mstring access_types[] =
69 : : {
70 : : minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
71 : : minit ("PUBLIC", ACCESS_PUBLIC),
72 : : minit ("PRIVATE", ACCESS_PRIVATE),
73 : : minit (NULL, -1)
74 : : };
75 : :
76 : : const mstring ifsrc_types[] =
77 : : {
78 : : minit ("UNKNOWN", IFSRC_UNKNOWN),
79 : : minit ("DECL", IFSRC_DECL),
80 : : minit ("BODY", IFSRC_IFBODY)
81 : : };
82 : :
83 : : const mstring save_status[] =
84 : : {
85 : : minit ("UNKNOWN", SAVE_NONE),
86 : : minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
87 : : minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
88 : : };
89 : :
90 : : /* Set the mstrings for DTIO procedure names. */
91 : : const mstring dtio_procs[] =
92 : : {
93 : : minit ("_dtio_formatted_read", DTIO_RF),
94 : : minit ("_dtio_formatted_write", DTIO_WF),
95 : : minit ("_dtio_unformatted_read", DTIO_RUF),
96 : : minit ("_dtio_unformatted_write", DTIO_WUF),
97 : : };
98 : :
99 : : /* This is to make sure the backend generates setup code in the correct
100 : : order. */
101 : :
102 : : static int next_dummy_order = 1;
103 : :
104 : :
105 : : gfc_namespace *gfc_current_ns;
106 : : gfc_namespace *gfc_global_ns_list;
107 : :
108 : : gfc_gsymbol *gfc_gsym_root = NULL;
109 : :
110 : : gfc_symbol *gfc_derived_types;
111 : :
112 : : static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL };
113 : : static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
114 : :
115 : :
116 : : /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
117 : :
118 : : /* The following static variable indicates whether a particular element has
119 : : been explicitly set or not. */
120 : :
121 : : static int new_flag[GFC_LETTERS];
122 : :
123 : :
124 : : /* Handle a correctly parsed IMPLICIT NONE. */
125 : :
126 : : void
127 : 20295 : gfc_set_implicit_none (bool type, bool external, locus *loc)
128 : : {
129 : 20295 : int i;
130 : :
131 : 20295 : if (external)
132 : 927 : gfc_current_ns->has_implicit_none_export = 1;
133 : :
134 : 20295 : if (type)
135 : : {
136 : 20284 : gfc_current_ns->seen_implicit_none = 1;
137 : 547617 : for (i = 0; i < GFC_LETTERS; i++)
138 : : {
139 : 527335 : if (gfc_current_ns->set_flag[i])
140 : : {
141 : 2 : gfc_error_now ("IMPLICIT NONE (type) statement at %L following an "
142 : : "IMPLICIT statement", loc);
143 : 2 : return;
144 : : }
145 : 527333 : gfc_clear_ts (&gfc_current_ns->default_type[i]);
146 : 527333 : gfc_current_ns->set_flag[i] = 1;
147 : : }
148 : : }
149 : : }
150 : :
151 : :
152 : : /* Reset the implicit range flags. */
153 : :
154 : : void
155 : 20934 : gfc_clear_new_implicit (void)
156 : : {
157 : 20934 : int i;
158 : :
159 : 565218 : for (i = 0; i < GFC_LETTERS; i++)
160 : 544284 : new_flag[i] = 0;
161 : 20934 : }
162 : :
163 : :
164 : : /* Prepare for a new implicit range. Sets flags in new_flag[]. */
165 : :
166 : : bool
167 : 664 : gfc_add_new_implicit_range (int c1, int c2)
168 : : {
169 : 664 : int i;
170 : :
171 : 664 : c1 -= 'a';
172 : 664 : c2 -= 'a';
173 : :
174 : 6215 : for (i = c1; i <= c2; i++)
175 : : {
176 : 5551 : if (new_flag[i])
177 : : {
178 : 0 : gfc_error ("Letter %qc already set in IMPLICIT statement at %C",
179 : : i + 'A');
180 : 0 : return false;
181 : : }
182 : :
183 : 5551 : new_flag[i] = 1;
184 : : }
185 : :
186 : : return true;
187 : : }
188 : :
189 : :
190 : : /* Add a matched implicit range for gfc_set_implicit(). Check if merging
191 : : the new implicit types back into the existing types will work. */
192 : :
193 : : bool
194 : 461 : gfc_merge_new_implicit (gfc_typespec *ts)
195 : : {
196 : 461 : int i;
197 : :
198 : 461 : if (gfc_current_ns->seen_implicit_none)
199 : : {
200 : 0 : gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
201 : 0 : return false;
202 : : }
203 : :
204 : 12401 : for (i = 0; i < GFC_LETTERS; i++)
205 : : {
206 : 11942 : if (new_flag[i])
207 : : {
208 : 5513 : if (gfc_current_ns->set_flag[i])
209 : : {
210 : 2 : gfc_error ("Letter %qc already has an IMPLICIT type at %C",
211 : : i + 'A');
212 : 2 : return false;
213 : : }
214 : :
215 : 5511 : gfc_current_ns->default_type[i] = *ts;
216 : 5511 : gfc_current_ns->implicit_loc[i] = gfc_current_locus;
217 : 5511 : gfc_current_ns->set_flag[i] = 1;
218 : : }
219 : : }
220 : : return true;
221 : : }
222 : :
223 : :
224 : : /* Given a symbol, return a pointer to the typespec for its default type. */
225 : :
226 : : gfc_typespec *
227 : 2470099 : gfc_get_default_type (const char *name, gfc_namespace *ns)
228 : : {
229 : 2470099 : char letter;
230 : :
231 : 2470099 : letter = name[0];
232 : :
233 : 2470099 : if (flag_allow_leading_underscore && letter == '_')
234 : 0 : gfc_fatal_error ("Option %<-fallow-leading-underscore%> is for use only by "
235 : : "gfortran developers, and should not be used for "
236 : : "implicitly typed variables");
237 : :
238 : 2470099 : if (letter < 'a' || letter > 'z')
239 : 0 : gfc_internal_error ("gfc_get_default_type(): Bad symbol %qs", name);
240 : :
241 : 2470099 : if (ns == NULL)
242 : 223823 : ns = gfc_current_ns;
243 : :
244 : 2470099 : return &ns->default_type[letter - 'a'];
245 : : }
246 : :
247 : :
248 : : /* Recursively append candidate SYM to CANDIDATES. Store the number of
249 : : candidates in CANDIDATES_LEN. */
250 : :
251 : : static void
252 : 363 : lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
253 : : char **&candidates,
254 : : size_t &candidates_len)
255 : : {
256 : 617 : gfc_symtree *p;
257 : :
258 : 617 : if (sym == NULL)
259 : : return;
260 : :
261 : 617 : if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE)
262 : 288 : vec_push (candidates, candidates_len, sym->name);
263 : 617 : p = sym->left;
264 : 617 : if (p)
265 : 255 : lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
266 : :
267 : 617 : p = sym->right;
268 : 617 : if (p)
269 : : lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
270 : : }
271 : :
272 : :
273 : : /* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */
274 : :
275 : : static const char*
276 : 108 : lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
277 : : {
278 : 108 : char **candidates = NULL;
279 : 108 : size_t candidates_len = 0;
280 : 108 : lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates,
281 : : candidates_len);
282 : 108 : return gfc_closest_fuzzy_match (sym_name, candidates);
283 : : }
284 : :
285 : :
286 : : /* Given a pointer to a symbol, set its type according to the first
287 : : letter of its name. Fails if the letter in question has no default
288 : : type. */
289 : :
290 : : bool
291 : 95017 : gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
292 : : {
293 : 95017 : gfc_typespec *ts;
294 : :
295 : 95017 : if (sym->ts.type != BT_UNKNOWN)
296 : 0 : gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
297 : :
298 : 95017 : ts = gfc_get_default_type (sym->name, ns);
299 : :
300 : 95017 : if (ts->type == BT_UNKNOWN)
301 : : {
302 : 44735 : if (error_flag && !sym->attr.untyped && !gfc_query_suppress_errors ())
303 : : {
304 : 108 : const char *guessed = lookup_symbol_fuzzy (sym->name, sym);
305 : 108 : if (guessed)
306 : 17 : gfc_error ("Symbol %qs at %L has no IMPLICIT type"
307 : : "; did you mean %qs?",
308 : : sym->name, &sym->declared_at, guessed);
309 : : else
310 : 91 : gfc_error ("Symbol %qs at %L has no IMPLICIT type",
311 : : sym->name, &sym->declared_at);
312 : 108 : sym->attr.untyped = 1; /* Ensure we only give an error once. */
313 : : }
314 : :
315 : 44735 : return false;
316 : : }
317 : :
318 : 50282 : sym->ts = *ts;
319 : 50282 : sym->attr.implicit_type = 1;
320 : :
321 : 50282 : if (ts->type == BT_CHARACTER && ts->u.cl)
322 : 456 : sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
323 : 49826 : else if (ts->type == BT_CLASS
324 : 49826 : && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
325 : : return false;
326 : :
327 : 50282 : if (sym->attr.is_bind_c == 1 && warn_c_binding_type)
328 : : {
329 : : /* BIND(C) variables should not be implicitly declared. */
330 : 1 : gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared BIND(C) "
331 : : "variable %qs at %L may not be C interoperable",
332 : : sym->name, &sym->declared_at);
333 : 1 : sym->ts.f90_type = sym->ts.type;
334 : : }
335 : :
336 : 50282 : if (sym->attr.dummy != 0)
337 : : {
338 : 4277 : if (sym->ns->proc_name != NULL
339 : 4276 : && (sym->ns->proc_name->attr.subroutine != 0
340 : 4276 : || sym->ns->proc_name->attr.function != 0)
341 : 4276 : && sym->ns->proc_name->attr.is_bind_c != 0
342 : 54 : && warn_c_binding_type)
343 : : {
344 : : /* Dummy args to a BIND(C) routine may not be interoperable if
345 : : they are implicitly typed. */
346 : 1 : gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared variable "
347 : : "%qs at %L may not be C interoperable but it is a "
348 : : "dummy argument to the BIND(C) procedure %qs at %L",
349 : : sym->name, &(sym->declared_at),
350 : : sym->ns->proc_name->name,
351 : : &(sym->ns->proc_name->declared_at));
352 : 1 : sym->ts.f90_type = sym->ts.type;
353 : : }
354 : : }
355 : :
356 : : return true;
357 : : }
358 : :
359 : :
360 : : /* This function is called from parse.cc(parse_progunit) to check the
361 : : type of the function is not implicitly typed in the host namespace
362 : : and to implicitly type the function result, if necessary. */
363 : :
364 : : void
365 : 11252 : gfc_check_function_type (gfc_namespace *ns)
366 : : {
367 : 11252 : gfc_symbol *proc = ns->proc_name;
368 : :
369 : 11252 : if (!proc->attr.contained || proc->result->attr.implicit_type)
370 : : return;
371 : :
372 : 8556 : if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
373 : : {
374 : 100 : if (gfc_set_default_type (proc->result, 0, gfc_current_ns))
375 : : {
376 : 80 : if (proc->result != proc)
377 : : {
378 : 16 : proc->ts = proc->result->ts;
379 : 16 : proc->as = gfc_copy_array_spec (proc->result->as);
380 : 16 : proc->attr.dimension = proc->result->attr.dimension;
381 : 16 : proc->attr.pointer = proc->result->attr.pointer;
382 : 16 : proc->attr.allocatable = proc->result->attr.allocatable;
383 : : }
384 : : }
385 : 20 : else if (!proc->result->attr.proc_pointer)
386 : : {
387 : 2 : gfc_error ("Function result %qs at %L has no IMPLICIT type",
388 : : proc->result->name, &proc->result->declared_at);
389 : 2 : proc->result->attr.untyped = 1;
390 : : }
391 : : }
392 : : }
393 : :
394 : :
395 : : /******************** Symbol attribute stuff *********************/
396 : :
397 : : /* This is a generic conflict-checker. We do this to avoid having a
398 : : single conflict in two places. */
399 : :
400 : : #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
401 : : #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
402 : : #define conf_std(a, b, std) if (attr->a && attr->b)\
403 : : {\
404 : : a1 = a;\
405 : : a2 = b;\
406 : : standard = std;\
407 : : goto conflict_std;\
408 : : }
409 : :
410 : : bool
411 : 5831071 : gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
412 : : {
413 : 5831071 : static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
414 : : *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
415 : : *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
416 : : *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
417 : : *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
418 : : *privat = "PRIVATE", *recursive = "RECURSIVE",
419 : : *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
420 : : *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
421 : : *function = "FUNCTION", *subroutine = "SUBROUTINE",
422 : : *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
423 : : *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
424 : : *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
425 : : *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
426 : : *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
427 : : *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT",
428 : : *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
429 : : *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC",
430 : : *pdt_len = "LEN", *pdt_kind = "KIND";
431 : 5831071 : static const char *threadprivate = "THREADPRIVATE";
432 : 5831071 : static const char *omp_declare_target = "OMP DECLARE TARGET";
433 : 5831071 : static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK";
434 : 5831071 : static const char *oacc_declare_copyin = "OACC DECLARE COPYIN";
435 : 5831071 : static const char *oacc_declare_create = "OACC DECLARE CREATE";
436 : 5831071 : static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR";
437 : 5831071 : static const char *oacc_declare_device_resident =
438 : : "OACC DECLARE DEVICE_RESIDENT";
439 : :
440 : 5831071 : const char *a1, *a2;
441 : 5831071 : int standard;
442 : :
443 : 5831071 : if (attr->artificial)
444 : : return true;
445 : :
446 : 5831064 : if (where == NULL)
447 : 3819912 : where = &gfc_current_locus;
448 : :
449 : 5831064 : if (attr->pointer && attr->intent != INTENT_UNKNOWN)
450 : : {
451 : 3634 : a1 = pointer;
452 : 3634 : a2 = intent;
453 : 3634 : standard = GFC_STD_F2003;
454 : 3634 : goto conflict_std;
455 : : }
456 : :
457 : 5827430 : if (attr->in_namelist && (attr->allocatable || attr->pointer))
458 : : {
459 : 613 : a1 = in_namelist;
460 : 613 : a2 = attr->allocatable ? allocatable : pointer;
461 : 613 : standard = GFC_STD_F2003;
462 : 613 : goto conflict_std;
463 : : }
464 : :
465 : : /* Check for attributes not allowed in a BLOCK DATA. */
466 : 5826817 : if (gfc_current_state () == COMP_BLOCK_DATA)
467 : : {
468 : 3308 : a1 = NULL;
469 : :
470 : 3308 : if (attr->in_namelist)
471 : 1 : a1 = in_namelist;
472 : 3308 : if (attr->allocatable)
473 : 0 : a1 = allocatable;
474 : 3308 : if (attr->external)
475 : 0 : a1 = external;
476 : 3308 : if (attr->optional)
477 : 0 : a1 = optional;
478 : 3308 : if (attr->access == ACCESS_PRIVATE)
479 : 0 : a1 = privat;
480 : 3308 : if (attr->access == ACCESS_PUBLIC)
481 : 0 : a1 = publik;
482 : 3308 : if (attr->intent != INTENT_UNKNOWN)
483 : 0 : a1 = intent;
484 : :
485 : 3308 : if (a1 != NULL)
486 : : {
487 : 1 : gfc_error
488 : 1 : ("%s attribute not allowed in BLOCK DATA program unit at %L",
489 : : a1, where);
490 : 1 : return false;
491 : : }
492 : : }
493 : :
494 : 5826816 : if (attr->save == SAVE_EXPLICIT)
495 : : {
496 : 6355 : conf (dummy, save);
497 : 6353 : conf (in_common, save);
498 : 6345 : conf (result, save);
499 : 6342 : conf (automatic, save);
500 : :
501 : 6340 : switch (attr->flavor)
502 : : {
503 : 2 : case FL_PROGRAM:
504 : 2 : case FL_BLOCK_DATA:
505 : 2 : case FL_MODULE:
506 : 2 : case FL_LABEL:
507 : 2 : case_fl_struct:
508 : 2 : case FL_PARAMETER:
509 : 2 : a1 = gfc_code2string (flavors, attr->flavor);
510 : 2 : a2 = save;
511 : 2 : goto conflict;
512 : 2 : case FL_NAMELIST:
513 : 2 : gfc_error ("Namelist group name at %L cannot have the "
514 : : "SAVE attribute", where);
515 : 2 : return false;
516 : : case FL_PROCEDURE:
517 : : /* Conflicts between SAVE and PROCEDURE will be checked at
518 : : resolution stage, see "resolve_fl_procedure". */
519 : : case FL_VARIABLE:
520 : : default:
521 : : break;
522 : : }
523 : : }
524 : :
525 : : /* The copying of procedure dummy arguments for module procedures in
526 : : a submodule occur whilst the current state is COMP_CONTAINS. It
527 : : is necessary, therefore, to let this through. */
528 : 5826797 : if (name && attr->dummy
529 : 219546 : && (attr->function || attr->subroutine)
530 : 1637 : && gfc_current_state () == COMP_CONTAINS
531 : 10 : && !(gfc_new_block && gfc_new_block->abr_modproc_decl))
532 : 3 : gfc_error_now ("internal procedure %qs at %L conflicts with "
533 : : "DUMMY argument", name, where);
534 : :
535 : 5826797 : conf (dummy, entry);
536 : 5826795 : conf (dummy, intrinsic);
537 : 5826794 : conf (dummy, threadprivate);
538 : 5826794 : conf (dummy, omp_declare_target);
539 : 5826794 : conf (dummy, omp_declare_target_link);
540 : 5826794 : conf (pointer, target);
541 : 5826794 : conf (pointer, intrinsic);
542 : 5826794 : conf (pointer, elemental);
543 : 5826792 : conf (pointer, codimension);
544 : 5826773 : conf (allocatable, elemental);
545 : :
546 : 5826772 : conf (in_common, automatic);
547 : 5826766 : conf (result, automatic);
548 : 5826764 : conf (use_assoc, automatic);
549 : 5826764 : conf (dummy, automatic);
550 : :
551 : 5826762 : conf (target, external);
552 : 5826762 : conf (target, intrinsic);
553 : :
554 : 5826762 : if (!attr->if_source)
555 : 5746588 : conf (external, dimension); /* See Fortran 95's R504. */
556 : :
557 : 5826762 : conf (external, intrinsic);
558 : 5826760 : conf (entry, intrinsic);
559 : 5826759 : conf (abstract, intrinsic);
560 : :
561 : 5826756 : if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
562 : 67977 : conf (external, subroutine);
563 : :
564 : 5826754 : if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003,
565 : : "Procedure pointer at %C"))
566 : : return false;
567 : :
568 : 5826748 : conf (allocatable, pointer);
569 : 5826748 : conf_std (allocatable, dummy, GFC_STD_F2003);
570 : 5818248 : conf_std (allocatable, function, GFC_STD_F2003);
571 : 5817588 : conf_std (allocatable, result, GFC_STD_F2003);
572 : 5816625 : conf_std (elemental, recursive, GFC_STD_F2018);
573 : :
574 : 5816614 : conf (in_common, dummy);
575 : 5816614 : conf (in_common, allocatable);
576 : 5816614 : conf (in_common, codimension);
577 : 5816614 : conf (in_common, result);
578 : :
579 : 5816614 : conf (in_equivalence, use_assoc);
580 : 5816613 : conf (in_equivalence, codimension);
581 : 5816613 : conf (in_equivalence, dummy);
582 : 5816613 : conf (in_equivalence, target);
583 : 5816612 : conf (in_equivalence, pointer);
584 : 5816611 : conf (in_equivalence, function);
585 : 5816611 : conf (in_equivalence, result);
586 : 5816611 : conf (in_equivalence, entry);
587 : 5816611 : conf (in_equivalence, allocatable);
588 : 5816609 : conf (in_equivalence, threadprivate);
589 : 5816609 : conf (in_equivalence, omp_declare_target);
590 : 5816609 : conf (in_equivalence, omp_declare_target_link);
591 : 5816609 : conf (in_equivalence, oacc_declare_create);
592 : 5816609 : conf (in_equivalence, oacc_declare_copyin);
593 : 5816609 : conf (in_equivalence, oacc_declare_deviceptr);
594 : 5816609 : conf (in_equivalence, oacc_declare_device_resident);
595 : 5816609 : conf (in_equivalence, is_bind_c);
596 : :
597 : 5816608 : conf (dummy, result);
598 : 5816608 : conf (entry, result);
599 : 5816607 : conf (generic, result);
600 : 5816604 : conf (generic, omp_declare_target);
601 : 5816604 : conf (generic, omp_declare_target_link);
602 : :
603 : 5816604 : conf (function, subroutine);
604 : :
605 : 5816548 : if (!function && !subroutine)
606 : 0 : conf (is_bind_c, dummy);
607 : :
608 : 5816548 : conf (is_bind_c, cray_pointer);
609 : 5816548 : conf (is_bind_c, cray_pointee);
610 : 5816548 : conf (is_bind_c, codimension);
611 : 5816547 : conf (is_bind_c, allocatable);
612 : 5816547 : conf (is_bind_c, elemental);
613 : :
614 : : /* Need to also get volatile attr, according to 5.1 of F2003 draft.
615 : : Parameter conflict caught below. Also, value cannot be specified
616 : : for a dummy procedure. */
617 : :
618 : : /* Cray pointer/pointee conflicts. */
619 : 5816545 : conf (cray_pointer, cray_pointee);
620 : 5816544 : conf (cray_pointer, dimension);
621 : 5816543 : conf (cray_pointer, codimension);
622 : 5816543 : conf (cray_pointer, contiguous);
623 : 5816543 : conf (cray_pointer, pointer);
624 : 5816542 : conf (cray_pointer, target);
625 : 5816541 : conf (cray_pointer, allocatable);
626 : 5816541 : conf (cray_pointer, external);
627 : 5816541 : conf (cray_pointer, intrinsic);
628 : 5816541 : conf (cray_pointer, in_namelist);
629 : 5816541 : conf (cray_pointer, function);
630 : 5816541 : conf (cray_pointer, subroutine);
631 : 5816541 : conf (cray_pointer, entry);
632 : :
633 : 5816541 : conf (cray_pointee, allocatable);
634 : 5816541 : conf (cray_pointee, contiguous);
635 : 5816541 : conf (cray_pointee, codimension);
636 : 5816541 : conf (cray_pointee, intent);
637 : 5816541 : conf (cray_pointee, optional);
638 : 5816541 : conf (cray_pointee, dummy);
639 : 5816540 : conf (cray_pointee, target);
640 : 5816539 : conf (cray_pointee, intrinsic);
641 : 5816539 : conf (cray_pointee, pointer);
642 : 5816538 : conf (cray_pointee, entry);
643 : 5816538 : conf (cray_pointee, in_common);
644 : 5816535 : conf (cray_pointee, in_equivalence);
645 : 5816533 : conf (cray_pointee, threadprivate);
646 : 5816532 : conf (cray_pointee, omp_declare_target);
647 : 5816532 : conf (cray_pointee, omp_declare_target_link);
648 : 5816532 : conf (cray_pointee, oacc_declare_create);
649 : 5816532 : conf (cray_pointee, oacc_declare_copyin);
650 : 5816532 : conf (cray_pointee, oacc_declare_deviceptr);
651 : 5816532 : conf (cray_pointee, oacc_declare_device_resident);
652 : :
653 : 5816532 : conf (data, dummy);
654 : 5816529 : conf (data, function);
655 : 5816528 : conf (data, result);
656 : 5816527 : conf (data, allocatable);
657 : :
658 : 5816526 : conf (value, pointer)
659 : 5816525 : conf (value, allocatable)
660 : 5816525 : conf (value, subroutine)
661 : 5816525 : conf (value, function)
662 : 5816524 : conf (value, volatile_)
663 : 5816524 : conf (value, dimension)
664 : 5816520 : conf (value, codimension)
665 : 5816520 : conf (value, external)
666 : :
667 : 5816519 : conf (codimension, result)
668 : :
669 : 5816516 : if (attr->value
670 : 29457 : && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
671 : : {
672 : 4 : a1 = value;
673 : 4 : a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
674 : 4 : goto conflict;
675 : : }
676 : :
677 : 5816512 : conf (is_protected, intrinsic)
678 : 5816512 : conf (is_protected, in_common)
679 : :
680 : 5816508 : conf (asynchronous, intrinsic)
681 : 5816508 : conf (asynchronous, external)
682 : :
683 : 5816508 : conf (volatile_, intrinsic)
684 : 5816507 : conf (volatile_, external)
685 : :
686 : 5816506 : if (attr->volatile_ && attr->intent == INTENT_IN)
687 : : {
688 : 1 : a1 = volatile_;
689 : 1 : a2 = intent_in;
690 : 1 : goto conflict;
691 : : }
692 : :
693 : 5816505 : conf (procedure, allocatable)
694 : 5816504 : conf (procedure, dimension)
695 : 5816504 : conf (procedure, codimension)
696 : 5816504 : conf (procedure, intrinsic)
697 : 5816504 : conf (procedure, target)
698 : 5816504 : conf (procedure, value)
699 : 5816504 : conf (procedure, volatile_)
700 : 5816504 : conf (procedure, asynchronous)
701 : 5816504 : conf (procedure, entry)
702 : :
703 : 5816503 : conf (proc_pointer, abstract)
704 : 5816501 : conf (proc_pointer, omp_declare_target)
705 : 5816501 : conf (proc_pointer, omp_declare_target_link)
706 : :
707 : 5816501 : conf (entry, omp_declare_target)
708 : 5816501 : conf (entry, omp_declare_target_link)
709 : 5816501 : conf (entry, oacc_declare_create)
710 : 5816501 : conf (entry, oacc_declare_copyin)
711 : 5816501 : conf (entry, oacc_declare_deviceptr)
712 : 5816501 : conf (entry, oacc_declare_device_resident)
713 : :
714 : 5816501 : conf (pdt_kind, allocatable)
715 : 5816500 : conf (pdt_kind, pointer)
716 : 5816499 : conf (pdt_kind, dimension)
717 : 5816498 : conf (pdt_kind, codimension)
718 : :
719 : 5816498 : conf (pdt_len, allocatable)
720 : 5816497 : conf (pdt_len, pointer)
721 : 5816496 : conf (pdt_len, dimension)
722 : 5816495 : conf (pdt_len, codimension)
723 : 5816495 : conf (pdt_len, pdt_kind)
724 : :
725 : 5816493 : if (attr->access == ACCESS_PRIVATE)
726 : : {
727 : 11144 : a1 = privat;
728 : 11144 : conf2 (pdt_kind);
729 : 11143 : conf2 (pdt_len);
730 : : }
731 : :
732 : 5816491 : a1 = gfc_code2string (flavors, attr->flavor);
733 : :
734 : 5816491 : if (attr->in_namelist
735 : 3663 : && attr->flavor != FL_VARIABLE
736 : 1613 : && attr->flavor != FL_PROCEDURE
737 : 1604 : && attr->flavor != FL_UNKNOWN)
738 : : {
739 : 0 : a2 = in_namelist;
740 : 0 : goto conflict;
741 : : }
742 : :
743 : 5816491 : switch (attr->flavor)
744 : : {
745 : 129529 : case FL_PROGRAM:
746 : 129529 : case FL_BLOCK_DATA:
747 : 129529 : case FL_MODULE:
748 : 129529 : case FL_LABEL:
749 : 129529 : conf2 (codimension);
750 : 129529 : conf2 (dimension);
751 : 129528 : conf2 (dummy);
752 : 129528 : conf2 (volatile_);
753 : 129526 : conf2 (asynchronous);
754 : 129525 : conf2 (contiguous);
755 : 129525 : conf2 (pointer);
756 : 129525 : conf2 (is_protected);
757 : 129524 : conf2 (target);
758 : 129524 : conf2 (external);
759 : 129523 : conf2 (intrinsic);
760 : 129523 : conf2 (allocatable);
761 : 129523 : conf2 (result);
762 : 129523 : conf2 (in_namelist);
763 : 129523 : conf2 (optional);
764 : 129523 : conf2 (function);
765 : 129523 : conf2 (subroutine);
766 : 129522 : conf2 (threadprivate);
767 : 129522 : conf2 (omp_declare_target);
768 : 129522 : conf2 (omp_declare_target_link);
769 : 129522 : conf2 (oacc_declare_create);
770 : 129522 : conf2 (oacc_declare_copyin);
771 : 129522 : conf2 (oacc_declare_deviceptr);
772 : 129522 : conf2 (oacc_declare_device_resident);
773 : :
774 : 129522 : if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
775 : : {
776 : 2 : a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
777 : 2 : gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
778 : : name, where);
779 : 2 : return false;
780 : : }
781 : :
782 : 129520 : if (attr->is_bind_c)
783 : : {
784 : 2 : gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
785 : 2 : return false;
786 : : }
787 : :
788 : : break;
789 : :
790 : : case FL_VARIABLE:
791 : : break;
792 : :
793 : 724 : case FL_NAMELIST:
794 : 724 : conf2 (result);
795 : : break;
796 : :
797 : 3632290 : case FL_PROCEDURE:
798 : : /* Conflicts with INTENT, SAVE and RESULT will be checked
799 : : at resolution stage, see "resolve_fl_procedure". */
800 : :
801 : 3632290 : if (attr->subroutine)
802 : : {
803 : 84809 : a1 = subroutine;
804 : 84809 : conf2 (target);
805 : 84809 : conf2 (allocatable);
806 : 84809 : conf2 (volatile_);
807 : 84808 : conf2 (asynchronous);
808 : 84807 : conf2 (in_namelist);
809 : 84807 : conf2 (codimension);
810 : 84807 : conf2 (dimension);
811 : 84806 : conf2 (function);
812 : 84806 : if (!attr->proc_pointer)
813 : 84549 : conf2 (threadprivate);
814 : : }
815 : :
816 : : /* Procedure pointers in COMMON blocks are allowed in F03,
817 : : * but forbidden per F08:C5100. */
818 : 3632287 : if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008))
819 : 3632057 : conf2 (in_common);
820 : :
821 : 3632283 : conf2 (omp_declare_target_link);
822 : :
823 : 3632281 : switch (attr->proc)
824 : : {
825 : 698621 : case PROC_ST_FUNCTION:
826 : 698621 : conf2 (dummy);
827 : 698620 : conf2 (target);
828 : : break;
829 : :
830 : 44043 : case PROC_MODULE:
831 : 44043 : conf2 (dummy);
832 : : break;
833 : :
834 : 0 : case PROC_DUMMY:
835 : 0 : conf2 (result);
836 : 0 : conf2 (threadprivate);
837 : : break;
838 : :
839 : : default:
840 : : break;
841 : : }
842 : :
843 : : break;
844 : :
845 : 30439 : case_fl_struct:
846 : 30439 : conf2 (dummy);
847 : 30439 : conf2 (pointer);
848 : 30439 : conf2 (target);
849 : 30439 : conf2 (external);
850 : 30439 : conf2 (intrinsic);
851 : 30439 : conf2 (allocatable);
852 : 30439 : conf2 (optional);
853 : 30439 : conf2 (entry);
854 : 30439 : conf2 (function);
855 : 30439 : conf2 (subroutine);
856 : 30439 : conf2 (threadprivate);
857 : 30439 : conf2 (result);
858 : 30439 : conf2 (omp_declare_target);
859 : 30439 : conf2 (omp_declare_target_link);
860 : 30439 : conf2 (oacc_declare_create);
861 : 30439 : conf2 (oacc_declare_copyin);
862 : 30439 : conf2 (oacc_declare_deviceptr);
863 : 30439 : conf2 (oacc_declare_device_resident);
864 : :
865 : 30439 : if (attr->intent != INTENT_UNKNOWN)
866 : : {
867 : 0 : a2 = intent;
868 : 0 : goto conflict;
869 : : }
870 : : break;
871 : :
872 : 32571 : case FL_PARAMETER:
873 : 32571 : conf2 (external);
874 : 32571 : conf2 (intrinsic);
875 : 32571 : conf2 (optional);
876 : 32571 : conf2 (allocatable);
877 : 32571 : conf2 (function);
878 : 32571 : conf2 (subroutine);
879 : 32571 : conf2 (entry);
880 : 32571 : conf2 (contiguous);
881 : 32571 : conf2 (pointer);
882 : 32571 : conf2 (is_protected);
883 : 32571 : conf2 (target);
884 : 32571 : conf2 (dummy);
885 : 32571 : conf2 (in_common);
886 : 32571 : conf2 (value);
887 : 32570 : conf2 (volatile_);
888 : 32569 : conf2 (asynchronous);
889 : 32569 : conf2 (threadprivate);
890 : 32569 : conf2 (value);
891 : 32569 : conf2 (codimension);
892 : 32568 : conf2 (result);
893 : 32567 : if (!attr->is_iso_c)
894 : 32551 : conf2 (is_bind_c);
895 : : break;
896 : :
897 : : default:
898 : : break;
899 : : }
900 : :
901 : : return true;
902 : :
903 : 208 : conflict:
904 : 208 : if (name == NULL)
905 : 57 : gfc_error ("%s attribute conflicts with %s attribute at %L",
906 : : a1, a2, where);
907 : : else
908 : 151 : gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
909 : : a1, a2, name, where);
910 : :
911 : : return false;
912 : :
913 : 14381 : conflict_std:
914 : 14381 : if (name == NULL)
915 : : {
916 : 8635 : return gfc_notify_std (standard, "%s attribute conflicts "
917 : : "with %s attribute at %L", a1, a2,
918 : 8635 : where);
919 : : }
920 : : else
921 : : {
922 : 5746 : return gfc_notify_std (standard, "%s attribute conflicts "
923 : : "with %s attribute in %qs at %L",
924 : 5746 : a1, a2, name, where);
925 : : }
926 : : }
927 : :
928 : : #undef conf
929 : : #undef conf2
930 : : #undef conf_std
931 : :
932 : :
933 : : /* Mark a symbol as referenced. */
934 : :
935 : : void
936 : 6509482 : gfc_set_sym_referenced (gfc_symbol *sym)
937 : : {
938 : :
939 : 6509482 : if (sym->attr.referenced)
940 : : return;
941 : :
942 : 3467864 : sym->attr.referenced = 1;
943 : :
944 : : /* Remember which order dummy variables are accessed in. */
945 : 3467864 : if (sym->attr.dummy)
946 : 97750 : sym->dummy_order = next_dummy_order++;
947 : : }
948 : :
949 : :
950 : : /* Common subroutine called by attribute changing subroutines in order
951 : : to prevent them from changing a symbol that has been
952 : : use-associated. Returns zero if it is OK to change the symbol,
953 : : nonzero if not. */
954 : :
955 : : static int
956 : 1931559 : check_used (symbol_attribute *attr, const char *name, locus *where)
957 : : {
958 : :
959 : 1931559 : if (attr->use_assoc == 0)
960 : : return 0;
961 : :
962 : 52 : if (where == NULL)
963 : 25 : where = &gfc_current_locus;
964 : :
965 : 52 : if (name == NULL)
966 : 3 : gfc_error ("Cannot change attributes of USE-associated symbol at %L",
967 : : where);
968 : : else
969 : 49 : gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
970 : : name, where);
971 : :
972 : : return 1;
973 : : }
974 : :
975 : :
976 : : /* Generate an error because of a duplicate attribute. */
977 : :
978 : : static void
979 : 21 : duplicate_attr (const char *attr, locus *where)
980 : : {
981 : :
982 : 0 : if (where == NULL)
983 : 7 : where = &gfc_current_locus;
984 : :
985 : 0 : gfc_error ("Duplicate %s attribute specified at %L", attr, where);
986 : 0 : }
987 : :
988 : :
989 : : bool
990 : 2486 : gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
991 : : locus *where ATTRIBUTE_UNUSED)
992 : : {
993 : 2486 : attr->ext_attr |= 1 << ext_attr;
994 : 2486 : return true;
995 : : }
996 : :
997 : :
998 : : /* Called from decl.cc (attr_decl1) to check attributes, when declared
999 : : separately. */
1000 : :
1001 : : bool
1002 : 9438 : gfc_add_attribute (symbol_attribute *attr, locus *where)
1003 : : {
1004 : 9438 : if (check_used (attr, NULL, where))
1005 : : return false;
1006 : :
1007 : 9438 : return gfc_check_conflict (attr, NULL, where);
1008 : : }
1009 : :
1010 : :
1011 : : bool
1012 : 26028 : gfc_add_allocatable (symbol_attribute *attr, locus *where)
1013 : : {
1014 : :
1015 : 26028 : if (check_used (attr, NULL, where))
1016 : : return false;
1017 : :
1018 : 26028 : if (attr->allocatable && ! gfc_submodule_procedure(attr))
1019 : : {
1020 : 1 : duplicate_attr ("ALLOCATABLE", where);
1021 : 1 : return false;
1022 : : }
1023 : :
1024 : 26027 : if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
1025 : 26027 : && !gfc_find_state (COMP_INTERFACE))
1026 : : {
1027 : 1 : gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
1028 : : where);
1029 : 1 : return false;
1030 : : }
1031 : :
1032 : 26026 : attr->allocatable = 1;
1033 : 26026 : return gfc_check_conflict (attr, NULL, where);
1034 : : }
1035 : :
1036 : :
1037 : : bool
1038 : 82 : gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where)
1039 : : {
1040 : 82 : if (check_used (attr, name, where))
1041 : : return false;
1042 : :
1043 : 82 : if (attr->automatic && !gfc_notify_std (GFC_STD_LEGACY,
1044 : : "Duplicate AUTOMATIC attribute specified at %L", where))
1045 : : return false;
1046 : :
1047 : 82 : attr->automatic = 1;
1048 : 82 : return gfc_check_conflict (attr, name, where);
1049 : : }
1050 : :
1051 : :
1052 : : bool
1053 : 1263 : gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
1054 : : {
1055 : :
1056 : 1263 : if (check_used (attr, name, where))
1057 : : return false;
1058 : :
1059 : 1263 : if (attr->codimension)
1060 : : {
1061 : 2 : duplicate_attr ("CODIMENSION", where);
1062 : 2 : return false;
1063 : : }
1064 : :
1065 : 1261 : if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
1066 : 1261 : && !gfc_find_state (COMP_INTERFACE))
1067 : : {
1068 : 0 : gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
1069 : : "at %L", name, where);
1070 : 0 : return false;
1071 : : }
1072 : :
1073 : 1261 : attr->codimension = 1;
1074 : 1261 : return gfc_check_conflict (attr, name, where);
1075 : : }
1076 : :
1077 : :
1078 : : bool
1079 : 84450 : gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
1080 : : {
1081 : :
1082 : 84450 : if (check_used (attr, name, where))
1083 : : return false;
1084 : :
1085 : 84450 : if (attr->dimension && ! gfc_submodule_procedure(attr))
1086 : : {
1087 : 2 : duplicate_attr ("DIMENSION", where);
1088 : 2 : return false;
1089 : : }
1090 : :
1091 : 84448 : if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
1092 : 84448 : && !gfc_find_state (COMP_INTERFACE))
1093 : : {
1094 : 1 : gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
1095 : : "at %L", name, where);
1096 : 1 : return false;
1097 : : }
1098 : :
1099 : 84447 : attr->dimension = 1;
1100 : 84447 : return gfc_check_conflict (attr, name, where);
1101 : : }
1102 : :
1103 : :
1104 : : bool
1105 : 3700 : gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
1106 : : {
1107 : :
1108 : 3700 : if (check_used (attr, name, where))
1109 : : return false;
1110 : :
1111 : 3700 : if (attr->contiguous)
1112 : : {
1113 : 2 : duplicate_attr ("CONTIGUOUS", where);
1114 : 2 : return false;
1115 : : }
1116 : :
1117 : 3698 : attr->contiguous = 1;
1118 : 3698 : return gfc_check_conflict (attr, name, where);
1119 : : }
1120 : :
1121 : :
1122 : : bool
1123 : 16239 : gfc_add_external (symbol_attribute *attr, locus *where)
1124 : : {
1125 : :
1126 : 16239 : if (check_used (attr, NULL, where))
1127 : : return false;
1128 : :
1129 : 16236 : if (attr->external)
1130 : : {
1131 : 4 : duplicate_attr ("EXTERNAL", where);
1132 : 4 : return false;
1133 : : }
1134 : :
1135 : 16232 : if (attr->pointer && attr->if_source != IFSRC_IFBODY)
1136 : : {
1137 : 756 : attr->pointer = 0;
1138 : 756 : attr->proc_pointer = 1;
1139 : : }
1140 : :
1141 : 16232 : attr->external = 1;
1142 : :
1143 : 16232 : return gfc_check_conflict (attr, NULL, where);
1144 : : }
1145 : :
1146 : :
1147 : : bool
1148 : 1689 : gfc_add_intrinsic (symbol_attribute *attr, locus *where)
1149 : : {
1150 : :
1151 : 1689 : if (check_used (attr, NULL, where))
1152 : : return false;
1153 : :
1154 : 1689 : if (attr->intrinsic)
1155 : : {
1156 : 0 : duplicate_attr ("INTRINSIC", where);
1157 : 0 : return false;
1158 : : }
1159 : :
1160 : 1689 : attr->intrinsic = 1;
1161 : :
1162 : 1689 : return gfc_check_conflict (attr, NULL, where);
1163 : : }
1164 : :
1165 : :
1166 : : bool
1167 : 8481 : gfc_add_optional (symbol_attribute *attr, locus *where)
1168 : : {
1169 : :
1170 : 8481 : if (check_used (attr, NULL, where))
1171 : : return false;
1172 : :
1173 : 8481 : if (attr->optional)
1174 : : {
1175 : 1 : duplicate_attr ("OPTIONAL", where);
1176 : 1 : return false;
1177 : : }
1178 : :
1179 : 8480 : attr->optional = 1;
1180 : 8480 : return gfc_check_conflict (attr, NULL, where);
1181 : : }
1182 : :
1183 : : bool
1184 : 122 : gfc_add_kind (symbol_attribute *attr, locus *where)
1185 : : {
1186 : 122 : if (attr->pdt_kind)
1187 : : {
1188 : 0 : duplicate_attr ("KIND", where);
1189 : 0 : return false;
1190 : : }
1191 : :
1192 : 122 : attr->pdt_kind = 1;
1193 : 122 : return gfc_check_conflict (attr, NULL, where);
1194 : : }
1195 : :
1196 : : bool
1197 : 153 : gfc_add_len (symbol_attribute *attr, locus *where)
1198 : : {
1199 : 153 : if (attr->pdt_len)
1200 : : {
1201 : 0 : duplicate_attr ("LEN", where);
1202 : 0 : return false;
1203 : : }
1204 : :
1205 : 153 : attr->pdt_len = 1;
1206 : 153 : return gfc_check_conflict (attr, NULL, where);
1207 : : }
1208 : :
1209 : :
1210 : : bool
1211 : 23624 : gfc_add_pointer (symbol_attribute *attr, locus *where)
1212 : : {
1213 : :
1214 : 23624 : if (check_used (attr, NULL, where))
1215 : : return false;
1216 : :
1217 : 3 : if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
1218 : 1 : && !gfc_find_state (COMP_INTERFACE))
1219 : 23625 : && ! gfc_submodule_procedure(attr))
1220 : : {
1221 : 1 : duplicate_attr ("POINTER", where);
1222 : 1 : return false;
1223 : : }
1224 : :
1225 : 23615 : if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
1226 : 47217 : || (attr->if_source == IFSRC_IFBODY
1227 : 169 : && !gfc_find_state (COMP_INTERFACE)))
1228 : 36 : attr->proc_pointer = 1;
1229 : : else
1230 : 23587 : attr->pointer = 1;
1231 : :
1232 : 23623 : return gfc_check_conflict (attr, NULL, where);
1233 : : }
1234 : :
1235 : :
1236 : : bool
1237 : 640 : gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
1238 : : {
1239 : :
1240 : 640 : if (check_used (attr, NULL, where))
1241 : : return false;
1242 : :
1243 : 640 : attr->cray_pointer = 1;
1244 : 640 : return gfc_check_conflict (attr, NULL, where);
1245 : : }
1246 : :
1247 : :
1248 : : bool
1249 : 624 : gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
1250 : : {
1251 : :
1252 : 624 : if (check_used (attr, NULL, where))
1253 : : return false;
1254 : :
1255 : 624 : if (attr->cray_pointee)
1256 : : {
1257 : 1 : gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1258 : : " statements", where);
1259 : 1 : return false;
1260 : : }
1261 : :
1262 : 623 : attr->cray_pointee = 1;
1263 : 623 : return gfc_check_conflict (attr, NULL, where);
1264 : : }
1265 : :
1266 : :
1267 : : bool
1268 : 108 : gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1269 : : {
1270 : 108 : if (check_used (attr, name, where))
1271 : : return false;
1272 : :
1273 : 108 : if (attr->is_protected)
1274 : : {
1275 : 0 : if (!gfc_notify_std (GFC_STD_LEGACY,
1276 : : "Duplicate PROTECTED attribute specified at %L",
1277 : : where))
1278 : : return false;
1279 : : }
1280 : :
1281 : 108 : attr->is_protected = 1;
1282 : 108 : return gfc_check_conflict (attr, name, where);
1283 : : }
1284 : :
1285 : :
1286 : : bool
1287 : 5312 : gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1288 : : {
1289 : :
1290 : 5312 : if (check_used (attr, name, where))
1291 : : return false;
1292 : :
1293 : 5312 : attr->result = 1;
1294 : 5312 : return gfc_check_conflict (attr, name, where);
1295 : : }
1296 : :
1297 : :
1298 : : bool
1299 : 9197 : gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
1300 : : locus *where)
1301 : : {
1302 : :
1303 : 9197 : if (check_used (attr, name, where))
1304 : : return false;
1305 : :
1306 : 9197 : if (s == SAVE_EXPLICIT && gfc_pure (NULL))
1307 : : {
1308 : 2 : gfc_error
1309 : 2 : ("SAVE attribute at %L cannot be specified in a PURE procedure",
1310 : : where);
1311 : 2 : return false;
1312 : : }
1313 : :
1314 : 9195 : if (s == SAVE_EXPLICIT)
1315 : 3560 : gfc_unset_implicit_pure (NULL);
1316 : :
1317 : 3560 : if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT
1318 : 57 : && (flag_automatic || pedantic))
1319 : : {
1320 : 20 : if (!gfc_notify_std (GFC_STD_LEGACY,
1321 : : "Duplicate SAVE attribute specified at %L",
1322 : : where))
1323 : : return false;
1324 : : }
1325 : :
1326 : 9193 : attr->save = s;
1327 : 9193 : return gfc_check_conflict (attr, name, where);
1328 : : }
1329 : :
1330 : :
1331 : : bool
1332 : 15885 : gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1333 : : {
1334 : :
1335 : 15885 : if (check_used (attr, name, where))
1336 : : return false;
1337 : :
1338 : 15885 : if (attr->value)
1339 : : {
1340 : 0 : if (!gfc_notify_std (GFC_STD_LEGACY,
1341 : : "Duplicate VALUE attribute specified at %L",
1342 : : where))
1343 : : return false;
1344 : : }
1345 : :
1346 : 15885 : attr->value = 1;
1347 : 15885 : return gfc_check_conflict (attr, name, where);
1348 : : }
1349 : :
1350 : :
1351 : : bool
1352 : 1275 : gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1353 : : {
1354 : : /* No check_used needed as 11.2.1 of the F2003 standard allows
1355 : : that the local identifier made accessible by a use statement can be
1356 : : given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1357 : :
1358 : 1275 : if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1359 : 1 : if (!gfc_notify_std (GFC_STD_LEGACY,
1360 : : "Duplicate VOLATILE attribute specified at %L",
1361 : : where))
1362 : : return false;
1363 : :
1364 : : /* F2008: C1282 A designator of a variable with the VOLATILE attribute
1365 : : shall not appear in a pure subprogram.
1366 : :
1367 : : F2018: C1588 A local variable of a pure subprogram, or of a BLOCK
1368 : : construct within a pure subprogram, shall not have the SAVE or
1369 : : VOLATILE attribute. */
1370 : 1275 : if (gfc_pure (NULL))
1371 : : {
1372 : 2 : gfc_error ("VOLATILE attribute at %L cannot be specified in a "
1373 : : "PURE procedure", where);
1374 : 2 : return false;
1375 : : }
1376 : :
1377 : :
1378 : 1273 : attr->volatile_ = 1;
1379 : 1273 : attr->volatile_ns = gfc_current_ns;
1380 : 1273 : return gfc_check_conflict (attr, name, where);
1381 : : }
1382 : :
1383 : :
1384 : : bool
1385 : 57 : gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1386 : : {
1387 : : /* No check_used needed as 11.2.1 of the F2003 standard allows
1388 : : that the local identifier made accessible by a use statement can be
1389 : : given a ASYNCHRONOUS attribute. */
1390 : :
1391 : 57 : if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
1392 : 0 : if (!gfc_notify_std (GFC_STD_LEGACY,
1393 : : "Duplicate ASYNCHRONOUS attribute specified at %L",
1394 : : where))
1395 : : return false;
1396 : :
1397 : 57 : attr->asynchronous = 1;
1398 : 57 : attr->asynchronous_ns = gfc_current_ns;
1399 : 57 : return gfc_check_conflict (attr, name, where);
1400 : : }
1401 : :
1402 : :
1403 : : bool
1404 : 281 : gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1405 : : {
1406 : :
1407 : 281 : if (check_used (attr, name, where))
1408 : : return false;
1409 : :
1410 : 281 : if (attr->threadprivate)
1411 : : {
1412 : 0 : duplicate_attr ("THREADPRIVATE", where);
1413 : 0 : return false;
1414 : : }
1415 : :
1416 : 281 : attr->threadprivate = 1;
1417 : 281 : return gfc_check_conflict (attr, name, where);
1418 : : }
1419 : :
1420 : :
1421 : : bool
1422 : 1043 : gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
1423 : : locus *where)
1424 : : {
1425 : :
1426 : 1043 : if (check_used (attr, name, where))
1427 : : return false;
1428 : :
1429 : 1017 : if (attr->omp_declare_target)
1430 : : return true;
1431 : :
1432 : 956 : attr->omp_declare_target = 1;
1433 : 956 : return gfc_check_conflict (attr, name, where);
1434 : : }
1435 : :
1436 : :
1437 : : bool
1438 : 41 : gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name,
1439 : : locus *where)
1440 : : {
1441 : :
1442 : 41 : if (check_used (attr, name, where))
1443 : : return false;
1444 : :
1445 : 41 : if (attr->omp_declare_target_link)
1446 : : return true;
1447 : :
1448 : 27 : attr->omp_declare_target_link = 1;
1449 : 27 : return gfc_check_conflict (attr, name, where);
1450 : : }
1451 : :
1452 : :
1453 : : bool
1454 : 0 : gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name,
1455 : : locus *where)
1456 : : {
1457 : 0 : if (check_used (attr, name, where))
1458 : : return false;
1459 : :
1460 : 0 : if (attr->oacc_declare_create)
1461 : : return true;
1462 : :
1463 : 0 : attr->oacc_declare_create = 1;
1464 : 0 : return gfc_check_conflict (attr, name, where);
1465 : : }
1466 : :
1467 : :
1468 : : bool
1469 : 0 : gfc_add_oacc_declare_copyin (symbol_attribute *attr, const char *name,
1470 : : locus *where)
1471 : : {
1472 : 0 : if (check_used (attr, name, where))
1473 : : return false;
1474 : :
1475 : 0 : if (attr->oacc_declare_copyin)
1476 : : return true;
1477 : :
1478 : 0 : attr->oacc_declare_copyin = 1;
1479 : 0 : return gfc_check_conflict (attr, name, where);
1480 : : }
1481 : :
1482 : :
1483 : : bool
1484 : 0 : gfc_add_oacc_declare_deviceptr (symbol_attribute *attr, const char *name,
1485 : : locus *where)
1486 : : {
1487 : 0 : if (check_used (attr, name, where))
1488 : : return false;
1489 : :
1490 : 0 : if (attr->oacc_declare_deviceptr)
1491 : : return true;
1492 : :
1493 : 0 : attr->oacc_declare_deviceptr = 1;
1494 : 0 : return gfc_check_conflict (attr, name, where);
1495 : : }
1496 : :
1497 : :
1498 : : bool
1499 : 0 : gfc_add_oacc_declare_device_resident (symbol_attribute *attr, const char *name,
1500 : : locus *where)
1501 : : {
1502 : 0 : if (check_used (attr, name, where))
1503 : : return false;
1504 : :
1505 : 0 : if (attr->oacc_declare_device_resident)
1506 : : return true;
1507 : :
1508 : 0 : attr->oacc_declare_device_resident = 1;
1509 : 0 : return gfc_check_conflict (attr, name, where);
1510 : : }
1511 : :
1512 : :
1513 : : bool
1514 : 11043 : gfc_add_target (symbol_attribute *attr, locus *where)
1515 : : {
1516 : :
1517 : 11043 : if (check_used (attr, NULL, where))
1518 : : return false;
1519 : :
1520 : 11043 : if (attr->target)
1521 : : {
1522 : 1 : duplicate_attr ("TARGET", where);
1523 : 1 : return false;
1524 : : }
1525 : :
1526 : 11042 : attr->target = 1;
1527 : 11042 : return gfc_check_conflict (attr, NULL, where);
1528 : : }
1529 : :
1530 : :
1531 : : bool
1532 : 84403 : gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1533 : : {
1534 : :
1535 : 84403 : if (check_used (attr, name, where))
1536 : : return false;
1537 : :
1538 : : /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1539 : 84403 : attr->dummy = 1;
1540 : 84403 : return gfc_check_conflict (attr, name, where);
1541 : : }
1542 : :
1543 : :
1544 : : bool
1545 : 11632 : gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1546 : : {
1547 : :
1548 : 11632 : if (check_used (attr, name, where))
1549 : : return false;
1550 : :
1551 : : /* Duplicate attribute already checked for. */
1552 : 11632 : attr->in_common = 1;
1553 : 11632 : return gfc_check_conflict (attr, name, where);
1554 : : }
1555 : :
1556 : :
1557 : : bool
1558 : 2973 : gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1559 : : {
1560 : :
1561 : : /* Duplicate attribute already checked for. */
1562 : 2973 : attr->in_equivalence = 1;
1563 : 2973 : if (!gfc_check_conflict (attr, name, where))
1564 : : return false;
1565 : :
1566 : 2966 : if (attr->flavor == FL_VARIABLE)
1567 : : return true;
1568 : :
1569 : 109 : return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1570 : : }
1571 : :
1572 : :
1573 : : bool
1574 : 3020 : gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1575 : : {
1576 : :
1577 : 3020 : if (check_used (attr, name, where))
1578 : : return false;
1579 : :
1580 : 3019 : attr->data = 1;
1581 : 3019 : return gfc_check_conflict (attr, name, where);
1582 : : }
1583 : :
1584 : :
1585 : : bool
1586 : 1937 : gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1587 : : {
1588 : :
1589 : 1937 : attr->in_namelist = 1;
1590 : 1937 : return gfc_check_conflict (attr, name, where);
1591 : : }
1592 : :
1593 : :
1594 : : bool
1595 : 958 : gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1596 : : {
1597 : :
1598 : 958 : if (check_used (attr, name, where))
1599 : : return false;
1600 : :
1601 : 958 : attr->sequence = 1;
1602 : 958 : return gfc_check_conflict (attr, name, where);
1603 : : }
1604 : :
1605 : :
1606 : : bool
1607 : 7127 : gfc_add_elemental (symbol_attribute *attr, locus *where)
1608 : : {
1609 : :
1610 : 7127 : if (check_used (attr, NULL, where))
1611 : : return false;
1612 : :
1613 : 7127 : if (attr->elemental)
1614 : : {
1615 : 2 : duplicate_attr ("ELEMENTAL", where);
1616 : 2 : return false;
1617 : : }
1618 : :
1619 : 7125 : attr->elemental = 1;
1620 : 7125 : return gfc_check_conflict (attr, NULL, where);
1621 : : }
1622 : :
1623 : :
1624 : : bool
1625 : 9674 : gfc_add_pure (symbol_attribute *attr, locus *where)
1626 : : {
1627 : :
1628 : 9674 : if (check_used (attr, NULL, where))
1629 : : return false;
1630 : :
1631 : 9674 : if (attr->pure)
1632 : : {
1633 : 2 : duplicate_attr ("PURE", where);
1634 : 2 : return false;
1635 : : }
1636 : :
1637 : 9672 : attr->pure = 1;
1638 : 9672 : return gfc_check_conflict (attr, NULL, where);
1639 : : }
1640 : :
1641 : :
1642 : : bool
1643 : 709 : gfc_add_recursive (symbol_attribute *attr, locus *where)
1644 : : {
1645 : :
1646 : 709 : if (check_used (attr, NULL, where))
1647 : : return false;
1648 : :
1649 : 709 : if (attr->recursive)
1650 : : {
1651 : 2 : duplicate_attr ("RECURSIVE", where);
1652 : 2 : return false;
1653 : : }
1654 : :
1655 : 707 : attr->recursive = 1;
1656 : 707 : return gfc_check_conflict (attr, NULL, where);
1657 : : }
1658 : :
1659 : :
1660 : : bool
1661 : 758 : gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1662 : : {
1663 : :
1664 : 758 : if (check_used (attr, name, where))
1665 : : return false;
1666 : :
1667 : 758 : if (attr->entry)
1668 : : {
1669 : 0 : duplicate_attr ("ENTRY", where);
1670 : 0 : return false;
1671 : : }
1672 : :
1673 : 758 : attr->entry = 1;
1674 : 758 : return gfc_check_conflict (attr, name, where);
1675 : : }
1676 : :
1677 : :
1678 : : bool
1679 : 854308 : gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1680 : : {
1681 : :
1682 : 854308 : if (attr->flavor != FL_PROCEDURE
1683 : 854308 : && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1684 : : return false;
1685 : :
1686 : 854308 : attr->function = 1;
1687 : 854308 : return gfc_check_conflict (attr, name, where);
1688 : : }
1689 : :
1690 : :
1691 : : bool
1692 : 106362 : gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1693 : : {
1694 : :
1695 : 106362 : if (attr->flavor != FL_PROCEDURE
1696 : 106362 : && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1697 : : return false;
1698 : :
1699 : 106359 : attr->subroutine = 1;
1700 : :
1701 : : /* If we are looking at a BLOCK DATA statement and we encounter a
1702 : : name with a leading underscore (which must be
1703 : : compiler-generated), do not check. See PR 84394. */
1704 : :
1705 : 106359 : if (name && *name != '_' && gfc_current_state () != COMP_BLOCK_DATA)
1706 : 63773 : return gfc_check_conflict (attr, name, where);
1707 : : else
1708 : : return true;
1709 : : }
1710 : :
1711 : :
1712 : : bool
1713 : 21643 : gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1714 : : {
1715 : :
1716 : 21643 : if (attr->flavor != FL_PROCEDURE
1717 : 21643 : && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1718 : : return false;
1719 : :
1720 : 21641 : attr->generic = 1;
1721 : 21641 : return gfc_check_conflict (attr, name, where);
1722 : : }
1723 : :
1724 : :
1725 : : bool
1726 : 1495 : gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1727 : : {
1728 : :
1729 : 1495 : if (check_used (attr, NULL, where))
1730 : : return false;
1731 : :
1732 : 1495 : if (attr->flavor != FL_PROCEDURE
1733 : 1495 : && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1734 : : return false;
1735 : :
1736 : 1495 : if (attr->procedure)
1737 : : {
1738 : 0 : duplicate_attr ("PROCEDURE", where);
1739 : 0 : return false;
1740 : : }
1741 : :
1742 : 1495 : attr->procedure = 1;
1743 : :
1744 : 1495 : return gfc_check_conflict (attr, NULL, where);
1745 : : }
1746 : :
1747 : :
1748 : : bool
1749 : 643 : gfc_add_abstract (symbol_attribute* attr, locus* where)
1750 : : {
1751 : 643 : if (attr->abstract)
1752 : : {
1753 : 1 : duplicate_attr ("ABSTRACT", where);
1754 : 1 : return false;
1755 : : }
1756 : :
1757 : 642 : attr->abstract = 1;
1758 : :
1759 : 642 : return gfc_check_conflict (attr, NULL, where);
1760 : : }
1761 : :
1762 : :
1763 : : /* Flavors are special because some flavors are not what Fortran
1764 : : considers attributes and can be reaffirmed multiple times. */
1765 : :
1766 : : bool
1767 : 3232135 : gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1768 : : locus *where)
1769 : : {
1770 : :
1771 : 3232135 : if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1772 : 3232135 : || f == FL_PARAMETER || f == FL_LABEL || gfc_fl_struct(f)
1773 : 191039 : || f == FL_NAMELIST) && check_used (attr, name, where))
1774 : : return false;
1775 : :
1776 : 3232135 : if (attr->flavor == f && f == FL_VARIABLE)
1777 : : return true;
1778 : :
1779 : : /* Copying a procedure dummy argument for a module procedure in a
1780 : : submodule results in the flavor being copied and would result in
1781 : : an error without this. */
1782 : 3232133 : if (attr->flavor == f && f == FL_PROCEDURE
1783 : 457 : && gfc_new_block && gfc_new_block->abr_modproc_decl)
1784 : : return true;
1785 : :
1786 : 3232126 : if (attr->flavor != FL_UNKNOWN)
1787 : : {
1788 : 513 : if (where == NULL)
1789 : 401 : where = &gfc_current_locus;
1790 : :
1791 : 513 : if (name)
1792 : 350 : gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
1793 : 175 : gfc_code2string (flavors, attr->flavor), name,
1794 : : gfc_code2string (flavors, f), where);
1795 : : else
1796 : 676 : gfc_error ("%s attribute conflicts with %s attribute at %L",
1797 : 338 : gfc_code2string (flavors, attr->flavor),
1798 : : gfc_code2string (flavors, f), where);
1799 : :
1800 : 513 : return false;
1801 : : }
1802 : :
1803 : 3231613 : attr->flavor = f;
1804 : :
1805 : 3231613 : return gfc_check_conflict (attr, name, where);
1806 : : }
1807 : :
1808 : :
1809 : : bool
1810 : 1231678 : gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1811 : : const char *name, locus *where)
1812 : : {
1813 : :
1814 : 1231678 : if (check_used (attr, name, where))
1815 : : return false;
1816 : :
1817 : 1231656 : if (attr->flavor != FL_PROCEDURE
1818 : 1231656 : && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1819 : : return false;
1820 : :
1821 : 1231606 : if (where == NULL)
1822 : 1217293 : where = &gfc_current_locus;
1823 : :
1824 : 1231606 : if (attr->proc != PROC_UNKNOWN && !attr->module_procedure
1825 : 194 : && attr->access == ACCESS_UNKNOWN)
1826 : : {
1827 : 0 : if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL
1828 : 167 : && !gfc_notification_std (GFC_STD_F2008))
1829 : 0 : gfc_error ("%s procedure at %L is already declared as %s "
1830 : : "procedure. \nF2008: A pointer function assignment "
1831 : : "is ambiguous if it is the first executable statement "
1832 : : "after the specification block. Please add any other "
1833 : : "kind of executable statement before it. FIXME",
1834 : : gfc_code2string (procedures, t), where,
1835 : 0 : gfc_code2string (procedures, attr->proc));
1836 : : else
1837 : 167 : gfc_error ("%s procedure at %L is already declared as %s "
1838 : : "procedure", gfc_code2string (procedures, t), where,
1839 : 167 : gfc_code2string (procedures, attr->proc));
1840 : :
1841 : 167 : return false;
1842 : : }
1843 : :
1844 : 1231439 : attr->proc = t;
1845 : :
1846 : : /* Statement functions are always scalar and functions. */
1847 : 1231439 : if (t == PROC_ST_FUNCTION
1848 : 1231439 : && ((!attr->function && !gfc_add_function (attr, name, where))
1849 : 349328 : || attr->dimension))
1850 : 66 : return false;
1851 : :
1852 : 1231373 : return gfc_check_conflict (attr, name, where);
1853 : : }
1854 : :
1855 : :
1856 : : bool
1857 : 48848 : gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1858 : : {
1859 : :
1860 : 48848 : if (check_used (attr, NULL, where))
1861 : : return false;
1862 : :
1863 : 48848 : if (attr->intent == INTENT_UNKNOWN)
1864 : : {
1865 : 48848 : attr->intent = intent;
1866 : 48848 : return gfc_check_conflict (attr, NULL, where);
1867 : : }
1868 : :
1869 : 0 : if (where == NULL)
1870 : 0 : where = &gfc_current_locus;
1871 : :
1872 : 0 : gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1873 : 0 : gfc_intent_string (attr->intent),
1874 : : gfc_intent_string (intent), where);
1875 : :
1876 : 0 : return false;
1877 : : }
1878 : :
1879 : :
1880 : : /* No checks for use-association in public and private statements. */
1881 : :
1882 : : bool
1883 : 5013 : gfc_add_access (symbol_attribute *attr, gfc_access access,
1884 : : const char *name, locus *where)
1885 : : {
1886 : :
1887 : 5013 : if (attr->access == ACCESS_UNKNOWN
1888 : 5 : || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1889 : : {
1890 : 5009 : attr->access = access;
1891 : 5009 : return gfc_check_conflict (attr, name, where);
1892 : : }
1893 : :
1894 : 4 : if (where == NULL)
1895 : 3 : where = &gfc_current_locus;
1896 : 4 : gfc_error ("ACCESS specification at %L was already specified", where);
1897 : :
1898 : 4 : return false;
1899 : : }
1900 : :
1901 : :
1902 : : /* Set the is_bind_c field for the given symbol_attribute. */
1903 : :
1904 : : bool
1905 : 5590 : gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1906 : : int is_proc_lang_bind_spec)
1907 : : {
1908 : :
1909 : 5590 : if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1910 : 5 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
1911 : : "variables or common blocks", where);
1912 : 5585 : else if (attr->is_bind_c)
1913 : 1 : gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1914 : : else
1915 : 5584 : attr->is_bind_c = 1;
1916 : :
1917 : 5590 : if (where == NULL)
1918 : 52 : where = &gfc_current_locus;
1919 : :
1920 : 5590 : if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where))
1921 : : return false;
1922 : :
1923 : 5590 : return gfc_check_conflict (attr, name, where);
1924 : : }
1925 : :
1926 : :
1927 : : /* Set the extension field for the given symbol_attribute. */
1928 : :
1929 : : bool
1930 : 1270 : gfc_add_extension (symbol_attribute *attr, locus *where)
1931 : : {
1932 : 1270 : if (where == NULL)
1933 : 0 : where = &gfc_current_locus;
1934 : :
1935 : 1270 : if (attr->extension)
1936 : 0 : gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1937 : : else
1938 : 1270 : attr->extension = 1;
1939 : :
1940 : 1270 : if (!gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where))
1941 : : return false;
1942 : :
1943 : : return true;
1944 : : }
1945 : :
1946 : :
1947 : : bool
1948 : 121050 : gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1949 : : gfc_formal_arglist * formal, locus *where)
1950 : : {
1951 : 121050 : if (check_used (&sym->attr, sym->name, where))
1952 : : return false;
1953 : :
1954 : : /* Skip the following checks in the case of a module_procedures in a
1955 : : submodule since they will manifestly fail. */
1956 : 121050 : if (sym->attr.module_procedure == 1
1957 : 1070 : && source == IFSRC_DECL)
1958 : 709 : goto finish;
1959 : :
1960 : 120341 : if (where == NULL)
1961 : 120341 : where = &gfc_current_locus;
1962 : :
1963 : 120341 : if (sym->attr.if_source != IFSRC_UNKNOWN
1964 : 120341 : && sym->attr.if_source != IFSRC_DECL)
1965 : : {
1966 : 1 : gfc_error ("Symbol %qs at %L already has an explicit interface",
1967 : : sym->name, where);
1968 : 1 : return false;
1969 : : }
1970 : :
1971 : 120340 : if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1972 : : {
1973 : 2 : gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
1974 : : "body", sym->name, where);
1975 : 2 : return false;
1976 : : }
1977 : :
1978 : 120338 : finish:
1979 : 121047 : sym->formal = formal;
1980 : 121047 : sym->attr.if_source = source;
1981 : :
1982 : 121047 : return true;
1983 : : }
1984 : :
1985 : :
1986 : : /* Add a type to a symbol. */
1987 : :
1988 : : bool
1989 : 231550 : gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1990 : : {
1991 : 231550 : sym_flavor flavor;
1992 : 231550 : bt type;
1993 : :
1994 : 231550 : if (where == NULL)
1995 : 4856 : where = &gfc_current_locus;
1996 : :
1997 : 231550 : if (sym->result)
1998 : 7464 : type = sym->result->ts.type;
1999 : : else
2000 : 224086 : type = sym->ts.type;
2001 : :
2002 : 231550 : if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
2003 : 3600 : type = sym->ns->proc_name->ts.type;
2004 : :
2005 : 231550 : if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type)
2006 : 77 : && !(gfc_state_stack->previous && gfc_state_stack->previous->previous
2007 : 59 : && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
2008 : 44 : && !sym->attr.module_procedure)
2009 : : {
2010 : 26 : if (sym->attr.use_assoc)
2011 : 2 : gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
2012 : : "use-associated at %L", sym->name, where, sym->module,
2013 : : &sym->declared_at);
2014 : 24 : else if (sym->attr.function && sym->attr.result)
2015 : 1 : gfc_error ("Symbol %qs at %L already has basic type of %s",
2016 : 1 : sym->ns->proc_name->name, where, gfc_basic_typename (type));
2017 : : else
2018 : 23 : gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name,
2019 : : where, gfc_basic_typename (type));
2020 : 26 : return false;
2021 : : }
2022 : :
2023 : 231524 : if (sym->attr.procedure && sym->ts.interface)
2024 : : {
2025 : 1 : gfc_error ("Procedure %qs at %L may not have basic type of %s",
2026 : : sym->name, where, gfc_basic_typename (ts->type));
2027 : 1 : return false;
2028 : : }
2029 : :
2030 : 231523 : flavor = sym->attr.flavor;
2031 : :
2032 : 231523 : if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
2033 : 231523 : || flavor == FL_LABEL
2034 : 231521 : || (flavor == FL_PROCEDURE && sym->attr.subroutine)
2035 : 231519 : || flavor == FL_DERIVED || flavor == FL_NAMELIST)
2036 : : {
2037 : 4 : gfc_error ("Symbol %qs at %L cannot have a type",
2038 : 4 : sym->ns->proc_name ? sym->ns->proc_name->name : sym->name,
2039 : : where);
2040 : 4 : return false;
2041 : : }
2042 : :
2043 : 231519 : sym->ts = *ts;
2044 : 231519 : return true;
2045 : : }
2046 : :
2047 : :
2048 : : /* Clears all attributes. */
2049 : :
2050 : : void
2051 : 6158092 : gfc_clear_attr (symbol_attribute *attr)
2052 : : {
2053 : 6158092 : memset (attr, 0, sizeof (symbol_attribute));
2054 : 6158092 : }
2055 : :
2056 : :
2057 : : /* Check for missing attributes in the new symbol. Currently does
2058 : : nothing, but it's not clear that it is unnecessary yet. */
2059 : :
2060 : : bool
2061 : 330830 : gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
2062 : : locus *where ATTRIBUTE_UNUSED)
2063 : : {
2064 : :
2065 : 330830 : return true;
2066 : : }
2067 : :
2068 : :
2069 : : /* Copy an attribute to a symbol attribute, bit by bit. Some
2070 : : attributes have a lot of side-effects but cannot be present given
2071 : : where we are called from, so we ignore some bits. */
2072 : :
2073 : : bool
2074 : 230675 : gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
2075 : : {
2076 : 230675 : int is_proc_lang_bind_spec;
2077 : :
2078 : : /* In line with the other attributes, we only add bits but do not remove
2079 : : them; cf. also PR 41034. */
2080 : 230675 : dest->ext_attr |= src->ext_attr;
2081 : :
2082 : 230675 : if (src->allocatable && !gfc_add_allocatable (dest, where))
2083 : 3 : goto fail;
2084 : :
2085 : 230672 : if (src->automatic && !gfc_add_automatic (dest, NULL, where))
2086 : 2 : goto fail;
2087 : 230670 : if (src->dimension && !gfc_add_dimension (dest, NULL, where))
2088 : 0 : goto fail;
2089 : 230670 : if (src->codimension && !gfc_add_codimension (dest, NULL, where))
2090 : 0 : goto fail;
2091 : 230670 : if (src->contiguous && !gfc_add_contiguous (dest, NULL, where))
2092 : 2 : goto fail;
2093 : 230668 : if (src->optional && !gfc_add_optional (dest, where))
2094 : 1 : goto fail;
2095 : 230667 : if (src->pointer && !gfc_add_pointer (dest, where))
2096 : 8 : goto fail;
2097 : 230659 : if (src->is_protected && !gfc_add_protected (dest, NULL, where))
2098 : 0 : goto fail;
2099 : 230659 : if (src->save && !gfc_add_save (dest, src->save, NULL, where))
2100 : 3 : goto fail;
2101 : 230656 : if (src->value && !gfc_add_value (dest, NULL, where))
2102 : 2 : goto fail;
2103 : 230654 : if (src->volatile_ && !gfc_add_volatile (dest, NULL, where))
2104 : 0 : goto fail;
2105 : 230654 : if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where))
2106 : 0 : goto fail;
2107 : 230654 : if (src->threadprivate
2108 : 230654 : && !gfc_add_threadprivate (dest, NULL, where))
2109 : 0 : goto fail;
2110 : 230654 : if (src->omp_declare_target
2111 : 230654 : && !gfc_add_omp_declare_target (dest, NULL, where))
2112 : 0 : goto fail;
2113 : 230654 : if (src->omp_declare_target_link
2114 : 230654 : && !gfc_add_omp_declare_target_link (dest, NULL, where))
2115 : 0 : goto fail;
2116 : 230654 : if (src->oacc_declare_create
2117 : 230654 : && !gfc_add_oacc_declare_create (dest, NULL, where))
2118 : 0 : goto fail;
2119 : 230654 : if (src->oacc_declare_copyin
2120 : 230654 : && !gfc_add_oacc_declare_copyin (dest, NULL, where))
2121 : 0 : goto fail;
2122 : 230654 : if (src->oacc_declare_deviceptr
2123 : 230654 : && !gfc_add_oacc_declare_deviceptr (dest, NULL, where))
2124 : 0 : goto fail;
2125 : 230654 : if (src->oacc_declare_device_resident
2126 : 230654 : && !gfc_add_oacc_declare_device_resident (dest, NULL, where))
2127 : 0 : goto fail;
2128 : 230654 : if (src->target && !gfc_add_target (dest, where))
2129 : 2 : goto fail;
2130 : 230652 : if (src->dummy && !gfc_add_dummy (dest, NULL, where))
2131 : 0 : goto fail;
2132 : 230652 : if (src->result && !gfc_add_result (dest, NULL, where))
2133 : 0 : goto fail;
2134 : 230652 : if (src->entry)
2135 : 0 : dest->entry = 1;
2136 : :
2137 : 230652 : if (src->in_namelist && !gfc_add_in_namelist (dest, NULL, where))
2138 : 0 : goto fail;
2139 : :
2140 : 230652 : if (src->in_common && !gfc_add_in_common (dest, NULL, where))
2141 : 0 : goto fail;
2142 : :
2143 : 230652 : if (src->generic && !gfc_add_generic (dest, NULL, where))
2144 : 0 : goto fail;
2145 : 230652 : if (src->function && !gfc_add_function (dest, NULL, where))
2146 : 0 : goto fail;
2147 : 230652 : if (src->subroutine && !gfc_add_subroutine (dest, NULL, where))
2148 : 0 : goto fail;
2149 : :
2150 : 230652 : if (src->sequence && !gfc_add_sequence (dest, NULL, where))
2151 : 0 : goto fail;
2152 : 230652 : if (src->elemental && !gfc_add_elemental (dest, where))
2153 : 0 : goto fail;
2154 : 230652 : if (src->pure && !gfc_add_pure (dest, where))
2155 : 0 : goto fail;
2156 : 230652 : if (src->recursive && !gfc_add_recursive (dest, where))
2157 : 0 : goto fail;
2158 : :
2159 : 230652 : if (src->flavor != FL_UNKNOWN
2160 : 230652 : && !gfc_add_flavor (dest, src->flavor, NULL, where))
2161 : 340 : goto fail;
2162 : :
2163 : 230312 : if (src->intent != INTENT_UNKNOWN
2164 : 230312 : && !gfc_add_intent (dest, src->intent, where))
2165 : 0 : goto fail;
2166 : :
2167 : 230312 : if (src->access != ACCESS_UNKNOWN
2168 : 230312 : && !gfc_add_access (dest, src->access, NULL, where))
2169 : 1 : goto fail;
2170 : :
2171 : 230311 : if (!gfc_missing_attr (dest, where))
2172 : 0 : goto fail;
2173 : :
2174 : 230311 : if (src->cray_pointer && !gfc_add_cray_pointer (dest, where))
2175 : 0 : goto fail;
2176 : 230311 : if (src->cray_pointee && !gfc_add_cray_pointee (dest, where))
2177 : 0 : goto fail;
2178 : :
2179 : 230311 : is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
2180 : 230311 : if (src->is_bind_c
2181 : 230311 : && !gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec))
2182 : : return false;
2183 : :
2184 : 230310 : if (src->is_c_interop)
2185 : 0 : dest->is_c_interop = 1;
2186 : 230310 : if (src->is_iso_c)
2187 : 0 : dest->is_iso_c = 1;
2188 : :
2189 : 230310 : if (src->external && !gfc_add_external (dest, where))
2190 : 5 : goto fail;
2191 : 230305 : if (src->intrinsic && !gfc_add_intrinsic (dest, where))
2192 : 4 : goto fail;
2193 : 230301 : if (src->proc_pointer)
2194 : 384 : dest->proc_pointer = 1;
2195 : :
2196 : : return true;
2197 : :
2198 : : fail:
2199 : : return false;
2200 : : }
2201 : :
2202 : :
2203 : : /* A function to generate a dummy argument symbol using that from the
2204 : : interface declaration. Can be used for the result symbol as well if
2205 : : the flag is set. */
2206 : :
2207 : : int
2208 : 224 : gfc_copy_dummy_sym (gfc_symbol **dsym, gfc_symbol *sym, int result)
2209 : : {
2210 : 224 : int rc;
2211 : :
2212 : 224 : rc = gfc_get_symbol (sym->name, NULL, dsym);
2213 : 224 : if (rc)
2214 : : return rc;
2215 : :
2216 : 224 : if (!gfc_add_type (*dsym, &(sym->ts), &gfc_current_locus))
2217 : : return 1;
2218 : :
2219 : 224 : if (!gfc_copy_attr (&(*dsym)->attr, &(sym->attr),
2220 : : &gfc_current_locus))
2221 : : return 1;
2222 : :
2223 : 224 : if ((*dsym)->attr.dimension)
2224 : 54 : (*dsym)->as = gfc_copy_array_spec (sym->as);
2225 : :
2226 : 224 : (*dsym)->attr.class_ok = sym->attr.class_ok;
2227 : :
2228 : 224 : if ((*dsym) != NULL && !result
2229 : 209 : && (!gfc_add_dummy(&(*dsym)->attr, (*dsym)->name, NULL)
2230 : 209 : || !gfc_missing_attr (&(*dsym)->attr, NULL)))
2231 : 0 : return 1;
2232 : 224 : else if ((*dsym) != NULL && result
2233 : 239 : && (!gfc_add_result(&(*dsym)->attr, (*dsym)->name, NULL)
2234 : 15 : || !gfc_missing_attr (&(*dsym)->attr, NULL)))
2235 : 0 : return 1;
2236 : :
2237 : : return 0;
2238 : : }
2239 : :
2240 : :
2241 : : /************** Component name management ************/
2242 : :
2243 : : /* Component names of a derived type form their own little namespaces
2244 : : that are separate from all other spaces. The space is composed of
2245 : : a singly linked list of gfc_component structures whose head is
2246 : : located in the parent symbol. */
2247 : :
2248 : :
2249 : : /* Add a component name to a symbol. The call fails if the name is
2250 : : already present. On success, the component pointer is modified to
2251 : : point to the additional component structure. */
2252 : :
2253 : : bool
2254 : 107697 : gfc_add_component (gfc_symbol *sym, const char *name,
2255 : : gfc_component **component)
2256 : : {
2257 : 107697 : gfc_component *p, *tail;
2258 : :
2259 : : /* Check for existing components with the same name, but not for union
2260 : : components or containers. Unions and maps are anonymous so they have
2261 : : unique internal names which will never conflict.
2262 : : Don't use gfc_find_component here because it calls gfc_use_derived,
2263 : : but the derived type may not be fully defined yet. */
2264 : 107697 : tail = NULL;
2265 : :
2266 : 350539 : for (p = sym->components; p; p = p->next)
2267 : : {
2268 : 242846 : if (strcmp (p->name, name) == 0)
2269 : : {
2270 : 4 : gfc_error ("Component %qs at %C already declared at %L",
2271 : : name, &p->loc);
2272 : 4 : return false;
2273 : : }
2274 : :
2275 : 242842 : tail = p;
2276 : : }
2277 : :
2278 : 107693 : if (sym->attr.extension
2279 : 107693 : && gfc_find_component (sym->components->ts.u.derived,
2280 : : name, true, true, NULL))
2281 : : {
2282 : 2 : gfc_error ("Component %qs at %C already in the parent type "
2283 : 2 : "at %L", name, &sym->components->ts.u.derived->declared_at);
2284 : 2 : return false;
2285 : : }
2286 : :
2287 : : /* Allocate a new component. */
2288 : 107691 : p = gfc_get_component ();
2289 : :
2290 : 107691 : if (tail == NULL)
2291 : 33683 : sym->components = p;
2292 : : else
2293 : 74008 : tail->next = p;
2294 : :
2295 : 107691 : p->name = gfc_get_string ("%s", name);
2296 : 107691 : p->loc = gfc_current_locus;
2297 : 107691 : p->ts.type = BT_UNKNOWN;
2298 : :
2299 : 107691 : *component = p;
2300 : 107691 : return true;
2301 : : }
2302 : :
2303 : :
2304 : : /* Recursive function to switch derived types of all symbol in a
2305 : : namespace. */
2306 : :
2307 : : static void
2308 : 0 : switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
2309 : : {
2310 : 0 : gfc_symbol *sym;
2311 : :
2312 : 0 : if (st == NULL)
2313 : 0 : return;
2314 : :
2315 : 0 : sym = st->n.sym;
2316 : 0 : if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
2317 : 0 : sym->ts.u.derived = to;
2318 : :
2319 : 0 : switch_types (st->left, from, to);
2320 : 0 : switch_types (st->right, from, to);
2321 : : }
2322 : :
2323 : :
2324 : : /* This subroutine is called when a derived type is used in order to
2325 : : make the final determination about which version to use. The
2326 : : standard requires that a type be defined before it is 'used', but
2327 : : such types can appear in IMPLICIT statements before the actual
2328 : : definition. 'Using' in this context means declaring a variable to
2329 : : be that type or using the type constructor.
2330 : :
2331 : : If a type is used and the components haven't been defined, then we
2332 : : have to have a derived type in a parent unit. We find the node in
2333 : : the other namespace and point the symtree node in this namespace to
2334 : : that node. Further reference to this name point to the correct
2335 : : node. If we can't find the node in a parent namespace, then we have
2336 : : an error.
2337 : :
2338 : : This subroutine takes a pointer to a symbol node and returns a
2339 : : pointer to the translated node or NULL for an error. Usually there
2340 : : is no translation and we return the node we were passed. */
2341 : :
2342 : : gfc_symbol *
2343 : 293477 : gfc_use_derived (gfc_symbol *sym)
2344 : : {
2345 : 293477 : gfc_symbol *s;
2346 : 293477 : gfc_typespec *t;
2347 : 293477 : gfc_symtree *st;
2348 : 293477 : int i;
2349 : :
2350 : 293477 : if (!sym)
2351 : : return NULL;
2352 : :
2353 : 293473 : if (sym->attr.unlimited_polymorphic)
2354 : : return sym;
2355 : :
2356 : 292214 : if (sym->attr.generic)
2357 : 0 : sym = gfc_find_dt_in_generic (sym);
2358 : :
2359 : 292214 : if (sym->components != NULL || sym->attr.zero_comp)
2360 : : return sym; /* Already defined. */
2361 : :
2362 : 18 : if (sym->ns->parent == NULL)
2363 : 9 : goto bad;
2364 : :
2365 : 9 : if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
2366 : : {
2367 : 0 : gfc_error ("Symbol %qs at %C is ambiguous", sym->name);
2368 : 0 : return NULL;
2369 : : }
2370 : :
2371 : 9 : if (s == NULL || !gfc_fl_struct (s->attr.flavor))
2372 : 9 : goto bad;
2373 : :
2374 : : /* Get rid of symbol sym, translating all references to s. */
2375 : 0 : for (i = 0; i < GFC_LETTERS; i++)
2376 : : {
2377 : 0 : t = &sym->ns->default_type[i];
2378 : 0 : if (t->u.derived == sym)
2379 : 0 : t->u.derived = s;
2380 : : }
2381 : :
2382 : 0 : st = gfc_find_symtree (sym->ns->sym_root, sym->name);
2383 : 0 : st->n.sym = s;
2384 : :
2385 : 0 : s->refs++;
2386 : :
2387 : : /* Unlink from list of modified symbols. */
2388 : 0 : gfc_commit_symbol (sym);
2389 : :
2390 : 0 : switch_types (sym->ns->sym_root, sym, s);
2391 : :
2392 : : /* TODO: Also have to replace sym -> s in other lists like
2393 : : namelists, common lists and interface lists. */
2394 : 0 : gfc_free_symbol (sym);
2395 : :
2396 : 0 : return s;
2397 : :
2398 : 18 : bad:
2399 : 18 : gfc_error ("Derived type %qs at %C is being used before it is defined",
2400 : : sym->name);
2401 : 18 : return NULL;
2402 : : }
2403 : :
2404 : :
2405 : : /* Find the component with the given name in the union type symbol.
2406 : : If ref is not NULL it will be set to the chain of components through which
2407 : : the component can actually be accessed. This is necessary for unions because
2408 : : intermediate structures may be maps, nested structures, or other unions,
2409 : : all of which may (or must) be 'anonymous' to user code. */
2410 : :
2411 : : static gfc_component *
2412 : 2192 : find_union_component (gfc_symbol *un, const char *name,
2413 : : bool noaccess, gfc_ref **ref)
2414 : : {
2415 : 2192 : gfc_component *m, *check;
2416 : 2192 : gfc_ref *sref, *tmp;
2417 : :
2418 : 3983 : for (m = un->components; m; m = m->next)
2419 : : {
2420 : 3483 : check = gfc_find_component (m->ts.u.derived, name, noaccess, true, &tmp);
2421 : 3483 : if (check == NULL)
2422 : 1791 : continue;
2423 : :
2424 : : /* Found component somewhere in m; chain the refs together. */
2425 : 1692 : if (ref)
2426 : : {
2427 : : /* Map ref. */
2428 : 1692 : sref = gfc_get_ref ();
2429 : 1692 : sref->type = REF_COMPONENT;
2430 : 1692 : sref->u.c.component = m;
2431 : 1692 : sref->u.c.sym = m->ts.u.derived;
2432 : 1692 : sref->next = tmp;
2433 : :
2434 : 1692 : *ref = sref;
2435 : : }
2436 : : /* Other checks (such as access) were done in the recursive calls. */
2437 : : return check;
2438 : : }
2439 : : return NULL;
2440 : : }
2441 : :
2442 : :
2443 : : /* Recursively append candidate COMPONENT structures to CANDIDATES. Store
2444 : : the number of total candidates in CANDIDATES_LEN. */
2445 : :
2446 : : static void
2447 : 34 : lookup_component_fuzzy_find_candidates (gfc_component *component,
2448 : : char **&candidates,
2449 : : size_t &candidates_len)
2450 : : {
2451 : 81 : for (gfc_component *p = component; p; p = p->next)
2452 : 47 : vec_push (candidates, candidates_len, p->name);
2453 : 34 : }
2454 : :
2455 : :
2456 : : /* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
2457 : :
2458 : : static const char*
2459 : 34 : lookup_component_fuzzy (const char *member, gfc_component *component)
2460 : : {
2461 : 34 : char **candidates = NULL;
2462 : 34 : size_t candidates_len = 0;
2463 : 34 : lookup_component_fuzzy_find_candidates (component, candidates,
2464 : : candidates_len);
2465 : 34 : return gfc_closest_fuzzy_match (member, candidates);
2466 : : }
2467 : :
2468 : :
2469 : : /* Given a derived type node and a component name, try to locate the
2470 : : component structure. Returns the NULL pointer if the component is
2471 : : not found or the components are private. If noaccess is set, no access
2472 : : checks are done. If silent is set, an error will not be generated if
2473 : : the component cannot be found or accessed.
2474 : :
2475 : : If ref is not NULL, *ref is set to represent the chain of components
2476 : : required to get to the ultimate component.
2477 : :
2478 : : If the component is simply a direct subcomponent, or is inherited from a
2479 : : parent derived type in the given derived type, this is a single ref with its
2480 : : component set to the returned component.
2481 : :
2482 : : Otherwise, *ref is constructed as a chain of subcomponents. This occurs
2483 : : when the component is found through an implicit chain of nested union and
2484 : : map components. Unions and maps are "anonymous" substructures in FORTRAN
2485 : : which cannot be explicitly referenced, but the reference chain must be
2486 : : considered as in C for backend translation to correctly compute layouts.
2487 : : (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */
2488 : :
2489 : : gfc_component *
2490 : 273883 : gfc_find_component (gfc_symbol *sym, const char *name,
2491 : : bool noaccess, bool silent, gfc_ref **ref)
2492 : : {
2493 : 273883 : gfc_component *p, *check;
2494 : 273883 : gfc_ref *sref = NULL, *tmp = NULL;
2495 : :
2496 : 273883 : if (name == NULL || sym == NULL)
2497 : : return NULL;
2498 : :
2499 : 268882 : if (sym->attr.flavor == FL_DERIVED)
2500 : 260119 : sym = gfc_use_derived (sym);
2501 : : else
2502 : 8763 : gcc_assert (gfc_fl_struct (sym->attr.flavor));
2503 : :
2504 : 260119 : if (sym == NULL)
2505 : : return NULL;
2506 : :
2507 : : /* Handle UNIONs specially - mutually recursive with gfc_find_component. */
2508 : 268880 : if (sym->attr.flavor == FL_UNION)
2509 : 500 : return find_union_component (sym, name, noaccess, ref);
2510 : :
2511 : 268380 : if (ref) *ref = NULL;
2512 : 590154 : for (p = sym->components; p; p = p->next)
2513 : : {
2514 : : /* Nest search into union's maps. */
2515 : 560522 : if (p->ts.type == BT_UNION)
2516 : : {
2517 : 1692 : check = find_union_component (p->ts.u.derived, name, noaccess, &tmp);
2518 : 1692 : if (check != NULL)
2519 : : {
2520 : : /* Union ref. */
2521 : 1692 : if (ref)
2522 : : {
2523 : 1252 : sref = gfc_get_ref ();
2524 : 1252 : sref->type = REF_COMPONENT;
2525 : 1252 : sref->u.c.component = p;
2526 : 1252 : sref->u.c.sym = p->ts.u.derived;
2527 : 1252 : sref->next = tmp;
2528 : 1252 : *ref = sref;
2529 : : }
2530 : 1692 : return check;
2531 : : }
2532 : : }
2533 : 558830 : else if (strcmp (p->name, name) == 0)
2534 : : break;
2535 : :
2536 : 321774 : continue;
2537 : : }
2538 : :
2539 : 266688 : if (p && sym->attr.use_assoc && !noaccess)
2540 : : {
2541 : 40138 : bool is_parent_comp = sym->attr.extension && (p == sym->components);
2542 : 40138 : if (p->attr.access == ACCESS_PRIVATE ||
2543 : : (p->attr.access != ACCESS_PUBLIC
2544 : 39549 : && sym->component_access == ACCESS_PRIVATE
2545 : 8 : && !is_parent_comp))
2546 : : {
2547 : 14 : if (!silent)
2548 : 14 : gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
2549 : : name, sym->name);
2550 : 14 : return NULL;
2551 : : }
2552 : : }
2553 : :
2554 : : if (p == NULL
2555 : 29632 : && sym->attr.extension
2556 : 20369 : && sym->components->ts.type == BT_DERIVED)
2557 : : {
2558 : 20369 : p = gfc_find_component (sym->components->ts.u.derived, name,
2559 : : noaccess, silent, ref);
2560 : : /* Do not overwrite the error. */
2561 : 20369 : if (p == NULL)
2562 : : return p;
2563 : : }
2564 : :
2565 : 266342 : if (p == NULL && !silent)
2566 : : {
2567 : 34 : const char *guessed = lookup_component_fuzzy (name, sym->components);
2568 : 34 : if (guessed)
2569 : 10 : gfc_error ("%qs at %C is not a member of the %qs structure"
2570 : : "; did you mean %qs?",
2571 : : name, sym->name, guessed);
2572 : : else
2573 : 24 : gfc_error ("%qs at %C is not a member of the %qs structure",
2574 : : name, sym->name);
2575 : : }
2576 : :
2577 : : /* Component was found; build the ultimate component reference. */
2578 : 266342 : if (p != NULL && ref)
2579 : : {
2580 : 212457 : tmp = gfc_get_ref ();
2581 : 212457 : tmp->type = REF_COMPONENT;
2582 : 212457 : tmp->u.c.component = p;
2583 : 212457 : tmp->u.c.sym = sym;
2584 : : /* Link the final component ref to the end of the chain of subrefs. */
2585 : 212457 : if (sref)
2586 : : {
2587 : : *ref = sref;
2588 : : for (; sref->next; sref = sref->next)
2589 : : ;
2590 : : sref->next = tmp;
2591 : : }
2592 : : else
2593 : 212457 : *ref = tmp;
2594 : : }
2595 : :
2596 : : return p;
2597 : 321774 : }
2598 : :
2599 : :
2600 : : /* Given a symbol, free all of the component structures and everything
2601 : : they point to. */
2602 : :
2603 : : static void
2604 : 4898172 : free_components (gfc_component *p)
2605 : : {
2606 : 4898172 : gfc_component *q;
2607 : :
2608 : 5110555 : for (; p; p = q)
2609 : : {
2610 : 212383 : q = p->next;
2611 : :
2612 : 212383 : gfc_free_array_spec (p->as);
2613 : 212383 : gfc_free_expr (p->initializer);
2614 : 212383 : if (p->kind_expr)
2615 : 110 : gfc_free_expr (p->kind_expr);
2616 : 212383 : if (p->param_list)
2617 : 81 : gfc_free_actual_arglist (p->param_list);
2618 : 212383 : free (p->tb);
2619 : 212383 : p->tb = NULL;
2620 : 212383 : free (p);
2621 : : }
2622 : 4898172 : }
2623 : :
2624 : :
2625 : : /******************** Statement label management ********************/
2626 : :
2627 : : /* Comparison function for statement labels, used for managing the
2628 : : binary tree. */
2629 : :
2630 : : static int
2631 : 7608 : compare_st_labels (void *a1, void *b1)
2632 : : {
2633 : 7608 : int a = ((gfc_st_label *) a1)->value;
2634 : 7608 : int b = ((gfc_st_label *) b1)->value;
2635 : :
2636 : 7608 : return (b - a);
2637 : : }
2638 : :
2639 : :
2640 : : /* Free a single gfc_st_label structure, making sure the tree is not
2641 : : messed up. This function is called only when some parse error
2642 : : occurs. */
2643 : :
2644 : : void
2645 : 3 : gfc_free_st_label (gfc_st_label *label)
2646 : : {
2647 : :
2648 : 3 : if (label == NULL)
2649 : : return;
2650 : :
2651 : 3 : gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels);
2652 : :
2653 : 3 : if (label->format != NULL)
2654 : 0 : gfc_free_expr (label->format);
2655 : :
2656 : 3 : free (label);
2657 : : }
2658 : :
2659 : :
2660 : : /* Free a whole tree of gfc_st_label structures. */
2661 : :
2662 : : static void
2663 : 423580 : free_st_labels (gfc_st_label *label)
2664 : : {
2665 : :
2666 : 423580 : if (label == NULL)
2667 : : return;
2668 : :
2669 : 4632 : free_st_labels (label->left);
2670 : 4632 : free_st_labels (label->right);
2671 : :
2672 : 4632 : if (label->format != NULL)
2673 : 987 : gfc_free_expr (label->format);
2674 : 4632 : free (label);
2675 : : }
2676 : :
2677 : :
2678 : : /* Given a label number, search for and return a pointer to the label
2679 : : structure, creating it if it does not exist. */
2680 : :
2681 : : gfc_st_label *
2682 : 13453 : gfc_get_st_label (int labelno)
2683 : : {
2684 : 13453 : gfc_st_label *lp;
2685 : 13453 : gfc_namespace *ns;
2686 : :
2687 : 13453 : if (gfc_current_state () == COMP_DERIVED)
2688 : 3 : ns = gfc_current_block ()->f2k_derived;
2689 : : else
2690 : : {
2691 : : /* Find the namespace of the scoping unit:
2692 : : If we're in a BLOCK construct, jump to the parent namespace. */
2693 : 13450 : ns = gfc_current_ns;
2694 : 13460 : while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2695 : 10 : ns = ns->parent;
2696 : : }
2697 : :
2698 : : /* First see if the label is already in this namespace. */
2699 : 13453 : lp = ns->st_labels;
2700 : 31195 : while (lp)
2701 : : {
2702 : 26559 : if (lp->value == labelno)
2703 : 8817 : return lp;
2704 : :
2705 : 17742 : if (lp->value < labelno)
2706 : 13132 : lp = lp->left;
2707 : : else
2708 : 4610 : lp = lp->right;
2709 : : }
2710 : :
2711 : 4636 : lp = XCNEW (gfc_st_label);
2712 : :
2713 : 4636 : lp->value = labelno;
2714 : 4636 : lp->defined = ST_LABEL_UNKNOWN;
2715 : 4636 : lp->referenced = ST_LABEL_UNKNOWN;
2716 : 4636 : lp->ns = ns;
2717 : :
2718 : 4636 : gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2719 : :
2720 : 4636 : return lp;
2721 : : }
2722 : :
2723 : :
2724 : : /* Called when a statement with a statement label is about to be
2725 : : accepted. We add the label to the list of the current namespace,
2726 : : making sure it hasn't been defined previously and referenced
2727 : : correctly. */
2728 : :
2729 : : void
2730 : 4605 : gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2731 : : {
2732 : 4605 : int labelno;
2733 : :
2734 : 4605 : labelno = lp->value;
2735 : :
2736 : 4605 : if (lp->defined != ST_LABEL_UNKNOWN)
2737 : 2 : gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2738 : : &lp->where, label_locus);
2739 : : else
2740 : : {
2741 : 4603 : lp->where = *label_locus;
2742 : :
2743 : 4603 : switch (type)
2744 : : {
2745 : 987 : case ST_LABEL_FORMAT:
2746 : 987 : if (lp->referenced == ST_LABEL_TARGET
2747 : 987 : || lp->referenced == ST_LABEL_DO_TARGET)
2748 : 0 : gfc_error ("Label %d at %C already referenced as branch target",
2749 : : labelno);
2750 : : else
2751 : 987 : lp->defined = ST_LABEL_FORMAT;
2752 : :
2753 : : break;
2754 : :
2755 : 3609 : case ST_LABEL_TARGET:
2756 : 3609 : case ST_LABEL_DO_TARGET:
2757 : 3609 : if (lp->referenced == ST_LABEL_FORMAT)
2758 : 0 : gfc_error ("Label %d at %C already referenced as a format label",
2759 : : labelno);
2760 : : else
2761 : 3609 : lp->defined = type;
2762 : :
2763 : 1694 : if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
2764 : 3740 : && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
2765 : : "DO termination statement which is not END DO"
2766 : : " or CONTINUE with label %d at %C", labelno))
2767 : : return;
2768 : : break;
2769 : :
2770 : 7 : default:
2771 : 7 : lp->defined = ST_LABEL_BAD_TARGET;
2772 : 7 : lp->referenced = ST_LABEL_BAD_TARGET;
2773 : : }
2774 : : }
2775 : : }
2776 : :
2777 : :
2778 : : /* Reference a label. Given a label and its type, see if that
2779 : : reference is consistent with what is known about that label,
2780 : : updating the unknown state. Returns false if something goes
2781 : : wrong. */
2782 : :
2783 : : bool
2784 : 17351 : gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2785 : : {
2786 : 17351 : gfc_sl_type label_type;
2787 : 17351 : int labelno;
2788 : 17351 : bool rc;
2789 : :
2790 : 17351 : if (lp == NULL)
2791 : : return true;
2792 : :
2793 : 7613 : labelno = lp->value;
2794 : :
2795 : 7613 : if (lp->defined != ST_LABEL_UNKNOWN)
2796 : : label_type = lp->defined;
2797 : : else
2798 : : {
2799 : 5976 : label_type = lp->referenced;
2800 : 5976 : lp->where = gfc_current_locus;
2801 : : }
2802 : :
2803 : 7613 : if (label_type == ST_LABEL_FORMAT
2804 : 1182 : && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
2805 : : {
2806 : 0 : gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2807 : 0 : rc = false;
2808 : 0 : goto done;
2809 : : }
2810 : :
2811 : 7613 : if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
2812 : 7613 : || label_type == ST_LABEL_BAD_TARGET)
2813 : 2422 : && type == ST_LABEL_FORMAT)
2814 : : {
2815 : 0 : gfc_error ("Label %d at %C previously used as branch target", labelno);
2816 : 0 : rc = false;
2817 : 0 : goto done;
2818 : : }
2819 : :
2820 : 620 : if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
2821 : 8154 : && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
2822 : : "Shared DO termination label %d at %C", labelno))
2823 : : return false;
2824 : :
2825 : 7613 : if (type == ST_LABEL_DO_TARGET
2826 : 7613 : && !gfc_notify_std (GFC_STD_F2018_OBS, "Labeled DO statement "
2827 : : "at %L", &gfc_current_locus))
2828 : : return false;
2829 : :
2830 : 7613 : if (lp->referenced != ST_LABEL_DO_TARGET)
2831 : 6993 : lp->referenced = type;
2832 : : rc = true;
2833 : :
2834 : : done:
2835 : : return rc;
2836 : : }
2837 : :
2838 : :
2839 : : /************** Symbol table management subroutines ****************/
2840 : :
2841 : : /* Basic details: Fortran 95 requires a potentially unlimited number
2842 : : of distinct namespaces when compiling a program unit. This case
2843 : : occurs during a compilation of internal subprograms because all of
2844 : : the internal subprograms must be read before we can start
2845 : : generating code for the host.
2846 : :
2847 : : Given the tricky nature of the Fortran grammar, we must be able to
2848 : : undo changes made to a symbol table if the current interpretation
2849 : : of a statement is found to be incorrect. Whenever a symbol is
2850 : : looked up, we make a copy of it and link to it. All of these
2851 : : symbols are kept in a vector so that we can commit or
2852 : : undo the changes at a later time.
2853 : :
2854 : : A symtree may point to a symbol node outside of its namespace. In
2855 : : this case, that symbol has been used as a host associated variable
2856 : : at some previous time. */
2857 : :
2858 : : /* Allocate a new namespace structure. Copies the implicit types from
2859 : : PARENT if PARENT_TYPES is set. */
2860 : :
2861 : : gfc_namespace *
2862 : 451866 : gfc_get_namespace (gfc_namespace *parent, int parent_types)
2863 : : {
2864 : 451866 : gfc_namespace *ns;
2865 : 451866 : gfc_typespec *ts;
2866 : 451866 : int in;
2867 : 451866 : int i;
2868 : :
2869 : 451866 : ns = XCNEW (gfc_namespace);
2870 : 451866 : ns->sym_root = NULL;
2871 : 451866 : ns->uop_root = NULL;
2872 : 451866 : ns->tb_sym_root = NULL;
2873 : 451866 : ns->finalizers = NULL;
2874 : 451866 : ns->default_access = ACCESS_UNKNOWN;
2875 : 451866 : ns->parent = parent;
2876 : :
2877 : 13104114 : for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2878 : : {
2879 : 12652248 : ns->operator_access[in] = ACCESS_UNKNOWN;
2880 : 12652248 : ns->tb_op[in] = NULL;
2881 : : }
2882 : :
2883 : : /* Initialize default implicit types. */
2884 : 12200382 : for (i = 'a'; i <= 'z'; i++)
2885 : : {
2886 : 11748516 : ns->set_flag[i - 'a'] = 0;
2887 : 11748516 : ts = &ns->default_type[i - 'a'];
2888 : :
2889 : 11748516 : if (parent_types && ns->parent != NULL)
2890 : : {
2891 : : /* Copy parent settings. */
2892 : 1428934 : *ts = ns->parent->default_type[i - 'a'];
2893 : 1428934 : continue;
2894 : : }
2895 : :
2896 : 10319582 : if (flag_implicit_none != 0)
2897 : : {
2898 : 108290 : gfc_clear_ts (ts);
2899 : 108290 : continue;
2900 : : }
2901 : :
2902 : 10211292 : if ('i' <= i && i <= 'n')
2903 : : {
2904 : 2356452 : ts->type = BT_INTEGER;
2905 : 2356452 : ts->kind = gfc_default_integer_kind;
2906 : : }
2907 : : else
2908 : : {
2909 : 7854840 : ts->type = BT_REAL;
2910 : 7854840 : ts->kind = gfc_default_real_kind;
2911 : : }
2912 : : }
2913 : :
2914 : 451866 : ns->refs = 1;
2915 : :
2916 : 451866 : return ns;
2917 : : }
2918 : :
2919 : :
2920 : : /* Comparison function for symtree nodes. */
2921 : :
2922 : : static int
2923 : 28503249 : compare_symtree (void *_st1, void *_st2)
2924 : : {
2925 : 28503249 : gfc_symtree *st1, *st2;
2926 : :
2927 : 28503249 : st1 = (gfc_symtree *) _st1;
2928 : 28503249 : st2 = (gfc_symtree *) _st2;
2929 : :
2930 : 28503249 : return strcmp (st1->name, st2->name);
2931 : : }
2932 : :
2933 : :
2934 : : /* Allocate a new symtree node and associate it with the new symbol. */
2935 : :
2936 : : gfc_symtree *
2937 : 5172835 : gfc_new_symtree (gfc_symtree **root, const char *name)
2938 : : {
2939 : 5172835 : gfc_symtree *st;
2940 : :
2941 : 5172835 : st = XCNEW (gfc_symtree);
2942 : 5172835 : st->name = gfc_get_string ("%s", name);
2943 : :
2944 : 5172835 : gfc_insert_bbt (root, st, compare_symtree);
2945 : 5172835 : return st;
2946 : : }
2947 : :
2948 : :
2949 : : /* Delete a symbol from the tree. Does not free the symbol itself! */
2950 : :
2951 : : void
2952 : 3478540 : gfc_delete_symtree (gfc_symtree **root, const char *name)
2953 : : {
2954 : 3478540 : gfc_symtree st, *st0;
2955 : 3478540 : const char *p;
2956 : :
2957 : : /* Submodules are marked as mod.submod. When freeing a submodule
2958 : : symbol, the symtree only has "submod", so adjust that here. */
2959 : :
2960 : 3478540 : p = strrchr(name, '.');
2961 : 3478540 : if (p)
2962 : 0 : p++;
2963 : : else
2964 : : p = name;
2965 : :
2966 : 3478540 : st0 = gfc_find_symtree (*root, p);
2967 : :
2968 : 3478540 : st.name = gfc_get_string ("%s", p);
2969 : 3478540 : gfc_delete_bbt (root, &st, compare_symtree);
2970 : :
2971 : 3478540 : free (st0);
2972 : 3478540 : }
2973 : :
2974 : :
2975 : : /* Given a root symtree node and a name, try to find the symbol within
2976 : : the namespace. Returns NULL if the symbol is not found. */
2977 : :
2978 : : gfc_symtree *
2979 : 26573200 : gfc_find_symtree (gfc_symtree *st, const char *name)
2980 : : {
2981 : 26573200 : int c;
2982 : :
2983 : 111857261 : while (st != NULL)
2984 : : {
2985 : 98223333 : c = strcmp (name, st->name);
2986 : 98223333 : if (c == 0)
2987 : 12939272 : return st;
2988 : :
2989 : 85284061 : st = (c < 0) ? st->left : st->right;
2990 : : }
2991 : :
2992 : : return NULL;
2993 : : }
2994 : :
2995 : :
2996 : : /* Return a symtree node with a name that is guaranteed to be unique
2997 : : within the namespace and corresponds to an illegal fortran name. */
2998 : :
2999 : : gfc_symtree *
3000 : 522772 : gfc_get_unique_symtree (gfc_namespace *ns)
3001 : : {
3002 : 522772 : char name[GFC_MAX_SYMBOL_LEN + 1];
3003 : 522772 : static int serial = 0;
3004 : :
3005 : 522772 : sprintf (name, "@%d", serial++);
3006 : 522772 : return gfc_new_symtree (&ns->sym_root, name);
3007 : : }
3008 : :
3009 : :
3010 : : /* Given a name find a user operator node, creating it if it doesn't
3011 : : exist. These are much simpler than symbols because they can't be
3012 : : ambiguous with one another. */
3013 : :
3014 : : gfc_user_op *
3015 : 755 : gfc_get_uop (const char *name)
3016 : : {
3017 : 755 : gfc_user_op *uop;
3018 : 755 : gfc_symtree *st;
3019 : 755 : gfc_namespace *ns = gfc_current_ns;
3020 : :
3021 : 755 : if (ns->omp_udr_ns)
3022 : 35 : ns = ns->parent;
3023 : 755 : st = gfc_find_symtree (ns->uop_root, name);
3024 : 755 : if (st != NULL)
3025 : 422 : return st->n.uop;
3026 : :
3027 : 333 : st = gfc_new_symtree (&ns->uop_root, name);
3028 : :
3029 : 333 : uop = st->n.uop = XCNEW (gfc_user_op);
3030 : 333 : uop->name = gfc_get_string ("%s", name);
3031 : 333 : uop->access = ACCESS_UNKNOWN;
3032 : 333 : uop->ns = ns;
3033 : :
3034 : 333 : return uop;
3035 : : }
3036 : :
3037 : :
3038 : : /* Given a name find the user operator node. Returns NULL if it does
3039 : : not exist. */
3040 : :
3041 : : gfc_user_op *
3042 : 6759 : gfc_find_uop (const char *name, gfc_namespace *ns)
3043 : : {
3044 : 6759 : gfc_symtree *st;
3045 : :
3046 : 6759 : if (ns == NULL)
3047 : 18 : ns = gfc_current_ns;
3048 : :
3049 : 6759 : st = gfc_find_symtree (ns->uop_root, name);
3050 : 6759 : return (st == NULL) ? NULL : st->n.uop;
3051 : : }
3052 : :
3053 : :
3054 : : /* Update a symbol's common_block field, and take care of the associated
3055 : : memory management. */
3056 : :
3057 : : static void
3058 : 5979071 : set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block)
3059 : : {
3060 : 5979071 : if (sym->common_block == common_block)
3061 : : return;
3062 : :
3063 : 5837 : if (sym->common_block && sym->common_block->name[0] != '\0')
3064 : : {
3065 : 5496 : sym->common_block->refs--;
3066 : 5496 : if (sym->common_block->refs == 0)
3067 : 1750 : free (sym->common_block);
3068 : : }
3069 : 5837 : sym->common_block = common_block;
3070 : : }
3071 : :
3072 : :
3073 : : /* Remove a gfc_symbol structure and everything it points to. */
3074 : :
3075 : : void
3076 : 5026518 : gfc_free_symbol (gfc_symbol *&sym)
3077 : : {
3078 : :
3079 : 5026518 : if (sym == NULL)
3080 : : return;
3081 : :
3082 : 4898172 : gfc_free_array_spec (sym->as);
3083 : :
3084 : 4898172 : free_components (sym->components);
3085 : :
3086 : 4898172 : gfc_free_expr (sym->value);
3087 : :
3088 : 4898172 : gfc_free_namelist (sym->namelist);
3089 : :
3090 : 4898172 : if (sym->ns != sym->formal_ns)
3091 : 4860123 : gfc_free_namespace (sym->formal_ns);
3092 : :
3093 : 4898172 : if (!sym->attr.generic_copy)
3094 : 4898172 : gfc_free_interface (sym->generic);
3095 : :
3096 : 4898172 : gfc_free_formal_arglist (sym->formal);
3097 : :
3098 : 4898172 : gfc_free_namespace (sym->f2k_derived);
3099 : :
3100 : 4898172 : set_symbol_common_block (sym, NULL);
3101 : :
3102 : 4898172 : if (sym->param_list)
3103 : 444 : gfc_free_actual_arglist (sym->param_list);
3104 : :
3105 : 4898172 : free (sym);
3106 : 4898172 : sym = NULL;
3107 : : }
3108 : :
3109 : :
3110 : : /* Decrease the reference counter and free memory when we reach zero. */
3111 : :
3112 : : void
3113 : 4941077 : gfc_release_symbol (gfc_symbol *&sym)
3114 : : {
3115 : 4941077 : if (sym == NULL)
3116 : : return;
3117 : :
3118 : 4940658 : if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns
3119 : 27865 : && (!sym->attr.entry || !sym->module))
3120 : : {
3121 : : /* As formal_ns contains a reference to sym, delete formal_ns just
3122 : : before the deletion of sym. */
3123 : 27807 : gfc_namespace *ns = sym->formal_ns;
3124 : 27807 : sym->formal_ns = NULL;
3125 : 27807 : gfc_free_namespace (ns);
3126 : : }
3127 : :
3128 : 4940658 : sym->refs--;
3129 : 4940658 : if (sym->refs > 0)
3130 : : return;
3131 : :
3132 : 4859343 : gcc_assert (sym->refs == 0);
3133 : 4859343 : gfc_free_symbol (sym);
3134 : : }
3135 : :
3136 : :
3137 : : /* Allocate and initialize a new symbol node. */
3138 : :
3139 : : gfc_symbol *
3140 : 5083931 : gfc_new_symbol (const char *name, gfc_namespace *ns)
3141 : : {
3142 : 5083931 : gfc_symbol *p;
3143 : :
3144 : 5083931 : p = XCNEW (gfc_symbol);
3145 : :
3146 : 5083931 : gfc_clear_ts (&p->ts);
3147 : 5083931 : gfc_clear_attr (&p->attr);
3148 : 5083931 : p->ns = ns;
3149 : 5083931 : p->declared_at = gfc_current_locus;
3150 : 5083931 : p->name = gfc_get_string ("%s", name);
3151 : :
3152 : 5083931 : return p;
3153 : : }
3154 : :
3155 : :
3156 : : /* Generate an error if a symbol is ambiguous, and set the error flag
3157 : : on it. */
3158 : :
3159 : : static void
3160 : 40 : ambiguous_symbol (const char *name, gfc_symtree *st)
3161 : : {
3162 : :
3163 : 40 : if (st->n.sym->error)
3164 : : return;
3165 : :
3166 : 20 : if (st->n.sym->module)
3167 : 17 : gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3168 : : "from module %qs", name, st->n.sym->name, st->n.sym->module);
3169 : : else
3170 : 3 : gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3171 : : "from current program unit", name, st->n.sym->name);
3172 : :
3173 : 20 : st->n.sym->error = 1;
3174 : : }
3175 : :
3176 : :
3177 : : /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
3178 : : selector on the stack. If yes, replace it by the corresponding temporary. */
3179 : :
3180 : : static void
3181 : 8318913 : select_type_insert_tmp (gfc_symtree **st)
3182 : : {
3183 : 8364061 : gfc_select_type_stack *stack = select_type_stack;
3184 : 8518397 : for (; stack; stack = stack->prev)
3185 : 199484 : if ((*st)->n.sym == stack->selector && stack->tmp)
3186 : : {
3187 : 45148 : *st = stack->tmp;
3188 : 45148 : select_type_insert_tmp (st);
3189 : 45148 : return;
3190 : : }
3191 : : }
3192 : :
3193 : :
3194 : : /* Look for a symtree in the current procedure -- that is, go up to
3195 : : parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
3196 : :
3197 : : gfc_symtree*
3198 : 234 : gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
3199 : : {
3200 : 278 : while (ns)
3201 : : {
3202 : 278 : gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
3203 : 278 : if (st)
3204 : 232 : return st;
3205 : :
3206 : 46 : if (!ns->construct_entities)
3207 : : break;
3208 : 44 : ns = ns->parent;
3209 : : }
3210 : :
3211 : : return NULL;
3212 : : }
3213 : :
3214 : :
3215 : : /* Search for a symtree starting in the current namespace, resorting to
3216 : : any parent namespaces if requested by a nonzero parent_flag.
3217 : : Returns true if the name is ambiguous. */
3218 : :
3219 : : bool
3220 : 14419978 : gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
3221 : : gfc_symtree **result)
3222 : : {
3223 : 14419978 : gfc_symtree *st;
3224 : :
3225 : 14419978 : if (ns == NULL)
3226 : 5323772 : ns = gfc_current_ns;
3227 : :
3228 : 16173243 : do
3229 : : {
3230 : 16173243 : st = gfc_find_symtree (ns->sym_root, name);
3231 : 16173243 : if (st != NULL)
3232 : : {
3233 : 8318913 : select_type_insert_tmp (&st);
3234 : :
3235 : 8318913 : *result = st;
3236 : : /* Ambiguous generic interfaces are permitted, as long
3237 : : as the specific interfaces are different. */
3238 : 8318913 : if (st->ambiguous && !st->n.sym->attr.generic)
3239 : : {
3240 : 36 : ambiguous_symbol (name, st);
3241 : 36 : return true;
3242 : : }
3243 : :
3244 : : return false;
3245 : : }
3246 : :
3247 : 7854330 : if (!parent_flag)
3248 : : break;
3249 : :
3250 : : /* Don't escape an interface block. */
3251 : 5442036 : if (ns && !ns->has_import_set
3252 : 5435051 : && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
3253 : : break;
3254 : :
3255 : 5308743 : ns = ns->parent;
3256 : : }
3257 : 5308743 : while (ns != NULL);
3258 : :
3259 : 6101065 : if (gfc_current_state() == COMP_DERIVED
3260 : 157941 : && gfc_current_block ()->attr.pdt_template)
3261 : : {
3262 : : gfc_symbol *der = gfc_current_block ();
3263 : 9900 : for (; der; der = gfc_get_derived_super_type (der))
3264 : : {
3265 : 5603 : if (der->f2k_derived && der->f2k_derived->sym_root)
3266 : : {
3267 : 5597 : st = gfc_find_symtree (der->f2k_derived->sym_root, name);
3268 : 5597 : if (st)
3269 : : break;
3270 : : }
3271 : : }
3272 : 5464 : *result = st;
3273 : 5464 : return false;
3274 : : }
3275 : :
3276 : 6095601 : *result = NULL;
3277 : :
3278 : 6095601 : return false;
3279 : : }
3280 : :
3281 : :
3282 : : /* Same, but returns the symbol instead. */
3283 : :
3284 : : int
3285 : 1916653 : gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
3286 : : gfc_symbol **result)
3287 : : {
3288 : 1916653 : gfc_symtree *st;
3289 : 1916653 : int i;
3290 : :
3291 : 1916653 : i = gfc_find_sym_tree (name, ns, parent_flag, &st);
3292 : :
3293 : 1916653 : if (st == NULL)
3294 : 1439090 : *result = NULL;
3295 : : else
3296 : 477563 : *result = st->n.sym;
3297 : :
3298 : 1916653 : return i;
3299 : : }
3300 : :
3301 : :
3302 : : /* Tells whether there is only one set of changes in the stack. */
3303 : :
3304 : : static bool
3305 : 33637966 : single_undo_checkpoint_p (void)
3306 : : {
3307 : 33637966 : if (latest_undo_chgset == &default_undo_chgset_var)
3308 : : {
3309 : 33637966 : gcc_assert (latest_undo_chgset->previous == NULL);
3310 : : return true;
3311 : : }
3312 : : else
3313 : : {
3314 : 0 : gcc_assert (latest_undo_chgset->previous != NULL);
3315 : : return false;
3316 : : }
3317 : : }
3318 : :
3319 : : /* Save symbol with the information necessary to back it out. */
3320 : :
3321 : : void
3322 : 4810933 : gfc_save_symbol_data (gfc_symbol *sym)
3323 : : {
3324 : 4810933 : gfc_symbol *s;
3325 : 4810933 : unsigned i;
3326 : :
3327 : 4810933 : if (!single_undo_checkpoint_p ())
3328 : : {
3329 : : /* If there is more than one change set, look for the symbol in the
3330 : : current one. If it is found there, we can reuse it. */
3331 : 0 : FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
3332 : 0 : if (s == sym)
3333 : : {
3334 : 0 : gcc_assert (sym->gfc_new || sym->old_symbol != NULL);
3335 : 4810933 : return;
3336 : : }
3337 : : }
3338 : 4810933 : else if (sym->gfc_new || sym->old_symbol != NULL)
3339 : : return;
3340 : :
3341 : 2345638 : s = XCNEW (gfc_symbol);
3342 : 2345638 : *s = *sym;
3343 : 2345638 : sym->old_symbol = s;
3344 : 2345638 : sym->gfc_new = 0;
3345 : :
3346 : 2345638 : latest_undo_chgset->syms.safe_push (sym);
3347 : : }
3348 : :
3349 : :
3350 : : /* Given a name, find a symbol, or create it if it does not exist yet
3351 : : in the current namespace. If the symbol is found we make sure that
3352 : : it's OK.
3353 : :
3354 : : The integer return code indicates
3355 : : 0 All OK
3356 : : 1 The symbol name was ambiguous
3357 : : 2 The name meant to be established was already host associated.
3358 : :
3359 : : So if the return value is nonzero, then an error was issued. */
3360 : :
3361 : : int
3362 : 5028911 : gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
3363 : : bool allow_subroutine)
3364 : : {
3365 : 5028911 : gfc_symtree *st;
3366 : 5028911 : gfc_symbol *p;
3367 : :
3368 : : /* This doesn't usually happen during resolution. */
3369 : 5028911 : if (ns == NULL)
3370 : 2492517 : ns = gfc_current_ns;
3371 : :
3372 : : /* Try to find the symbol in ns. */
3373 : 5028911 : st = gfc_find_symtree (ns->sym_root, name);
3374 : :
3375 : 5028911 : if (st == NULL && ns->omp_udr_ns)
3376 : : {
3377 : 319 : ns = ns->parent;
3378 : 319 : st = gfc_find_symtree (ns->sym_root, name);
3379 : : }
3380 : :
3381 : 4300413 : if (st == NULL)
3382 : : {
3383 : : /* If not there, create a new symbol. */
3384 : 4300283 : p = gfc_new_symbol (name, ns);
3385 : :
3386 : : /* Add to the list of tentative symbols. */
3387 : 4300283 : p->old_symbol = NULL;
3388 : 4300283 : p->mark = 1;
3389 : 4300283 : p->gfc_new = 1;
3390 : 4300283 : latest_undo_chgset->syms.safe_push (p);
3391 : :
3392 : 4300283 : st = gfc_new_symtree (&ns->sym_root, name);
3393 : 4300283 : st->n.sym = p;
3394 : 4300283 : p->refs++;
3395 : :
3396 : : }
3397 : : else
3398 : : {
3399 : : /* Make sure the existing symbol is OK. Ambiguous
3400 : : generic interfaces are permitted, as long as the
3401 : : specific interfaces are different. */
3402 : 728628 : if (st->ambiguous && !st->n.sym->attr.generic)
3403 : : {
3404 : 4 : ambiguous_symbol (name, st);
3405 : 4 : return 1;
3406 : : }
3407 : :
3408 : 728624 : p = st->n.sym;
3409 : 728624 : if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
3410 : 7004 : && !(allow_subroutine && p->attr.subroutine)
3411 : 6996 : && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
3412 : 6966 : && (ns->has_import_set || p->attr.imported)))
3413 : : {
3414 : : /* Symbol is from another namespace. */
3415 : 31 : gfc_error ("Symbol %qs at %C has already been host associated",
3416 : : name);
3417 : 31 : return 2;
3418 : : }
3419 : :
3420 : 728593 : p->mark = 1;
3421 : :
3422 : : /* Copy in case this symbol is changed. */
3423 : 728593 : gfc_save_symbol_data (p);
3424 : : }
3425 : :
3426 : 5028876 : *result = st;
3427 : 5028876 : return 0;
3428 : : }
3429 : :
3430 : :
3431 : : int
3432 : 812819 : gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
3433 : : {
3434 : 812819 : gfc_symtree *st;
3435 : 812819 : int i;
3436 : :
3437 : 812819 : i = gfc_get_sym_tree (name, ns, &st, false);
3438 : 812819 : if (i != 0)
3439 : : return i;
3440 : :
3441 : 812814 : if (st)
3442 : 812814 : *result = st->n.sym;
3443 : : else
3444 : 0 : *result = NULL;
3445 : : return i;
3446 : : }
3447 : :
3448 : :
3449 : : /* Subroutine that searches for a symbol, creating it if it doesn't
3450 : : exist, but tries to host-associate the symbol if possible. */
3451 : :
3452 : : int
3453 : 6322567 : gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
3454 : : {
3455 : 6322567 : gfc_symtree *st;
3456 : 6322567 : int i;
3457 : :
3458 : 6322567 : i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
3459 : :
3460 : 6322567 : if (st != NULL)
3461 : : {
3462 : 4028204 : gfc_save_symbol_data (st->n.sym);
3463 : 4028204 : *result = st;
3464 : 4028204 : return i;
3465 : : }
3466 : :
3467 : 2294363 : i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st);
3468 : 2294363 : if (i)
3469 : : return i;
3470 : :
3471 : 2294363 : if (st != NULL)
3472 : : {
3473 : 229896 : *result = st;
3474 : 229896 : return 0;
3475 : : }
3476 : :
3477 : 2064467 : return gfc_get_sym_tree (name, gfc_current_ns, result, false);
3478 : : }
3479 : :
3480 : :
3481 : : int
3482 : 27077 : gfc_get_ha_symbol (const char *name, gfc_symbol **result)
3483 : : {
3484 : 27077 : int i;
3485 : 27077 : gfc_symtree *st;
3486 : :
3487 : 27077 : i = gfc_get_ha_sym_tree (name, &st);
3488 : :
3489 : 27077 : if (st)
3490 : 27077 : *result = st->n.sym;
3491 : : else
3492 : 0 : *result = NULL;
3493 : :
3494 : 27077 : return i;
3495 : : }
3496 : :
3497 : :
3498 : : /* Search for the symtree belonging to a gfc_common_head; we cannot use
3499 : : head->name as the common_root symtree's name might be mangled. */
3500 : :
3501 : : static gfc_symtree *
3502 : 17 : find_common_symtree (gfc_symtree *st, gfc_common_head *head)
3503 : : {
3504 : :
3505 : 20 : gfc_symtree *result;
3506 : :
3507 : 20 : if (st == NULL)
3508 : : return NULL;
3509 : :
3510 : 14 : if (st->n.common == head)
3511 : : return st;
3512 : :
3513 : 3 : result = find_common_symtree (st->left, head);
3514 : 3 : if (!result)
3515 : 3 : result = find_common_symtree (st->right, head);
3516 : :
3517 : : return result;
3518 : : }
3519 : :
3520 : :
3521 : : /* Restore previous state of symbol. Just copy simple stuff. */
3522 : :
3523 : : static void
3524 : 1080899 : restore_old_symbol (gfc_symbol *p)
3525 : : {
3526 : 1080899 : gfc_symbol *old;
3527 : :
3528 : 1080899 : p->mark = 0;
3529 : 1080899 : old = p->old_symbol;
3530 : :
3531 : 1080899 : p->ts.type = old->ts.type;
3532 : 1080899 : p->ts.kind = old->ts.kind;
3533 : :
3534 : 1080899 : p->attr = old->attr;
3535 : :
3536 : 1080899 : if (p->value != old->value)
3537 : : {
3538 : 1 : gcc_checking_assert (old->value == NULL);
3539 : 1 : gfc_free_expr (p->value);
3540 : 1 : p->value = NULL;
3541 : : }
3542 : :
3543 : 1080899 : if (p->as != old->as)
3544 : : {
3545 : 7 : if (p->as)
3546 : 7 : gfc_free_array_spec (p->as);
3547 : 7 : p->as = old->as;
3548 : : }
3549 : :
3550 : 1080899 : p->generic = old->generic;
3551 : 1080899 : p->component_access = old->component_access;
3552 : :
3553 : 1080899 : if (p->namelist != NULL && old->namelist == NULL)
3554 : : {
3555 : 0 : gfc_free_namelist (p->namelist);
3556 : 0 : p->namelist = NULL;
3557 : : }
3558 : : else
3559 : : {
3560 : 1080899 : if (p->namelist_tail != old->namelist_tail)
3561 : : {
3562 : 1 : gfc_free_namelist (old->namelist_tail->next);
3563 : 1 : old->namelist_tail->next = NULL;
3564 : : }
3565 : : }
3566 : :
3567 : 1080899 : p->namelist_tail = old->namelist_tail;
3568 : :
3569 : 1080899 : if (p->formal != old->formal)
3570 : : {
3571 : 16 : gfc_free_formal_arglist (p->formal);
3572 : 16 : p->formal = old->formal;
3573 : : }
3574 : :
3575 : 1080899 : set_symbol_common_block (p, old->common_block);
3576 : 1080899 : p->common_head = old->common_head;
3577 : :
3578 : 1080899 : p->old_symbol = old->old_symbol;
3579 : 1080899 : free (old);
3580 : 1080899 : }
3581 : :
3582 : :
3583 : : /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3584 : : the structure itself. */
3585 : :
3586 : : static void
3587 : 74461 : free_undo_change_set_data (gfc_undo_change_set &cs)
3588 : : {
3589 : 0 : cs.syms.release ();
3590 : 74461 : cs.tbps.release ();
3591 : 0 : }
3592 : :
3593 : :
3594 : : /* Given a change set pointer, free its target's contents and update it with
3595 : : the address of the previous change set. Note that only the contents are
3596 : : freed, not the target itself (the contents' container). It is not a problem
3597 : : as the latter will be a local variable usually. */
3598 : :
3599 : : static void
3600 : 0 : pop_undo_change_set (gfc_undo_change_set *&cs)
3601 : : {
3602 : 0 : free_undo_change_set_data (*cs);
3603 : 0 : cs = cs->previous;
3604 : 0 : }
3605 : :
3606 : :
3607 : : static void free_old_symbol (gfc_symbol *sym);
3608 : :
3609 : :
3610 : : /* Merges the current change set into the previous one. The changes themselves
3611 : : are left untouched; only one checkpoint is forgotten. */
3612 : :
3613 : : void
3614 : 0 : gfc_drop_last_undo_checkpoint (void)
3615 : : {
3616 : 0 : gfc_symbol *s, *t;
3617 : 0 : unsigned i, j;
3618 : :
3619 : 0 : FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
3620 : : {
3621 : : /* No need to loop in this case. */
3622 : 0 : if (s->old_symbol == NULL)
3623 : 0 : continue;
3624 : :
3625 : : /* Remove the duplicate symbols. */
3626 : 0 : FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)
3627 : 0 : if (t == s)
3628 : : {
3629 : 0 : latest_undo_chgset->previous->syms.unordered_remove (j);
3630 : :
3631 : : /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3632 : : last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3633 : : shall contain from now on the backup symbol for S as it was
3634 : : at the checkpoint before. */
3635 : 0 : if (s->old_symbol->gfc_new)
3636 : : {
3637 : 0 : gcc_assert (s->old_symbol->old_symbol == NULL);
3638 : 0 : s->gfc_new = s->old_symbol->gfc_new;
3639 : 0 : free_old_symbol (s);
3640 : : }
3641 : : else
3642 : 0 : restore_old_symbol (s->old_symbol);
3643 : : break;
3644 : : }
3645 : : }
3646 : :
3647 : 0 : latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
3648 : 0 : latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);
3649 : :
3650 : 0 : pop_undo_change_set (latest_undo_chgset);
3651 : 0 : }
3652 : :
3653 : :
3654 : : /* Undoes all the changes made to symbols since the previous checkpoint.
3655 : : This subroutine is made simpler due to the fact that attributes are
3656 : : never removed once added. */
3657 : :
3658 : : void
3659 : 10800235 : gfc_restore_last_undo_checkpoint (void)
3660 : : {
3661 : 10800235 : gfc_symbol *p;
3662 : 10800235 : unsigned i;
3663 : :
3664 : 26131923 : FOR_EACH_VEC_ELT_REVERSE (latest_undo_chgset->syms, i, p)
3665 : : {
3666 : : /* Symbol in a common block was new. Or was old and just put in common */
3667 : 4559439 : if (p->common_block
3668 : 3808 : && (p->gfc_new || !p->old_symbol->common_block))
3669 : : {
3670 : : /* If the symbol was added to any common block, it
3671 : : needs to be removed to stop the resolver looking
3672 : : for a (possibly) dead symbol. */
3673 : 80 : if (p->common_block->head == p && !p->common_next)
3674 : : {
3675 : 14 : gfc_symtree st, *st0;
3676 : 14 : st0 = find_common_symtree (p->ns->common_root,
3677 : : p->common_block);
3678 : 14 : if (st0)
3679 : : {
3680 : 11 : st.name = st0->name;
3681 : 11 : gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
3682 : 11 : free (st0);
3683 : : }
3684 : : }
3685 : :
3686 : 80 : if (p->common_block->head == p)
3687 : 14 : p->common_block->head = p->common_next;
3688 : : else
3689 : : {
3690 : 66 : gfc_symbol *cparent, *csym;
3691 : :
3692 : 66 : cparent = p->common_block->head;
3693 : 66 : csym = cparent->common_next;
3694 : :
3695 : 290 : while (csym != p)
3696 : : {
3697 : 224 : cparent = csym;
3698 : 224 : csym = csym->common_next;
3699 : : }
3700 : :
3701 : 66 : gcc_assert(cparent->common_next == p);
3702 : 66 : cparent->common_next = csym->common_next;
3703 : : }
3704 : 80 : p->common_next = NULL;
3705 : : }
3706 : 4559439 : if (p->gfc_new)
3707 : : {
3708 : : /* The derived type is saved in the symtree with the first
3709 : : letter capitalized; the all lower-case version to the
3710 : : derived type contains its associated generic function. */
3711 : 3478540 : if (gfc_fl_struct (p->attr.flavor))
3712 : 35 : gfc_delete_symtree (&p->ns->sym_root,gfc_dt_upper_string (p->name));
3713 : : else
3714 : 3478505 : gfc_delete_symtree (&p->ns->sym_root, p->name);
3715 : :
3716 : 3478540 : gfc_release_symbol (p);
3717 : : }
3718 : : else
3719 : 1080899 : restore_old_symbol (p);
3720 : : }
3721 : :
3722 : 10800235 : latest_undo_chgset->syms.truncate (0);
3723 : 10800235 : latest_undo_chgset->tbps.truncate (0);
3724 : :
3725 : 10800235 : if (!single_undo_checkpoint_p ())
3726 : 0 : pop_undo_change_set (latest_undo_chgset);
3727 : 10800235 : }
3728 : :
3729 : :
3730 : : /* Makes sure that there is only one set of changes; in other words we haven't
3731 : : forgotten to pair a call to gfc_new_checkpoint with a call to either
3732 : : gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3733 : :
3734 : : static void
3735 : 18026798 : enforce_single_undo_checkpoint (void)
3736 : : {
3737 : 18026798 : gcc_checking_assert (single_undo_checkpoint_p ());
3738 : 18026798 : }
3739 : :
3740 : :
3741 : : /* Undoes all the changes made to symbols in the current statement. */
3742 : :
3743 : : void
3744 : 10800235 : gfc_undo_symbols (void)
3745 : : {
3746 : 10800235 : enforce_single_undo_checkpoint ();
3747 : 10800235 : gfc_restore_last_undo_checkpoint ();
3748 : 10800235 : }
3749 : :
3750 : :
3751 : : /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3752 : : components of old_symbol that might need deallocation are the "allocatables"
3753 : : that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3754 : : namelist_tail. In case these differ between old_symbol and sym, it's just
3755 : : because sym->namelist has gotten a few more items. */
3756 : :
3757 : : static void
3758 : 2148659 : free_old_symbol (gfc_symbol *sym)
3759 : : {
3760 : :
3761 : 2148659 : if (sym->old_symbol == NULL)
3762 : : return;
3763 : :
3764 : 1264739 : if (sym->old_symbol->as != NULL
3765 : 227965 : && sym->old_symbol->as != sym->as
3766 : 2 : && !(sym->ts.type == BT_CLASS
3767 : 2 : && sym->ts.u.derived->attr.is_class
3768 : 2 : && sym->old_symbol->as == CLASS_DATA (sym)->as))
3769 : 0 : gfc_free_array_spec (sym->old_symbol->as);
3770 : :
3771 : 1264739 : if (sym->old_symbol->value != sym->value)
3772 : 5085 : gfc_free_expr (sym->old_symbol->value);
3773 : :
3774 : 1264739 : if (sym->old_symbol->formal != sym->formal)
3775 : 14790 : gfc_free_formal_arglist (sym->old_symbol->formal);
3776 : :
3777 : 1264739 : free (sym->old_symbol);
3778 : 1264739 : sym->old_symbol = NULL;
3779 : : }
3780 : :
3781 : :
3782 : : /* Makes the changes made in the current statement permanent-- gets
3783 : : rid of undo information. */
3784 : :
3785 : : void
3786 : 1250570 : gfc_commit_symbols (void)
3787 : : {
3788 : 1250570 : gfc_symbol *p;
3789 : 1250570 : gfc_typebound_proc *tbp;
3790 : 1250570 : unsigned i;
3791 : :
3792 : 1250570 : enforce_single_undo_checkpoint ();
3793 : :
3794 : 4145300 : FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3795 : : {
3796 : 1644160 : p->mark = 0;
3797 : 1644160 : p->gfc_new = 0;
3798 : 1644160 : free_old_symbol (p);
3799 : : }
3800 : 1250570 : latest_undo_chgset->syms.truncate (0);
3801 : :
3802 : 2551227 : FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)
3803 : 50087 : tbp->error = 0;
3804 : 1250570 : latest_undo_chgset->tbps.truncate (0);
3805 : 1250570 : }
3806 : :
3807 : :
3808 : : /* Makes the changes made in one symbol permanent -- gets rid of undo
3809 : : information. */
3810 : :
3811 : : void
3812 : 504499 : gfc_commit_symbol (gfc_symbol *sym)
3813 : : {
3814 : 504499 : gfc_symbol *p;
3815 : 504499 : unsigned i;
3816 : :
3817 : 504499 : enforce_single_undo_checkpoint ();
3818 : :
3819 : 1820693 : FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3820 : 1250909 : if (p == sym)
3821 : : {
3822 : 439214 : latest_undo_chgset->syms.unordered_remove (i);
3823 : 439214 : break;
3824 : : }
3825 : :
3826 : 504499 : sym->mark = 0;
3827 : 504499 : sym->gfc_new = 0;
3828 : :
3829 : 504499 : free_old_symbol (sym);
3830 : 504499 : }
3831 : :
3832 : :
3833 : : /* Recursively free trees containing type-bound procedures. */
3834 : :
3835 : : static void
3836 : 841016 : free_tb_tree (gfc_symtree *t)
3837 : : {
3838 : 841016 : if (t == NULL)
3839 : : return;
3840 : :
3841 : 6192 : free_tb_tree (t->left);
3842 : 6192 : free_tb_tree (t->right);
3843 : :
3844 : : /* TODO: Free type-bound procedure u.generic */
3845 : 6192 : free (t->n.tb);
3846 : 6192 : t->n.tb = NULL;
3847 : 6192 : free (t);
3848 : : }
3849 : :
3850 : :
3851 : : /* Recursive function that deletes an entire tree and all the common
3852 : : head structures it points to. */
3853 : :
3854 : : static void
3855 : 418162 : free_common_tree (gfc_symtree * common_tree)
3856 : : {
3857 : 418162 : if (common_tree == NULL)
3858 : : return;
3859 : :
3860 : 1923 : free_common_tree (common_tree->left);
3861 : 1923 : free_common_tree (common_tree->right);
3862 : :
3863 : 1923 : free (common_tree);
3864 : : }
3865 : :
3866 : :
3867 : : /* Recursive function that deletes an entire tree and all the common
3868 : : head structures it points to. */
3869 : :
3870 : : static void
3871 : 415324 : free_omp_udr_tree (gfc_symtree * omp_udr_tree)
3872 : : {
3873 : 415324 : if (omp_udr_tree == NULL)
3874 : : return;
3875 : :
3876 : 504 : free_omp_udr_tree (omp_udr_tree->left);
3877 : 504 : free_omp_udr_tree (omp_udr_tree->right);
3878 : :
3879 : 504 : gfc_free_omp_udr (omp_udr_tree->n.omp_udr);
3880 : 504 : free (omp_udr_tree);
3881 : : }
3882 : :
3883 : :
3884 : : /* Recursive function that deletes an entire tree and all the user
3885 : : operator nodes that it contains. */
3886 : :
3887 : : static void
3888 : 414982 : free_uop_tree (gfc_symtree *uop_tree)
3889 : : {
3890 : 414982 : if (uop_tree == NULL)
3891 : : return;
3892 : :
3893 : 333 : free_uop_tree (uop_tree->left);
3894 : 333 : free_uop_tree (uop_tree->right);
3895 : :
3896 : 333 : gfc_free_interface (uop_tree->n.uop->op);
3897 : 333 : free (uop_tree->n.uop);
3898 : 333 : free (uop_tree);
3899 : : }
3900 : :
3901 : :
3902 : : /* Recursive function that deletes an entire tree and all the symbols
3903 : : that it contains. */
3904 : :
3905 : : static void
3906 : 3332104 : free_sym_tree (gfc_symtree *sym_tree)
3907 : : {
3908 : 3332104 : if (sym_tree == NULL)
3909 : : return;
3910 : :
3911 : 1458894 : free_sym_tree (sym_tree->left);
3912 : 1458894 : free_sym_tree (sym_tree->right);
3913 : :
3914 : 1458894 : gfc_release_symbol (sym_tree->n.sym);
3915 : 1458894 : free (sym_tree);
3916 : : }
3917 : :
3918 : :
3919 : : /* Free the gfc_equiv_info's. */
3920 : :
3921 : : static void
3922 : 14848 : gfc_free_equiv_infos (gfc_equiv_info *s)
3923 : : {
3924 : 14848 : if (s == NULL)
3925 : : return;
3926 : 8212 : gfc_free_equiv_infos (s->next);
3927 : 8212 : free (s);
3928 : : }
3929 : :
3930 : :
3931 : : /* Free the gfc_equiv_lists. */
3932 : :
3933 : : static void
3934 : 420952 : gfc_free_equiv_lists (gfc_equiv_list *l)
3935 : : {
3936 : 420952 : if (l == NULL)
3937 : : return;
3938 : 6636 : gfc_free_equiv_lists (l->next);
3939 : 6636 : gfc_free_equiv_infos (l->equiv);
3940 : 6636 : free (l);
3941 : : }
3942 : :
3943 : :
3944 : : /* Free a finalizer procedure list. */
3945 : :
3946 : : void
3947 : 748 : gfc_free_finalizer (gfc_finalizer* el)
3948 : : {
3949 : 748 : if (el)
3950 : : {
3951 : 748 : gfc_release_symbol (el->proc_sym);
3952 : 748 : free (el);
3953 : : }
3954 : 748 : }
3955 : :
3956 : : static void
3957 : 414316 : gfc_free_finalizer_list (gfc_finalizer* list)
3958 : : {
3959 : 415050 : while (list)
3960 : : {
3961 : 734 : gfc_finalizer* current = list;
3962 : 734 : list = list->next;
3963 : 734 : gfc_free_finalizer (current);
3964 : : }
3965 : 414316 : }
3966 : :
3967 : :
3968 : : /* Create a new gfc_charlen structure and add it to a namespace.
3969 : : If 'old_cl' is given, the newly created charlen will be a copy of it. */
3970 : :
3971 : : gfc_charlen*
3972 : 254868 : gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3973 : : {
3974 : 254868 : gfc_charlen *cl;
3975 : :
3976 : 254868 : cl = gfc_get_charlen ();
3977 : :
3978 : : /* Copy old_cl. */
3979 : 254868 : if (old_cl)
3980 : : {
3981 : 9787 : cl->length = gfc_copy_expr (old_cl->length);
3982 : 9787 : cl->length_from_typespec = old_cl->length_from_typespec;
3983 : 9787 : cl->backend_decl = old_cl->backend_decl;
3984 : 9787 : cl->passed_length = old_cl->passed_length;
3985 : 9787 : cl->resolved = old_cl->resolved;
3986 : : }
3987 : :
3988 : : /* Put into namespace. */
3989 : 254868 : cl->next = ns->cl_list;
3990 : 254868 : ns->cl_list = cl;
3991 : :
3992 : 254868 : return cl;
3993 : : }
3994 : :
3995 : :
3996 : : /* Free the charlen list from cl to end (end is not freed).
3997 : : Free the whole list if end is NULL. */
3998 : :
3999 : : static void
4000 : 414316 : gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
4001 : : {
4002 : 414316 : gfc_charlen *cl2;
4003 : :
4004 : 655069 : for (; cl != end; cl = cl2)
4005 : : {
4006 : 240753 : gcc_assert (cl);
4007 : :
4008 : 240753 : cl2 = cl->next;
4009 : 240753 : gfc_free_expr (cl->length);
4010 : 240753 : free (cl);
4011 : : }
4012 : 414316 : }
4013 : :
4014 : :
4015 : : /* Free entry list structs. */
4016 : :
4017 : : static void
4018 : 0 : free_entry_list (gfc_entry_list *el)
4019 : : {
4020 : 415615 : gfc_entry_list *next;
4021 : :
4022 : 415615 : if (el == NULL)
4023 : 0 : return;
4024 : :
4025 : 1299 : next = el->next;
4026 : 1299 : free (el);
4027 : 1299 : free_entry_list (next);
4028 : : }
4029 : :
4030 : :
4031 : : /* Free a namespace structure and everything below it. Interface
4032 : : lists associated with intrinsic operators are not freed. These are
4033 : : taken care of when a specific name is freed. */
4034 : :
4035 : : void
4036 : 9970145 : gfc_free_namespace (gfc_namespace *&ns)
4037 : : {
4038 : 9970145 : gfc_namespace *p, *q;
4039 : 9970145 : int i;
4040 : 9970145 : gfc_was_finalized *f;
4041 : :
4042 : 9970145 : if (ns == NULL)
4043 : 9555829 : return;
4044 : :
4045 : 436320 : ns->refs--;
4046 : 436320 : if (ns->refs > 0)
4047 : : return;
4048 : :
4049 : 414316 : gcc_assert (ns->refs == 0);
4050 : :
4051 : 414316 : gfc_free_statements (ns->code);
4052 : :
4053 : 414316 : free_sym_tree (ns->sym_root);
4054 : 414316 : free_uop_tree (ns->uop_root);
4055 : 414316 : free_common_tree (ns->common_root);
4056 : 414316 : free_omp_udr_tree (ns->omp_udr_root);
4057 : 414316 : free_tb_tree (ns->tb_sym_root);
4058 : 414316 : free_tb_tree (ns->tb_uop_root);
4059 : 414316 : gfc_free_finalizer_list (ns->finalizers);
4060 : 414316 : gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
4061 : 414316 : gfc_free_omp_declare_variant_list (ns->omp_declare_variant);
4062 : 414316 : gfc_free_charlen (ns->cl_list, NULL);
4063 : 414316 : free_st_labels (ns->st_labels);
4064 : :
4065 : 414316 : free_entry_list (ns->entries);
4066 : 414316 : gfc_free_equiv (ns->equiv);
4067 : 414316 : gfc_free_equiv_lists (ns->equiv_lists);
4068 : 414316 : gfc_free_use_stmts (ns->use_stmts);
4069 : :
4070 : 12429480 : for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4071 : 11600848 : gfc_free_interface (ns->op[i]);
4072 : :
4073 : 414316 : gfc_free_data (ns->data);
4074 : :
4075 : : /* Free all the expr + component combinations that have been
4076 : : finalized. */
4077 : 414316 : f = ns->was_finalized;
4078 : 416254 : while (f)
4079 : : {
4080 : 1938 : gfc_was_finalized* current = f;
4081 : 1938 : f = f->next;
4082 : 1938 : free (current);
4083 : : }
4084 : 414316 : if (ns->omp_assumes)
4085 : : {
4086 : 13 : free (ns->omp_assumes->absent);
4087 : 13 : free (ns->omp_assumes->contains);
4088 : 13 : gfc_free_expr_list (ns->omp_assumes->holds);
4089 : 13 : free (ns->omp_assumes);
4090 : : }
4091 : 414316 : p = ns->contained;
4092 : 414316 : free (ns);
4093 : 414316 : ns = NULL;
4094 : :
4095 : : /* Recursively free any contained namespaces. */
4096 : 453240 : while (p != NULL)
4097 : : {
4098 : 38924 : q = p;
4099 : 38924 : p = p->sibling;
4100 : 38924 : gfc_free_namespace (q);
4101 : : }
4102 : : }
4103 : :
4104 : :
4105 : : void
4106 : 74166 : gfc_symbol_init_2 (void)
4107 : : {
4108 : :
4109 : 74166 : gfc_current_ns = gfc_get_namespace (NULL, 0);
4110 : 74166 : }
4111 : :
4112 : :
4113 : : void
4114 : 74461 : gfc_symbol_done_2 (void)
4115 : : {
4116 : 74461 : if (gfc_current_ns != NULL)
4117 : : {
4118 : : /* free everything from the root. */
4119 : 74471 : while (gfc_current_ns->parent != NULL)
4120 : 10 : gfc_current_ns = gfc_current_ns->parent;
4121 : 74461 : gfc_free_namespace (gfc_current_ns);
4122 : 74461 : gfc_current_ns = NULL;
4123 : : }
4124 : 74461 : gfc_derived_types = NULL;
4125 : :
4126 : 74461 : enforce_single_undo_checkpoint ();
4127 : 74461 : free_undo_change_set_data (*latest_undo_chgset);
4128 : 74461 : }
4129 : :
4130 : :
4131 : : /* Count how many nodes a symtree has. */
4132 : :
4133 : : static unsigned
4134 : 20654712 : count_st_nodes (const gfc_symtree *st)
4135 : : {
4136 : 38477069 : unsigned nodes;
4137 : 38477069 : if (!st)
4138 : 20654712 : return 0;
4139 : :
4140 : 17822357 : nodes = count_st_nodes (st->left);
4141 : 17822357 : nodes++;
4142 : 17822357 : nodes += count_st_nodes (st->right);
4143 : :
4144 : 17822357 : return nodes;
4145 : : }
4146 : :
4147 : :
4148 : : /* Convert symtree tree into symtree vector. */
4149 : :
4150 : : static unsigned
4151 : 20654712 : fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
4152 : : {
4153 : 38477069 : if (!st)
4154 : 20654712 : return node_cntr;
4155 : :
4156 : 17822357 : node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
4157 : 17822357 : st_vec[node_cntr++] = st;
4158 : 17822357 : node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
4159 : :
4160 : 17822357 : return node_cntr;
4161 : : }
4162 : :
4163 : :
4164 : : /* Traverse namespace. As the functions might modify the symtree, we store the
4165 : : symtree as a vector and operate on this vector. Note: We assume that
4166 : : sym_func or st_func never deletes nodes from the symtree - only adding is
4167 : : allowed. Additionally, newly added nodes are not traversed. */
4168 : :
4169 : : static void
4170 : 2832355 : do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
4171 : : void (*sym_func) (gfc_symbol *))
4172 : : {
4173 : 2832355 : gfc_symtree **st_vec;
4174 : 2832355 : unsigned nodes, i, node_cntr;
4175 : :
4176 : 2832355 : gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
4177 : 2832355 : nodes = count_st_nodes (st);
4178 : 2832355 : st_vec = XALLOCAVEC (gfc_symtree *, nodes);
4179 : 2832355 : node_cntr = 0;
4180 : 2832355 : fill_st_vector (st, st_vec, node_cntr);
4181 : :
4182 : 2832355 : if (sym_func)
4183 : : {
4184 : : /* Clear marks. */
4185 : 20397839 : for (i = 0; i < nodes; i++)
4186 : 17679308 : st_vec[i]->n.sym->mark = 0;
4187 : 20397839 : for (i = 0; i < nodes; i++)
4188 : 17679308 : if (!st_vec[i]->n.sym->mark)
4189 : : {
4190 : 17143374 : (*sym_func) (st_vec[i]->n.sym);
4191 : 17143374 : st_vec[i]->n.sym->mark = 1;
4192 : : }
4193 : : }
4194 : : else
4195 : 256873 : for (i = 0; i < nodes; i++)
4196 : 143049 : (*st_func) (st_vec[i]);
4197 : 2832355 : }
4198 : :
4199 : :
4200 : : /* Recursively traverse the symtree nodes. */
4201 : :
4202 : : void
4203 : 113824 : gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
4204 : : {
4205 : 113824 : do_traverse_symtree (st, st_func, NULL);
4206 : 113824 : }
4207 : :
4208 : :
4209 : : /* Call a given function for all symbols in the namespace. We take
4210 : : care that each gfc_symbol node is called exactly once. */
4211 : :
4212 : : void
4213 : 2718531 : gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
4214 : : {
4215 : 2718531 : do_traverse_symtree (ns->sym_root, NULL, sym_func);
4216 : 2718531 : }
4217 : :
4218 : :
4219 : : /* Return TRUE when name is the name of an intrinsic type. */
4220 : :
4221 : : bool
4222 : 11790 : gfc_is_intrinsic_typename (const char *name)
4223 : : {
4224 : 11790 : if (strcmp (name, "integer") == 0
4225 : 11787 : || strcmp (name, "real") == 0
4226 : 11784 : || strcmp (name, "character") == 0
4227 : 11782 : || strcmp (name, "logical") == 0
4228 : 11780 : || strcmp (name, "complex") == 0
4229 : 11776 : || strcmp (name, "doubleprecision") == 0
4230 : 11773 : || strcmp (name, "doublecomplex") == 0)
4231 : : return true;
4232 : : else
4233 : 11770 : return false;
4234 : : }
4235 : :
4236 : :
4237 : : /* Return TRUE if the symbol is an automatic variable. */
4238 : :
4239 : : static bool
4240 : 857 : gfc_is_var_automatic (gfc_symbol *sym)
4241 : : {
4242 : : /* Pointer and allocatable variables are never automatic. */
4243 : 857 : if (sym->attr.pointer || sym->attr.allocatable)
4244 : : return false;
4245 : : /* Check for arrays with non-constant size. */
4246 : 75 : if (sym->attr.dimension && sym->as
4247 : 871 : && !gfc_is_compile_time_shape (sym->as))
4248 : : return true;
4249 : : /* Check for non-constant length character variables. */
4250 : 781 : if (sym->ts.type == BT_CHARACTER
4251 : 82 : && sym->ts.u.cl
4252 : 863 : && !gfc_is_constant_expr (sym->ts.u.cl->length))
4253 : : return true;
4254 : : /* Variables with explicit AUTOMATIC attribute. */
4255 : 773 : if (sym->attr.automatic)
4256 : : return true;
4257 : :
4258 : : return false;
4259 : : }
4260 : :
4261 : : /* Given a symbol, mark it as SAVEd if it is allowed. */
4262 : :
4263 : : static void
4264 : 2734 : save_symbol (gfc_symbol *sym)
4265 : : {
4266 : :
4267 : 2734 : if (sym->attr.use_assoc)
4268 : : return;
4269 : :
4270 : 2390 : if (sym->attr.in_common
4271 : : || sym->attr.in_equivalence
4272 : : || sym->attr.dummy
4273 : 2390 : || sym->attr.result
4274 : 1958 : || sym->attr.flavor != FL_VARIABLE)
4275 : : return;
4276 : : /* Automatic objects are not saved. */
4277 : 857 : if (gfc_is_var_automatic (sym))
4278 : : return;
4279 : 816 : gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
4280 : : }
4281 : :
4282 : :
4283 : : /* Mark those symbols which can be SAVEd as such. */
4284 : :
4285 : : void
4286 : 339 : gfc_save_all (gfc_namespace *ns)
4287 : : {
4288 : 339 : gfc_traverse_ns (ns, save_symbol);
4289 : 339 : }
4290 : :
4291 : :
4292 : : /* Make sure that no changes to symbols are pending. */
4293 : :
4294 : : void
4295 : 5397033 : gfc_enforce_clean_symbol_state(void)
4296 : : {
4297 : 5397033 : enforce_single_undo_checkpoint ();
4298 : 5397033 : gcc_assert (latest_undo_chgset->syms.is_empty ());
4299 : 5397033 : }
4300 : :
4301 : :
4302 : : /************** Global symbol handling ************/
4303 : :
4304 : :
4305 : : /* Search a tree for the global symbol. */
4306 : :
4307 : : gfc_gsymbol *
4308 : 330835 : gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
4309 : : {
4310 : 330835 : int c;
4311 : :
4312 : 330835 : if (symbol == NULL)
4313 : : return NULL;
4314 : :
4315 : 963158 : while (symbol)
4316 : : {
4317 : 781024 : c = strcmp (name, symbol->name);
4318 : 781024 : if (!c)
4319 : 107752 : return symbol;
4320 : :
4321 : 673272 : symbol = (c < 0) ? symbol->left : symbol->right;
4322 : : }
4323 : :
4324 : : return NULL;
4325 : : }
4326 : :
4327 : :
4328 : : /* Case insensitive search a tree for the global symbol. */
4329 : :
4330 : : gfc_gsymbol *
4331 : 20452 : gfc_find_case_gsymbol (gfc_gsymbol *symbol, const char *name)
4332 : : {
4333 : 20452 : int c;
4334 : :
4335 : 20452 : if (symbol == NULL)
4336 : : return NULL;
4337 : :
4338 : 73638 : while (symbol)
4339 : : {
4340 : 61406 : c = strcasecmp (name, symbol->name);
4341 : 61406 : if (!c)
4342 : 7922 : return symbol;
4343 : :
4344 : 53484 : symbol = (c < 0) ? symbol->left : symbol->right;
4345 : : }
4346 : :
4347 : : return NULL;
4348 : : }
4349 : :
4350 : :
4351 : : /* Compare two global symbols. Used for managing the BB tree. */
4352 : :
4353 : : static int
4354 : 115836 : gsym_compare (void *_s1, void *_s2)
4355 : : {
4356 : 115836 : gfc_gsymbol *s1, *s2;
4357 : :
4358 : 115836 : s1 = (gfc_gsymbol *) _s1;
4359 : 115836 : s2 = (gfc_gsymbol *) _s2;
4360 : 115836 : return strcmp (s1->name, s2->name);
4361 : : }
4362 : :
4363 : :
4364 : : /* Get a global symbol, creating it if it doesn't exist. */
4365 : :
4366 : : gfc_gsymbol *
4367 : 95592 : gfc_get_gsymbol (const char *name, bool bind_c)
4368 : : {
4369 : 95592 : gfc_gsymbol *s;
4370 : :
4371 : 95592 : s = gfc_find_gsymbol (gfc_gsym_root, name);
4372 : 95592 : if (s != NULL)
4373 : : return s;
4374 : :
4375 : 71415 : s = XCNEW (gfc_gsymbol);
4376 : 71415 : s->type = GSYM_UNKNOWN;
4377 : 71415 : s->name = gfc_get_string ("%s", name);
4378 : 71415 : s->bind_c = bind_c;
4379 : :
4380 : 71415 : gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
4381 : :
4382 : 71415 : return s;
4383 : : }
4384 : :
4385 : : void
4386 : 0 : gfc_traverse_gsymbol (gfc_gsymbol *gsym,
4387 : : void (*do_something) (gfc_gsymbol *, void *),
4388 : : void *data)
4389 : : {
4390 : 0 : if (gsym->left)
4391 : 0 : gfc_traverse_gsymbol (gsym->left, do_something, data);
4392 : :
4393 : 0 : (*do_something) (gsym, data);
4394 : :
4395 : 0 : if (gsym->right)
4396 : : gfc_traverse_gsymbol (gsym->right, do_something, data);
4397 : 0 : }
4398 : :
4399 : : static gfc_symbol *
4400 : 52 : get_iso_c_binding_dt (int sym_id)
4401 : : {
4402 : 52 : gfc_symbol *dt_list = gfc_derived_types;
4403 : :
4404 : : /* Loop through the derived types in the name list, searching for
4405 : : the desired symbol from iso_c_binding. Search the parent namespaces
4406 : : if necessary and requested to (parent_flag). */
4407 : 52 : if (dt_list)
4408 : : {
4409 : 25 : while (dt_list->dt_next != gfc_derived_types)
4410 : : {
4411 : 0 : if (dt_list->from_intmod != INTMOD_NONE
4412 : 0 : && dt_list->intmod_sym_id == sym_id)
4413 : 0 : return dt_list;
4414 : :
4415 : : dt_list = dt_list->dt_next;
4416 : : }
4417 : : }
4418 : :
4419 : : return NULL;
4420 : : }
4421 : :
4422 : :
4423 : : /* Verifies that the given derived type symbol, derived_sym, is interoperable
4424 : : with C. This is necessary for any derived type that is BIND(C) and for
4425 : : derived types that are parameters to functions that are BIND(C). All
4426 : : fields of the derived type are required to be interoperable, and are tested
4427 : : for such. If an error occurs, the errors are reported here, allowing for
4428 : : multiple errors to be handled for a single derived type. */
4429 : :
4430 : : bool
4431 : 19162 : verify_bind_c_derived_type (gfc_symbol *derived_sym)
4432 : : {
4433 : 19162 : gfc_component *curr_comp = NULL;
4434 : 19162 : bool is_c_interop = false;
4435 : 19162 : bool retval = true;
4436 : :
4437 : 19162 : if (derived_sym == NULL)
4438 : 0 : gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
4439 : : "unexpectedly NULL");
4440 : :
4441 : : /* If we've already looked at this derived symbol, do not look at it again
4442 : : so we don't repeat warnings/errors. */
4443 : 19162 : if (derived_sym->ts.is_c_interop)
4444 : : return true;
4445 : :
4446 : : /* The derived type must have the BIND attribute to be interoperable
4447 : : J3/04-007, Section 15.2.3. */
4448 : 399 : if (derived_sym->attr.is_bind_c != 1)
4449 : : {
4450 : 2 : derived_sym->ts.is_c_interop = 0;
4451 : 2 : gfc_error_now ("Derived type %qs declared at %L must have the BIND "
4452 : : "attribute to be C interoperable", derived_sym->name,
4453 : : &(derived_sym->declared_at));
4454 : 2 : retval = false;
4455 : : }
4456 : :
4457 : 399 : curr_comp = derived_sym->components;
4458 : :
4459 : : /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
4460 : : empty struct. Section 15.2 in Fortran 2003 states: "The following
4461 : : subclauses define the conditions under which a Fortran entity is
4462 : : interoperable. If a Fortran entity is interoperable, an equivalent
4463 : : entity may be defined by means of C and the Fortran entity is said
4464 : : to be interoperable with the C entity. There does not have to be such
4465 : : an interoperating C entity."
4466 : : */
4467 : 399 : if (curr_comp == NULL)
4468 : : {
4469 : 1 : gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
4470 : : "and may be inaccessible by the C companion processor",
4471 : : derived_sym->name, &(derived_sym->declared_at));
4472 : 1 : derived_sym->ts.is_c_interop = 1;
4473 : 1 : derived_sym->attr.is_bind_c = 1;
4474 : 1 : return true;
4475 : : }
4476 : :
4477 : :
4478 : : /* Initialize the derived type as being C interoperable.
4479 : : If we find an error in the components, this will be set false. */
4480 : 398 : derived_sym->ts.is_c_interop = 1;
4481 : :
4482 : : /* Loop through the list of components to verify that the kind of
4483 : : each is a C interoperable type. */
4484 : 835 : do
4485 : : {
4486 : : /* The components cannot be pointers (fortran sense).
4487 : : J3/04-007, Section 15.2.3, C1505. */
4488 : 835 : if (curr_comp->attr.pointer != 0)
4489 : : {
4490 : 3 : gfc_error ("Component %qs at %L cannot have the "
4491 : : "POINTER attribute because it is a member "
4492 : : "of the BIND(C) derived type %qs at %L",
4493 : : curr_comp->name, &(curr_comp->loc),
4494 : : derived_sym->name, &(derived_sym->declared_at));
4495 : 3 : retval = false;
4496 : : }
4497 : :
4498 : 835 : if (curr_comp->attr.proc_pointer != 0)
4499 : : {
4500 : 1 : gfc_error ("Procedure pointer component %qs at %L cannot be a member"
4501 : : " of the BIND(C) derived type %qs at %L", curr_comp->name,
4502 : : &curr_comp->loc, derived_sym->name,
4503 : : &derived_sym->declared_at);
4504 : 1 : retval = false;
4505 : : }
4506 : :
4507 : : /* The components cannot be allocatable.
4508 : : J3/04-007, Section 15.2.3, C1505. */
4509 : 835 : if (curr_comp->attr.allocatable != 0)
4510 : : {
4511 : 3 : gfc_error ("Component %qs at %L cannot have the "
4512 : : "ALLOCATABLE attribute because it is a member "
4513 : : "of the BIND(C) derived type %qs at %L",
4514 : : curr_comp->name, &(curr_comp->loc),
4515 : : derived_sym->name, &(derived_sym->declared_at));
4516 : 3 : retval = false;
4517 : : }
4518 : :
4519 : : /* BIND(C) derived types must have interoperable components. */
4520 : 835 : if (curr_comp->ts.type == BT_DERIVED
4521 : 71 : && curr_comp->ts.u.derived->ts.is_iso_c != 1
4522 : 17 : && curr_comp->ts.u.derived != derived_sym)
4523 : : {
4524 : : /* This should be allowed; the draft says a derived-type cannot
4525 : : have type parameters if it is has the BIND attribute. Type
4526 : : parameters seem to be for making parameterized derived types.
4527 : : There's no need to verify the type if it is c_ptr/c_funptr. */
4528 : 16 : retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
4529 : : }
4530 : : else
4531 : : {
4532 : : /* Grab the typespec for the given component and test the kind. */
4533 : 819 : is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
4534 : :
4535 : 819 : if (!is_c_interop)
4536 : : {
4537 : : /* Report warning and continue since not fatal. The
4538 : : draft does specify a constraint that requires all fields
4539 : : to interoperate, but if the user says real(4), etc., it
4540 : : may interoperate with *something* in C, but the compiler
4541 : : most likely won't know exactly what. Further, it may not
4542 : : interoperate with the same data type(s) in C if the user
4543 : : recompiles with different flags (e.g., -m32 and -m64 on
4544 : : x86_64 and using integer(4) to claim interop with a
4545 : : C_LONG). */
4546 : 16 : if (derived_sym->attr.is_bind_c == 1 && warn_c_binding_type)
4547 : : /* If the derived type is bind(c), all fields must be
4548 : : interop. */
4549 : 1 : gfc_warning (OPT_Wc_binding_type,
4550 : : "Component %qs in derived type %qs at %L "
4551 : : "may not be C interoperable, even though "
4552 : : "derived type %qs is BIND(C)",
4553 : : curr_comp->name, derived_sym->name,
4554 : : &(curr_comp->loc), derived_sym->name);
4555 : 15 : else if (warn_c_binding_type)
4556 : : /* If derived type is param to bind(c) routine, or to one
4557 : : of the iso_c_binding procs, it must be interoperable, so
4558 : : all fields must interop too. */
4559 : 0 : gfc_warning (OPT_Wc_binding_type,
4560 : : "Component %qs in derived type %qs at %L "
4561 : : "may not be C interoperable",
4562 : : curr_comp->name, derived_sym->name,
4563 : : &(curr_comp->loc));
4564 : : }
4565 : : }
4566 : :
4567 : 835 : curr_comp = curr_comp->next;
4568 : 835 : } while (curr_comp != NULL);
4569 : :
4570 : 398 : if (derived_sym->attr.sequence != 0)
4571 : : {
4572 : 0 : gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
4573 : : "attribute because it is BIND(C)", derived_sym->name,
4574 : : &(derived_sym->declared_at));
4575 : 0 : retval = false;
4576 : : }
4577 : :
4578 : : /* Mark the derived type as not being C interoperable if we found an
4579 : : error. If there were only warnings, proceed with the assumption
4580 : : it's interoperable. */
4581 : 398 : if (!retval)
4582 : 8 : derived_sym->ts.is_c_interop = 0;
4583 : :
4584 : : return retval;
4585 : : }
4586 : :
4587 : :
4588 : : /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
4589 : :
4590 : : static bool
4591 : 5782 : gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree)
4592 : : {
4593 : 5782 : gfc_constructor *c;
4594 : :
4595 : 5782 : gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym);
4596 : 5782 : dt_symtree->n.sym->attr.referenced = 1;
4597 : :
4598 : 5782 : tmp_sym->attr.is_c_interop = 1;
4599 : 5782 : tmp_sym->attr.is_bind_c = 1;
4600 : 5782 : tmp_sym->ts.is_c_interop = 1;
4601 : 5782 : tmp_sym->ts.is_iso_c = 1;
4602 : 5782 : tmp_sym->ts.type = BT_DERIVED;
4603 : 5782 : tmp_sym->ts.f90_type = BT_VOID;
4604 : 5782 : tmp_sym->attr.flavor = FL_PARAMETER;
4605 : 5782 : tmp_sym->ts.u.derived = dt_symtree->n.sym;
4606 : :
4607 : : /* Set the c_address field of c_null_ptr and c_null_funptr to
4608 : : the value of NULL. */
4609 : 5782 : tmp_sym->value = gfc_get_expr ();
4610 : 5782 : tmp_sym->value->expr_type = EXPR_STRUCTURE;
4611 : 5782 : tmp_sym->value->ts.type = BT_DERIVED;
4612 : 5782 : tmp_sym->value->ts.f90_type = BT_VOID;
4613 : 5782 : tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
4614 : 5782 : gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
4615 : 5782 : c = gfc_constructor_first (tmp_sym->value->value.constructor);
4616 : 5782 : c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
4617 : 5782 : c->expr->ts.is_iso_c = 1;
4618 : :
4619 : 5782 : return true;
4620 : : }
4621 : :
4622 : :
4623 : : /* Add a formal argument, gfc_formal_arglist, to the
4624 : : end of the given list of arguments. Set the reference to the
4625 : : provided symbol, param_sym, in the argument. */
4626 : :
4627 : : static void
4628 : 66342 : add_formal_arg (gfc_formal_arglist **head,
4629 : : gfc_formal_arglist **tail,
4630 : : gfc_formal_arglist *formal_arg,
4631 : : gfc_symbol *param_sym)
4632 : : {
4633 : : /* Put in list, either as first arg or at the tail (curr arg). */
4634 : 0 : if (*head == NULL)
4635 : 0 : *head = *tail = formal_arg;
4636 : : else
4637 : : {
4638 : 38085 : (*tail)->next = formal_arg;
4639 : 38085 : (*tail) = formal_arg;
4640 : : }
4641 : :
4642 : 66342 : (*tail)->sym = param_sym;
4643 : 66342 : (*tail)->next = NULL;
4644 : :
4645 : 66342 : return;
4646 : : }
4647 : :
4648 : :
4649 : : /* Add a procedure interface to the given symbol (i.e., store a
4650 : : reference to the list of formal arguments). */
4651 : :
4652 : : static void
4653 : 28897 : add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
4654 : : {
4655 : :
4656 : 28897 : sym->formal = formal;
4657 : 28897 : sym->attr.if_source = source;
4658 : 0 : }
4659 : :
4660 : :
4661 : : /* Copy the formal args from an existing symbol, src, into a new
4662 : : symbol, dest. New formal args are created, and the description of
4663 : : each arg is set according to the existing ones. This function is
4664 : : used when creating procedure declaration variables from a procedure
4665 : : declaration statement (see match_proc_decl()) to create the formal
4666 : : args based on the args of a given named interface.
4667 : :
4668 : : When an actual argument list is provided, skip the absent arguments
4669 : : unless copy_type is true.
4670 : : To be used together with gfc_se->ignore_optional. */
4671 : :
4672 : : void
4673 : 28897 : gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
4674 : : gfc_actual_arglist *actual, bool copy_type)
4675 : : {
4676 : 28897 : gfc_formal_arglist *head = NULL;
4677 : 28897 : gfc_formal_arglist *tail = NULL;
4678 : 28897 : gfc_formal_arglist *formal_arg = NULL;
4679 : 28897 : gfc_intrinsic_arg *curr_arg = NULL;
4680 : 28897 : gfc_formal_arglist *formal_prev = NULL;
4681 : 28897 : gfc_actual_arglist *act_arg = actual;
4682 : : /* Save current namespace so we can change it for formal args. */
4683 : 28897 : gfc_namespace *parent_ns = gfc_current_ns;
4684 : :
4685 : : /* Create a new namespace, which will be the formal ns (namespace
4686 : : of the formal args). */
4687 : 28897 : gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4688 : 28897 : gfc_current_ns->proc_name = dest;
4689 : :
4690 : 97180 : for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4691 : : {
4692 : : /* Skip absent arguments. */
4693 : 68283 : if (actual)
4694 : : {
4695 : 10932 : gcc_assert (act_arg != NULL);
4696 : 10932 : if (act_arg->expr == NULL)
4697 : : {
4698 : 1941 : act_arg = act_arg->next;
4699 : 1941 : continue;
4700 : : }
4701 : : }
4702 : 66342 : formal_arg = gfc_get_formal_arglist ();
4703 : 66342 : gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4704 : :
4705 : : /* May need to copy more info for the symbol. */
4706 : 66342 : if (copy_type && act_arg->expr != NULL)
4707 : : {
4708 : 3524 : formal_arg->sym->ts = act_arg->expr->ts;
4709 : 3524 : if (act_arg->expr->rank > 0)
4710 : : {
4711 : 1699 : formal_arg->sym->attr.dimension = 1;
4712 : 1699 : formal_arg->sym->as = gfc_get_array_spec();
4713 : 1699 : formal_arg->sym->as->rank = -1;
4714 : 1699 : formal_arg->sym->as->type = AS_ASSUMED_RANK;
4715 : : }
4716 : 3524 : if (act_arg->name && strcmp (act_arg->name, "%VAL") == 0)
4717 : 790 : formal_arg->sym->pass_as_value = 1;
4718 : : }
4719 : : else
4720 : 62818 : formal_arg->sym->ts = curr_arg->ts;
4721 : :
4722 : 66342 : formal_arg->sym->attr.optional = curr_arg->optional;
4723 : 66342 : formal_arg->sym->attr.value = curr_arg->value;
4724 : 66342 : formal_arg->sym->attr.intent = curr_arg->intent;
4725 : 66342 : formal_arg->sym->attr.flavor = FL_VARIABLE;
4726 : 66342 : formal_arg->sym->attr.dummy = 1;
4727 : :
4728 : : /* Do not treat an actual deferred-length character argument wrongly
4729 : : as template for the formal argument. */
4730 : 66342 : if (formal_arg->sym->ts.type == BT_CHARACTER
4731 : 1287 : && !(formal_arg->sym->attr.allocatable
4732 : : || formal_arg->sym->attr.pointer))
4733 : 1287 : formal_arg->sym->ts.deferred = false;
4734 : :
4735 : 66342 : if (formal_arg->sym->ts.type == BT_CHARACTER)
4736 : 1287 : formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4737 : :
4738 : : /* If this isn't the first arg, set up the next ptr. For the
4739 : : last arg built, the formal_arg->next will never get set to
4740 : : anything other than NULL. */
4741 : 66342 : if (formal_prev != NULL)
4742 : 38085 : formal_prev->next = formal_arg;
4743 : : else
4744 : : formal_arg->next = NULL;
4745 : :
4746 : 66342 : formal_prev = formal_arg;
4747 : :
4748 : : /* Add arg to list of formal args. */
4749 : 66342 : add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4750 : :
4751 : : /* Validate changes. */
4752 : 66342 : gfc_commit_symbol (formal_arg->sym);
4753 : 66342 : if (actual)
4754 : 8991 : act_arg = act_arg->next;
4755 : : }
4756 : :
4757 : : /* Add the interface to the symbol. */
4758 : 28897 : add_proc_interface (dest, IFSRC_DECL, head);
4759 : :
4760 : : /* Store the formal namespace information. */
4761 : 28897 : if (dest->formal != NULL)
4762 : : /* The current ns should be that for the dest proc. */
4763 : 28257 : dest->formal_ns = gfc_current_ns;
4764 : : /* Restore the current namespace to what it was on entry. */
4765 : 28897 : gfc_current_ns = parent_ns;
4766 : 28897 : }
4767 : :
4768 : :
4769 : : static int
4770 : 138345 : std_for_isocbinding_symbol (int id)
4771 : : {
4772 : 138345 : switch (id)
4773 : : {
4774 : : #define NAMED_INTCST(a,b,c,d) \
4775 : : case a:\
4776 : : return d;
4777 : : #include "iso-c-binding.def"
4778 : : #undef NAMED_INTCST
4779 : :
4780 : : #define NAMED_FUNCTION(a,b,c,d) \
4781 : : case a:\
4782 : : return d;
4783 : : #define NAMED_SUBROUTINE(a,b,c,d) \
4784 : : case a:\
4785 : : return d;
4786 : : #include "iso-c-binding.def"
4787 : : #undef NAMED_FUNCTION
4788 : : #undef NAMED_SUBROUTINE
4789 : :
4790 : : default:
4791 : : return GFC_STD_F2003;
4792 : : }
4793 : : }
4794 : :
4795 : : /* Generate the given set of C interoperable kind objects, or all
4796 : : interoperable kinds. This function will only be given kind objects
4797 : : for valid iso_c_binding defined types because this is verified when
4798 : : the 'use' statement is parsed. If the user gives an 'only' clause,
4799 : : the specific kinds are looked up; if they don't exist, an error is
4800 : : reported. If the user does not give an 'only' clause, all
4801 : : iso_c_binding symbols are generated. If a list of specific kinds
4802 : : is given, it must have a NULL in the first empty spot to mark the
4803 : : end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4804 : : point to the symtree for c_(fun)ptr. */
4805 : :
4806 : : gfc_symtree *
4807 : 138345 : generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4808 : : const char *local_name, gfc_symtree *dt_symtree,
4809 : : bool hidden)
4810 : : {
4811 : 6504 : const char *const name = (local_name && local_name[0])
4812 : 138345 : ? local_name : c_interop_kinds_table[s].name;
4813 : 138345 : gfc_symtree *tmp_symtree;
4814 : 138345 : gfc_symbol *tmp_sym = NULL;
4815 : 138345 : int index;
4816 : :
4817 : 138345 : if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4818 : : return NULL;
4819 : :
4820 : 138345 : tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4821 : 138345 : if (hidden
4822 : 46 : && (!tmp_symtree || !tmp_symtree->n.sym
4823 : 14 : || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING
4824 : 14 : || tmp_symtree->n.sym->intmod_sym_id != s))
4825 : 32 : tmp_symtree = NULL;
4826 : :
4827 : : /* Already exists in this scope so don't re-add it. */
4828 : 318 : if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
4829 : 318 : && (!tmp_sym->attr.generic
4830 : 52 : || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
4831 : 138663 : && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
4832 : : {
4833 : 318 : if (tmp_sym->attr.flavor == FL_DERIVED
4834 : 318 : && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
4835 : : {
4836 : 52 : if (gfc_derived_types)
4837 : : {
4838 : 25 : tmp_sym->dt_next = gfc_derived_types->dt_next;
4839 : 25 : gfc_derived_types->dt_next = tmp_sym;
4840 : : }
4841 : : else
4842 : : {
4843 : 27 : tmp_sym->dt_next = tmp_sym;
4844 : : }
4845 : 52 : gfc_derived_types = tmp_sym;
4846 : : }
4847 : :
4848 : 318 : return tmp_symtree;
4849 : : }
4850 : :
4851 : : /* Create the sym tree in the current ns. */
4852 : 138027 : if (hidden)
4853 : : {
4854 : 32 : tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
4855 : 32 : tmp_sym = gfc_new_symbol (name, gfc_current_ns);
4856 : :
4857 : : /* Add to the list of tentative symbols. */
4858 : 32 : latest_undo_chgset->syms.safe_push (tmp_sym);
4859 : 32 : tmp_sym->old_symbol = NULL;
4860 : 32 : tmp_sym->mark = 1;
4861 : 32 : tmp_sym->gfc_new = 1;
4862 : :
4863 : 32 : tmp_symtree->n.sym = tmp_sym;
4864 : 32 : tmp_sym->refs++;
4865 : : }
4866 : : else
4867 : : {
4868 : 137995 : gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4869 : 137995 : gcc_assert (tmp_symtree);
4870 : 137995 : tmp_sym = tmp_symtree->n.sym;
4871 : : }
4872 : :
4873 : : /* Say what module this symbol belongs to. */
4874 : 138027 : tmp_sym->module = gfc_get_string ("%s", mod_name);
4875 : 138027 : tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4876 : 138027 : tmp_sym->intmod_sym_id = s;
4877 : 138027 : tmp_sym->attr.is_iso_c = 1;
4878 : 138027 : tmp_sym->attr.use_assoc = 1;
4879 : :
4880 : 138027 : gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR
4881 : : || s == ISOCBINDING_NULL_PTR);
4882 : :
4883 : 135110 : switch (s)
4884 : : {
4885 : :
4886 : : #define NAMED_INTCST(a,b,c,d) case a :
4887 : : #define NAMED_REALCST(a,b,c,d) case a :
4888 : : #define NAMED_CMPXCST(a,b,c,d) case a :
4889 : : #define NAMED_LOGCST(a,b,c) case a :
4890 : : #define NAMED_CHARKNDCST(a,b,c) case a :
4891 : : #include "iso-c-binding.def"
4892 : :
4893 : 204698 : tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4894 : 102349 : c_interop_kinds_table[s].value);
4895 : :
4896 : : /* Initialize an integer constant expression node. */
4897 : 102349 : tmp_sym->attr.flavor = FL_PARAMETER;
4898 : 102349 : tmp_sym->ts.type = BT_INTEGER;
4899 : 102349 : tmp_sym->ts.kind = gfc_default_integer_kind;
4900 : :
4901 : : /* Mark this type as a C interoperable one. */
4902 : 102349 : tmp_sym->ts.is_c_interop = 1;
4903 : 102349 : tmp_sym->ts.is_iso_c = 1;
4904 : 102349 : tmp_sym->value->ts.is_c_interop = 1;
4905 : 102349 : tmp_sym->value->ts.is_iso_c = 1;
4906 : 102349 : tmp_sym->attr.is_c_interop = 1;
4907 : :
4908 : : /* Tell what f90 type this c interop kind is valid. */
4909 : 102349 : tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4910 : :
4911 : 102349 : break;
4912 : :
4913 : :
4914 : : #define NAMED_CHARCST(a,b,c) case a :
4915 : : #include "iso-c-binding.def"
4916 : :
4917 : : /* Initialize an integer constant expression node for the
4918 : : length of the character. */
4919 : 22920 : tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
4920 : : &gfc_current_locus, NULL, 1);
4921 : 22920 : tmp_sym->value->ts.is_c_interop = 1;
4922 : 22920 : tmp_sym->value->ts.is_iso_c = 1;
4923 : 22920 : tmp_sym->value->value.character.length = 1;
4924 : 22920 : tmp_sym->value->value.character.string[0]
4925 : 22920 : = (gfc_char_t) c_interop_kinds_table[s].value;
4926 : 22920 : tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4927 : 22920 : tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
4928 : : NULL, 1);
4929 : :
4930 : : /* May not need this in both attr and ts, but do need in
4931 : : attr for writing module file. */
4932 : 22920 : tmp_sym->attr.is_c_interop = 1;
4933 : :
4934 : 22920 : tmp_sym->attr.flavor = FL_PARAMETER;
4935 : 22920 : tmp_sym->ts.type = BT_CHARACTER;
4936 : :
4937 : : /* Need to set it to the C_CHAR kind. */
4938 : 22920 : tmp_sym->ts.kind = gfc_default_character_kind;
4939 : :
4940 : : /* Mark this type as a C interoperable one. */
4941 : 22920 : tmp_sym->ts.is_c_interop = 1;
4942 : 22920 : tmp_sym->ts.is_iso_c = 1;
4943 : :
4944 : : /* Tell what f90 type this c interop kind is valid. */
4945 : 22920 : tmp_sym->ts.f90_type = BT_CHARACTER;
4946 : :
4947 : 22920 : break;
4948 : :
4949 : 6976 : case ISOCBINDING_PTR:
4950 : 6976 : case ISOCBINDING_FUNPTR:
4951 : 6976 : {
4952 : 6976 : gfc_symbol *dt_sym;
4953 : 6976 : gfc_component *tmp_comp = NULL;
4954 : :
4955 : : /* Generate real derived type. */
4956 : 6976 : if (hidden)
4957 : : dt_sym = tmp_sym;
4958 : : else
4959 : : {
4960 : 6944 : const char *hidden_name;
4961 : 6944 : gfc_interface *intr, *head;
4962 : :
4963 : 6944 : hidden_name = gfc_dt_upper_string (tmp_sym->name);
4964 : 6944 : tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4965 : : hidden_name);
4966 : 6944 : gcc_assert (tmp_symtree == NULL);
4967 : 6944 : gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
4968 : 6944 : dt_sym = tmp_symtree->n.sym;
4969 : 9896 : dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR
4970 : : ? "c_ptr" : "c_funptr");
4971 : :
4972 : : /* Generate an artificial generic function. */
4973 : 6944 : head = tmp_sym->generic;
4974 : 6944 : intr = gfc_get_interface ();
4975 : 6944 : intr->sym = dt_sym;
4976 : 6944 : intr->where = gfc_current_locus;
4977 : 6944 : intr->next = head;
4978 : 6944 : tmp_sym->generic = intr;
4979 : :
4980 : 6944 : if (!tmp_sym->attr.generic
4981 : 6944 : && !gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL))
4982 : 0 : return NULL;
4983 : :
4984 : 6944 : if (!tmp_sym->attr.function
4985 : 6944 : && !gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL))
4986 : : return NULL;
4987 : : }
4988 : :
4989 : : /* Say what module this symbol belongs to. */
4990 : 6976 : dt_sym->module = gfc_get_string ("%s", mod_name);
4991 : 6976 : dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
4992 : 6976 : dt_sym->intmod_sym_id = s;
4993 : 6976 : dt_sym->attr.use_assoc = 1;
4994 : :
4995 : : /* Initialize an integer constant expression node. */
4996 : 6976 : dt_sym->attr.flavor = FL_DERIVED;
4997 : 6976 : dt_sym->ts.is_c_interop = 1;
4998 : 6976 : dt_sym->attr.is_c_interop = 1;
4999 : 6976 : dt_sym->attr.private_comp = 1;
5000 : 6976 : dt_sym->component_access = ACCESS_PRIVATE;
5001 : 6976 : dt_sym->ts.is_iso_c = 1;
5002 : 6976 : dt_sym->ts.type = BT_DERIVED;
5003 : 6976 : dt_sym->ts.f90_type = BT_VOID;
5004 : :
5005 : : /* A derived type must have the bind attribute to be
5006 : : interoperable (J3/04-007, Section 15.2.3), even though
5007 : : the binding label is not used. */
5008 : 6976 : dt_sym->attr.is_bind_c = 1;
5009 : :
5010 : 6976 : dt_sym->attr.referenced = 1;
5011 : 6976 : dt_sym->ts.u.derived = dt_sym;
5012 : :
5013 : : /* Add the symbol created for the derived type to the current ns. */
5014 : 6976 : if (gfc_derived_types)
5015 : : {
5016 : 5190 : dt_sym->dt_next = gfc_derived_types->dt_next;
5017 : 5190 : gfc_derived_types->dt_next = dt_sym;
5018 : : }
5019 : : else
5020 : : {
5021 : 1786 : dt_sym->dt_next = dt_sym;
5022 : : }
5023 : 6976 : gfc_derived_types = dt_sym;
5024 : :
5025 : 6976 : gfc_add_component (dt_sym, "c_address", &tmp_comp);
5026 : 6976 : if (tmp_comp == NULL)
5027 : 0 : gcc_unreachable ();
5028 : :
5029 : 6976 : tmp_comp->ts.type = BT_INTEGER;
5030 : :
5031 : : /* Set this because the module will need to read/write this field. */
5032 : 6976 : tmp_comp->ts.f90_type = BT_INTEGER;
5033 : :
5034 : : /* The kinds for c_ptr and c_funptr are the same. */
5035 : 6976 : index = get_c_kind ("c_ptr", c_interop_kinds_table);
5036 : 6976 : tmp_comp->ts.kind = c_interop_kinds_table[index].value;
5037 : 6976 : tmp_comp->attr.access = ACCESS_PRIVATE;
5038 : :
5039 : : /* Mark the component as C interoperable. */
5040 : 6976 : tmp_comp->ts.is_c_interop = 1;
5041 : : }
5042 : :
5043 : 6976 : break;
5044 : :
5045 : 5782 : case ISOCBINDING_NULL_PTR:
5046 : 5782 : case ISOCBINDING_NULL_FUNPTR:
5047 : 5782 : gen_special_c_interop_ptr (tmp_sym, dt_symtree);
5048 : 5782 : break;
5049 : :
5050 : 0 : default:
5051 : 0 : gcc_unreachable ();
5052 : : }
5053 : 138027 : gfc_commit_symbol (tmp_sym);
5054 : 138027 : return tmp_symtree;
5055 : : }
5056 : :
5057 : :
5058 : : /* Check that a symbol is already typed. If strict is not set, an untyped
5059 : : symbol is acceptable for non-standard-conforming mode. */
5060 : :
5061 : : bool
5062 : 13214 : gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
5063 : : bool strict, locus where)
5064 : : {
5065 : 13214 : gcc_assert (sym);
5066 : :
5067 : 13214 : if (gfc_matching_prefix)
5068 : : return true;
5069 : :
5070 : : /* Check for the type and try to give it an implicit one. */
5071 : 13175 : if (sym->ts.type == BT_UNKNOWN
5072 : 13175 : && !gfc_set_default_type (sym, 0, ns))
5073 : : {
5074 : 439 : if (strict)
5075 : : {
5076 : 11 : gfc_error ("Symbol %qs is used before it is typed at %L",
5077 : : sym->name, &where);
5078 : 11 : return false;
5079 : : }
5080 : :
5081 : 428 : if (!gfc_notify_std (GFC_STD_GNU, "Symbol %qs is used before"
5082 : : " it is typed at %L", sym->name, &where))
5083 : : return false;
5084 : : }
5085 : :
5086 : : /* Everything is ok. */
5087 : : return true;
5088 : : }
5089 : :
5090 : :
5091 : : /* Construct a typebound-procedure structure. Those are stored in a tentative
5092 : : list and marked `error' until symbols are committed. */
5093 : :
5094 : : gfc_typebound_proc*
5095 : 50101 : gfc_get_typebound_proc (gfc_typebound_proc *tb0)
5096 : : {
5097 : 50101 : gfc_typebound_proc *result;
5098 : :
5099 : 50101 : result = XCNEW (gfc_typebound_proc);
5100 : 50101 : if (tb0)
5101 : 2769 : *result = *tb0;
5102 : 50101 : result->error = 1;
5103 : :
5104 : 50101 : latest_undo_chgset->tbps.safe_push (result);
5105 : :
5106 : 50101 : return result;
5107 : : }
5108 : :
5109 : :
5110 : : /* Get the super-type of a given derived type. */
5111 : :
5112 : : gfc_symbol*
5113 : 683376 : gfc_get_derived_super_type (gfc_symbol* derived)
5114 : : {
5115 : 683376 : gcc_assert (derived);
5116 : :
5117 : 683376 : if (derived->attr.generic)
5118 : 2 : derived = gfc_find_dt_in_generic (derived);
5119 : :
5120 : 683376 : if (!derived->attr.extension)
5121 : : return NULL;
5122 : :
5123 : 105523 : gcc_assert (derived->components);
5124 : 105523 : gcc_assert (derived->components->ts.type == BT_DERIVED);
5125 : 105523 : gcc_assert (derived->components->ts.u.derived);
5126 : :
5127 : 105523 : if (derived->components->ts.u.derived->attr.generic)
5128 : 0 : return gfc_find_dt_in_generic (derived->components->ts.u.derived);
5129 : :
5130 : : return derived->components->ts.u.derived;
5131 : : }
5132 : :
5133 : :
5134 : : /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
5135 : :
5136 : : bool
5137 : 25978 : gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
5138 : : {
5139 : 29744 : while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
5140 : 3766 : t2 = gfc_get_derived_super_type (t2);
5141 : 25978 : return gfc_compare_derived_types (t1, t2);
5142 : : }
5143 : :
5144 : :
5145 : : /* Check if two typespecs are type compatible (F03:5.1.1.2):
5146 : : If ts1 is nonpolymorphic, ts2 must be the same type.
5147 : : If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
5148 : :
5149 : : bool
5150 : 237235 : gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
5151 : : {
5152 : 237235 : bool is_class1 = (ts1->type == BT_CLASS);
5153 : 237235 : bool is_class2 = (ts2->type == BT_CLASS);
5154 : 237235 : bool is_derived1 = (ts1->type == BT_DERIVED);
5155 : 237235 : bool is_derived2 = (ts2->type == BT_DERIVED);
5156 : 237235 : bool is_union1 = (ts1->type == BT_UNION);
5157 : 237235 : bool is_union2 = (ts2->type == BT_UNION);
5158 : :
5159 : : /* A boz-literal-constant has no type. */
5160 : 237235 : if (ts1->type == BT_BOZ || ts2->type == BT_BOZ)
5161 : : return false;
5162 : :
5163 : 237233 : if (is_class1
5164 : 24649 : && ts1->u.derived->components
5165 : 24489 : && ((ts1->u.derived->attr.is_class
5166 : 24482 : && ts1->u.derived->components->ts.u.derived->attr
5167 : 24482 : .unlimited_polymorphic)
5168 : 23780 : || ts1->u.derived->attr.unlimited_polymorphic))
5169 : : return 1;
5170 : :
5171 : 236524 : if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2
5172 : 1669 : && !is_union1 && !is_union2)
5173 : 1669 : return (ts1->type == ts2->type);
5174 : :
5175 : 234855 : if ((is_derived1 && is_derived2) || (is_union1 && is_union2))
5176 : 209953 : return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
5177 : :
5178 : 24902 : if (is_derived1 && is_class2)
5179 : 958 : return gfc_compare_derived_types (ts1->u.derived,
5180 : 958 : ts2->u.derived->attr.is_class ?
5181 : 955 : ts2->u.derived->components->ts.u.derived
5182 : 958 : : ts2->u.derived);
5183 : 23944 : if (is_class1 && is_derived2)
5184 : 16473 : return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ?
5185 : 8236 : ts1->u.derived->components->ts.u.derived
5186 : : : ts1->u.derived,
5187 : 8237 : ts2->u.derived);
5188 : 15707 : else if (is_class1 && is_class2)
5189 : 31240 : return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ?
5190 : 15537 : ts1->u.derived->components->ts.u.derived
5191 : : : ts1->u.derived,
5192 : 15703 : ts2->u.derived->attr.is_class ?
5193 : 15538 : ts2->u.derived->components->ts.u.derived
5194 : 15703 : : ts2->u.derived);
5195 : : else
5196 : : return 0;
5197 : : }
5198 : :
5199 : :
5200 : : /* Find the parent-namespace of the current function. If we're inside
5201 : : BLOCK constructs, it may not be the current one. */
5202 : :
5203 : : gfc_namespace*
5204 : 55194 : gfc_find_proc_namespace (gfc_namespace* ns)
5205 : : {
5206 : 55736 : while (ns->construct_entities)
5207 : : {
5208 : 542 : ns = ns->parent;
5209 : 542 : gcc_assert (ns);
5210 : : }
5211 : :
5212 : 55194 : return ns;
5213 : : }
5214 : :
5215 : :
5216 : : /* Check if an associate-variable should be translated as an `implicit' pointer
5217 : : internally (if it is associated to a variable and not an array with
5218 : : descriptor). */
5219 : :
5220 : : bool
5221 : 413570 : gfc_is_associate_pointer (gfc_symbol* sym)
5222 : : {
5223 : 413570 : if (!sym->assoc)
5224 : : return false;
5225 : :
5226 : 9740 : if (sym->ts.type == BT_CLASS)
5227 : : return true;
5228 : :
5229 : 5603 : if (sym->ts.type == BT_CHARACTER
5230 : 1078 : && sym->ts.deferred
5231 : 56 : && sym->assoc->target
5232 : 56 : && sym->assoc->target->expr_type == EXPR_FUNCTION)
5233 : : return true;
5234 : :
5235 : 5597 : if (!sym->assoc->variable)
5236 : : return false;
5237 : :
5238 : 5147 : if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
5239 : 0 : return false;
5240 : :
5241 : : return true;
5242 : : }
5243 : :
5244 : :
5245 : : gfc_symbol *
5246 : 28974 : gfc_find_dt_in_generic (gfc_symbol *sym)
5247 : : {
5248 : 28974 : gfc_interface *intr = NULL;
5249 : :
5250 : 28974 : if (!sym || gfc_fl_struct (sym->attr.flavor))
5251 : : return sym;
5252 : :
5253 : 28974 : if (sym->attr.generic)
5254 : 30483 : for (intr = sym->generic; intr; intr = intr->next)
5255 : 19201 : if (gfc_fl_struct (intr->sym->attr.flavor))
5256 : : break;
5257 : 28972 : return intr ? intr->sym : NULL;
5258 : : }
5259 : :
5260 : :
5261 : : /* Get the dummy arguments from a procedure symbol. If it has been declared
5262 : : via a PROCEDURE statement with a named interface, ts.interface will be set
5263 : : and the arguments need to be taken from there. */
5264 : :
5265 : : gfc_formal_arglist *
5266 : 3124260 : gfc_sym_get_dummy_args (gfc_symbol *sym)
5267 : : {
5268 : 3124260 : gfc_formal_arglist *dummies;
5269 : :
5270 : 3124260 : if (sym == NULL)
5271 : : return NULL;
5272 : :
5273 : 3124259 : dummies = sym->formal;
5274 : 3124259 : if (dummies == NULL && sym->ts.interface != NULL)
5275 : 6113 : dummies = sym->ts.interface->formal;
5276 : :
5277 : : return dummies;
5278 : : }
|
