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