Reverting merge from trunk
[official-gcc.git] / gcc / fortran / symbol.c
blob9d23e8b48a3f8ada857fbbd19a4f5ed7aa6a619d
1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
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.
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.
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/>. */
22 #include "config.h"
23 #include "system.h"
24 #include "coretypes.h"
25 #include "flags.h"
26 #include "gfortran.h"
27 #include "parse.h"
28 #include "match.h"
29 #include "constructor.h"
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. */
36 const mstring flavors[] =
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 (NULL, -1)
46 const mstring procedures[] =
48 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
49 minit ("MODULE-PROC", PROC_MODULE),
50 minit ("INTERNAL-PROC", PROC_INTERNAL),
51 minit ("DUMMY-PROC", PROC_DUMMY),
52 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
53 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
54 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
55 minit (NULL, -1)
58 const mstring intents[] =
60 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
61 minit ("IN", INTENT_IN),
62 minit ("OUT", INTENT_OUT),
63 minit ("INOUT", INTENT_INOUT),
64 minit (NULL, -1)
67 const mstring access_types[] =
69 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
70 minit ("PUBLIC", ACCESS_PUBLIC),
71 minit ("PRIVATE", ACCESS_PRIVATE),
72 minit (NULL, -1)
75 const mstring ifsrc_types[] =
77 minit ("UNKNOWN", IFSRC_UNKNOWN),
78 minit ("DECL", IFSRC_DECL),
79 minit ("BODY", IFSRC_IFBODY)
82 const mstring save_status[] =
84 minit ("UNKNOWN", SAVE_NONE),
85 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
86 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
89 /* This is to make sure the backend generates setup code in the correct
90 order. */
92 static int next_dummy_order = 1;
95 gfc_namespace *gfc_current_ns;
96 gfc_namespace *gfc_global_ns_list;
98 gfc_gsymbol *gfc_gsym_root = NULL;
100 gfc_dt_list *gfc_derived_types;
102 static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL };
103 static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
106 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
108 /* The following static variable indicates whether a particular element has
109 been explicitly set or not. */
111 static int new_flag[GFC_LETTERS];
114 /* Handle a correctly parsed IMPLICIT NONE. */
116 void
117 gfc_set_implicit_none (void)
119 int i;
121 if (gfc_current_ns->seen_implicit_none)
123 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
124 return;
127 gfc_current_ns->seen_implicit_none = 1;
129 for (i = 0; i < GFC_LETTERS; i++)
131 gfc_clear_ts (&gfc_current_ns->default_type[i]);
132 gfc_current_ns->set_flag[i] = 1;
137 /* Reset the implicit range flags. */
139 void
140 gfc_clear_new_implicit (void)
142 int i;
144 for (i = 0; i < GFC_LETTERS; i++)
145 new_flag[i] = 0;
149 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
151 bool
152 gfc_add_new_implicit_range (int c1, int c2)
154 int i;
156 c1 -= 'a';
157 c2 -= 'a';
159 for (i = c1; i <= c2; i++)
161 if (new_flag[i])
163 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
164 i + 'A');
165 return false;
168 new_flag[i] = 1;
171 return true;
175 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
176 the new implicit types back into the existing types will work. */
178 bool
179 gfc_merge_new_implicit (gfc_typespec *ts)
181 int i;
183 if (gfc_current_ns->seen_implicit_none)
185 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
186 return false;
189 for (i = 0; i < GFC_LETTERS; i++)
191 if (new_flag[i])
193 if (gfc_current_ns->set_flag[i])
195 gfc_error ("Letter %c already has an IMPLICIT type at %C",
196 i + 'A');
197 return false;
200 gfc_current_ns->default_type[i] = *ts;
201 gfc_current_ns->implicit_loc[i] = gfc_current_locus;
202 gfc_current_ns->set_flag[i] = 1;
205 return true;
209 /* Given a symbol, return a pointer to the typespec for its default type. */
211 gfc_typespec *
212 gfc_get_default_type (const char *name, gfc_namespace *ns)
214 char letter;
216 letter = name[0];
218 if (gfc_option.flag_allow_leading_underscore && letter == '_')
219 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
220 "gfortran developers, and should not be used for "
221 "implicitly typed variables");
223 if (letter < 'a' || letter > 'z')
224 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
226 if (ns == NULL)
227 ns = gfc_current_ns;
229 return &ns->default_type[letter - 'a'];
233 /* Given a pointer to a symbol, set its type according to the first
234 letter of its name. Fails if the letter in question has no default
235 type. */
237 bool
238 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
240 gfc_typespec *ts;
242 if (sym->ts.type != BT_UNKNOWN)
243 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
245 ts = gfc_get_default_type (sym->name, ns);
247 if (ts->type == BT_UNKNOWN)
249 if (error_flag && !sym->attr.untyped)
251 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
252 sym->name, &sym->declared_at);
253 sym->attr.untyped = 1; /* Ensure we only give an error once. */
256 return false;
259 sym->ts = *ts;
260 sym->attr.implicit_type = 1;
262 if (ts->type == BT_CHARACTER && ts->u.cl)
263 sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
264 else if (ts->type == BT_CLASS
265 && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false))
266 return false;
268 if (sym->attr.is_bind_c == 1 && gfc_option.warn_c_binding_type)
270 /* BIND(C) variables should not be implicitly declared. */
271 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
272 "not be C interoperable", sym->name, &sym->declared_at);
273 sym->ts.f90_type = sym->ts.type;
276 if (sym->attr.dummy != 0)
278 if (sym->ns->proc_name != NULL
279 && (sym->ns->proc_name->attr.subroutine != 0
280 || sym->ns->proc_name->attr.function != 0)
281 && sym->ns->proc_name->attr.is_bind_c != 0
282 && gfc_option.warn_c_binding_type)
284 /* Dummy args to a BIND(C) routine may not be interoperable if
285 they are implicitly typed. */
286 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
287 "be C interoperable but it is a dummy argument to "
288 "the BIND(C) procedure '%s' at %L", sym->name,
289 &(sym->declared_at), sym->ns->proc_name->name,
290 &(sym->ns->proc_name->declared_at));
291 sym->ts.f90_type = sym->ts.type;
295 return true;
299 /* This function is called from parse.c(parse_progunit) to check the
300 type of the function is not implicitly typed in the host namespace
301 and to implicitly type the function result, if necessary. */
303 void
304 gfc_check_function_type (gfc_namespace *ns)
306 gfc_symbol *proc = ns->proc_name;
308 if (!proc->attr.contained || proc->result->attr.implicit_type)
309 return;
311 if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
313 if (gfc_set_default_type (proc->result, 0, gfc_current_ns))
315 if (proc->result != proc)
317 proc->ts = proc->result->ts;
318 proc->as = gfc_copy_array_spec (proc->result->as);
319 proc->attr.dimension = proc->result->attr.dimension;
320 proc->attr.pointer = proc->result->attr.pointer;
321 proc->attr.allocatable = proc->result->attr.allocatable;
324 else if (!proc->result->attr.proc_pointer)
326 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
327 proc->result->name, &proc->result->declared_at);
328 proc->result->attr.untyped = 1;
334 /******************** Symbol attribute stuff *********************/
336 /* This is a generic conflict-checker. We do this to avoid having a
337 single conflict in two places. */
339 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
340 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
341 #define conf_std(a, b, std) if (attr->a && attr->b)\
343 a1 = a;\
344 a2 = b;\
345 standard = std;\
346 goto conflict_std;\
349 static bool
350 check_conflict (symbol_attribute *attr, const char *name, locus *where)
352 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
353 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
354 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
355 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
356 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
357 *privat = "PRIVATE", *recursive = "RECURSIVE",
358 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
359 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
360 *function = "FUNCTION", *subroutine = "SUBROUTINE",
361 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
362 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
363 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
364 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
365 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
366 *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
367 *contiguous = "CONTIGUOUS", *generic = "GENERIC";
368 static const char *threadprivate = "THREADPRIVATE";
370 const char *a1, *a2;
371 int standard;
373 if (where == NULL)
374 where = &gfc_current_locus;
376 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
378 a1 = pointer;
379 a2 = intent;
380 standard = GFC_STD_F2003;
381 goto conflict_std;
384 if (attr->in_namelist && (attr->allocatable || attr->pointer))
386 a1 = in_namelist;
387 a2 = attr->allocatable ? allocatable : pointer;
388 standard = GFC_STD_F2003;
389 goto conflict_std;
392 /* Check for attributes not allowed in a BLOCK DATA. */
393 if (gfc_current_state () == COMP_BLOCK_DATA)
395 a1 = NULL;
397 if (attr->in_namelist)
398 a1 = in_namelist;
399 if (attr->allocatable)
400 a1 = allocatable;
401 if (attr->external)
402 a1 = external;
403 if (attr->optional)
404 a1 = optional;
405 if (attr->access == ACCESS_PRIVATE)
406 a1 = privat;
407 if (attr->access == ACCESS_PUBLIC)
408 a1 = publik;
409 if (attr->intent != INTENT_UNKNOWN)
410 a1 = intent;
412 if (a1 != NULL)
414 gfc_error
415 ("%s attribute not allowed in BLOCK DATA program unit at %L",
416 a1, where);
417 return false;
421 if (attr->save == SAVE_EXPLICIT)
423 conf (dummy, save);
424 conf (in_common, save);
425 conf (result, save);
427 switch (attr->flavor)
429 case FL_PROGRAM:
430 case FL_BLOCK_DATA:
431 case FL_MODULE:
432 case FL_LABEL:
433 case FL_DERIVED:
434 case FL_PARAMETER:
435 a1 = gfc_code2string (flavors, attr->flavor);
436 a2 = save;
437 goto conflict;
438 case FL_NAMELIST:
439 gfc_error ("Namelist group name at %L cannot have the "
440 "SAVE attribute", where);
441 return false;
442 break;
443 case FL_PROCEDURE:
444 /* Conflicts between SAVE and PROCEDURE will be checked at
445 resolution stage, see "resolve_fl_procedure". */
446 case FL_VARIABLE:
447 default:
448 break;
452 conf (dummy, entry);
453 conf (dummy, intrinsic);
454 conf (dummy, threadprivate);
455 conf (pointer, target);
456 conf (pointer, intrinsic);
457 conf (pointer, elemental);
458 conf (allocatable, elemental);
460 conf (target, external);
461 conf (target, intrinsic);
463 if (!attr->if_source)
464 conf (external, dimension); /* See Fortran 95's R504. */
466 conf (external, intrinsic);
467 conf (entry, intrinsic);
469 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
470 conf (external, subroutine);
472 if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003,
473 "Procedure pointer at %C"))
474 return false;
476 conf (allocatable, pointer);
477 conf_std (allocatable, dummy, GFC_STD_F2003);
478 conf_std (allocatable, function, GFC_STD_F2003);
479 conf_std (allocatable, result, GFC_STD_F2003);
480 conf (elemental, recursive);
482 conf (in_common, dummy);
483 conf (in_common, allocatable);
484 conf (in_common, codimension);
485 conf (in_common, result);
487 conf (in_equivalence, use_assoc);
488 conf (in_equivalence, codimension);
489 conf (in_equivalence, dummy);
490 conf (in_equivalence, target);
491 conf (in_equivalence, pointer);
492 conf (in_equivalence, function);
493 conf (in_equivalence, result);
494 conf (in_equivalence, entry);
495 conf (in_equivalence, allocatable);
496 conf (in_equivalence, threadprivate);
498 conf (dummy, result);
499 conf (entry, result);
500 conf (generic, result);
502 conf (function, subroutine);
504 if (!function && !subroutine)
505 conf (is_bind_c, dummy);
507 conf (is_bind_c, cray_pointer);
508 conf (is_bind_c, cray_pointee);
509 conf (is_bind_c, codimension);
510 conf (is_bind_c, allocatable);
511 conf (is_bind_c, elemental);
513 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
514 Parameter conflict caught below. Also, value cannot be specified
515 for a dummy procedure. */
517 /* Cray pointer/pointee conflicts. */
518 conf (cray_pointer, cray_pointee);
519 conf (cray_pointer, dimension);
520 conf (cray_pointer, codimension);
521 conf (cray_pointer, contiguous);
522 conf (cray_pointer, pointer);
523 conf (cray_pointer, target);
524 conf (cray_pointer, allocatable);
525 conf (cray_pointer, external);
526 conf (cray_pointer, intrinsic);
527 conf (cray_pointer, in_namelist);
528 conf (cray_pointer, function);
529 conf (cray_pointer, subroutine);
530 conf (cray_pointer, entry);
532 conf (cray_pointee, allocatable);
533 conf (cray_pointer, contiguous);
534 conf (cray_pointer, codimension);
535 conf (cray_pointee, intent);
536 conf (cray_pointee, optional);
537 conf (cray_pointee, dummy);
538 conf (cray_pointee, target);
539 conf (cray_pointee, intrinsic);
540 conf (cray_pointee, pointer);
541 conf (cray_pointee, entry);
542 conf (cray_pointee, in_common);
543 conf (cray_pointee, in_equivalence);
544 conf (cray_pointee, threadprivate);
546 conf (data, dummy);
547 conf (data, function);
548 conf (data, result);
549 conf (data, allocatable);
551 conf (value, pointer)
552 conf (value, allocatable)
553 conf (value, subroutine)
554 conf (value, function)
555 conf (value, volatile_)
556 conf (value, dimension)
557 conf (value, codimension)
558 conf (value, external)
560 conf (codimension, result)
562 if (attr->value
563 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
565 a1 = value;
566 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
567 goto conflict;
570 conf (is_protected, intrinsic)
571 conf (is_protected, in_common)
573 conf (asynchronous, intrinsic)
574 conf (asynchronous, external)
576 conf (volatile_, intrinsic)
577 conf (volatile_, external)
579 if (attr->volatile_ && attr->intent == INTENT_IN)
581 a1 = volatile_;
582 a2 = intent_in;
583 goto conflict;
586 conf (procedure, allocatable)
587 conf (procedure, dimension)
588 conf (procedure, codimension)
589 conf (procedure, intrinsic)
590 conf (procedure, target)
591 conf (procedure, value)
592 conf (procedure, volatile_)
593 conf (procedure, asynchronous)
594 conf (procedure, entry)
596 a1 = gfc_code2string (flavors, attr->flavor);
598 if (attr->in_namelist
599 && attr->flavor != FL_VARIABLE
600 && attr->flavor != FL_PROCEDURE
601 && attr->flavor != FL_UNKNOWN)
603 a2 = in_namelist;
604 goto conflict;
607 switch (attr->flavor)
609 case FL_PROGRAM:
610 case FL_BLOCK_DATA:
611 case FL_MODULE:
612 case FL_LABEL:
613 conf2 (codimension);
614 conf2 (dimension);
615 conf2 (dummy);
616 conf2 (volatile_);
617 conf2 (asynchronous);
618 conf2 (contiguous);
619 conf2 (pointer);
620 conf2 (is_protected);
621 conf2 (target);
622 conf2 (external);
623 conf2 (intrinsic);
624 conf2 (allocatable);
625 conf2 (result);
626 conf2 (in_namelist);
627 conf2 (optional);
628 conf2 (function);
629 conf2 (subroutine);
630 conf2 (threadprivate);
632 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
634 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
635 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
636 name, where);
637 return false;
640 if (attr->is_bind_c)
642 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
643 return false;
646 break;
648 case FL_VARIABLE:
649 break;
651 case FL_NAMELIST:
652 conf2 (result);
653 break;
655 case FL_PROCEDURE:
656 /* Conflicts with INTENT, SAVE and RESULT will be checked
657 at resolution stage, see "resolve_fl_procedure". */
659 if (attr->subroutine)
661 a1 = subroutine;
662 conf2 (target);
663 conf2 (allocatable);
664 conf2 (volatile_);
665 conf2 (asynchronous);
666 conf2 (in_namelist);
667 conf2 (codimension);
668 conf2 (dimension);
669 conf2 (function);
670 if (!attr->proc_pointer)
671 conf2 (threadprivate);
674 if (!attr->proc_pointer)
675 conf2 (in_common);
677 switch (attr->proc)
679 case PROC_ST_FUNCTION:
680 conf2 (dummy);
681 conf2 (target);
682 break;
684 case PROC_MODULE:
685 conf2 (dummy);
686 break;
688 case PROC_DUMMY:
689 conf2 (result);
690 conf2 (threadprivate);
691 break;
693 default:
694 break;
697 break;
699 case FL_DERIVED:
700 conf2 (dummy);
701 conf2 (pointer);
702 conf2 (target);
703 conf2 (external);
704 conf2 (intrinsic);
705 conf2 (allocatable);
706 conf2 (optional);
707 conf2 (entry);
708 conf2 (function);
709 conf2 (subroutine);
710 conf2 (threadprivate);
711 conf2 (result);
713 if (attr->intent != INTENT_UNKNOWN)
715 a2 = intent;
716 goto conflict;
718 break;
720 case FL_PARAMETER:
721 conf2 (external);
722 conf2 (intrinsic);
723 conf2 (optional);
724 conf2 (allocatable);
725 conf2 (function);
726 conf2 (subroutine);
727 conf2 (entry);
728 conf2 (contiguous);
729 conf2 (pointer);
730 conf2 (is_protected);
731 conf2 (target);
732 conf2 (dummy);
733 conf2 (in_common);
734 conf2 (value);
735 conf2 (volatile_);
736 conf2 (asynchronous);
737 conf2 (threadprivate);
738 conf2 (value);
739 conf2 (codimension);
740 conf2 (result);
741 if (!attr->is_iso_c)
742 conf2 (is_bind_c);
743 break;
745 default:
746 break;
749 return true;
751 conflict:
752 if (name == NULL)
753 gfc_error ("%s attribute conflicts with %s attribute at %L",
754 a1, a2, where);
755 else
756 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
757 a1, a2, name, where);
759 return false;
761 conflict_std:
762 if (name == NULL)
764 return gfc_notify_std (standard, "%s attribute "
765 "with %s attribute at %L", a1, a2,
766 where);
768 else
770 return gfc_notify_std (standard, "%s attribute "
771 "with %s attribute in '%s' at %L",
772 a1, a2, name, where);
776 #undef conf
777 #undef conf2
778 #undef conf_std
781 /* Mark a symbol as referenced. */
783 void
784 gfc_set_sym_referenced (gfc_symbol *sym)
787 if (sym->attr.referenced)
788 return;
790 sym->attr.referenced = 1;
792 /* Remember which order dummy variables are accessed in. */
793 if (sym->attr.dummy)
794 sym->dummy_order = next_dummy_order++;
798 /* Common subroutine called by attribute changing subroutines in order
799 to prevent them from changing a symbol that has been
800 use-associated. Returns zero if it is OK to change the symbol,
801 nonzero if not. */
803 static int
804 check_used (symbol_attribute *attr, const char *name, locus *where)
807 if (attr->use_assoc == 0)
808 return 0;
810 if (where == NULL)
811 where = &gfc_current_locus;
813 if (name == NULL)
814 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
815 where);
816 else
817 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
818 name, where);
820 return 1;
824 /* Generate an error because of a duplicate attribute. */
826 static void
827 duplicate_attr (const char *attr, locus *where)
830 if (where == NULL)
831 where = &gfc_current_locus;
833 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
837 bool
838 gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
839 locus *where ATTRIBUTE_UNUSED)
841 attr->ext_attr |= 1 << ext_attr;
842 return true;
846 /* Called from decl.c (attr_decl1) to check attributes, when declared
847 separately. */
849 bool
850 gfc_add_attribute (symbol_attribute *attr, locus *where)
852 if (check_used (attr, NULL, where))
853 return false;
855 return check_conflict (attr, NULL, where);
859 bool
860 gfc_add_allocatable (symbol_attribute *attr, locus *where)
863 if (check_used (attr, NULL, where))
864 return false;
866 if (attr->allocatable)
868 duplicate_attr ("ALLOCATABLE", where);
869 return false;
872 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
873 && !gfc_find_state (COMP_INTERFACE))
875 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
876 where);
877 return false;
880 attr->allocatable = 1;
881 return check_conflict (attr, NULL, where);
885 bool
886 gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
889 if (check_used (attr, name, where))
890 return false;
892 if (attr->codimension)
894 duplicate_attr ("CODIMENSION", where);
895 return false;
898 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
899 && !gfc_find_state (COMP_INTERFACE))
901 gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
902 "at %L", name, where);
903 return false;
906 attr->codimension = 1;
907 return check_conflict (attr, name, where);
911 bool
912 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
915 if (check_used (attr, name, where))
916 return false;
918 if (attr->dimension)
920 duplicate_attr ("DIMENSION", where);
921 return false;
924 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
925 && !gfc_find_state (COMP_INTERFACE))
927 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
928 "at %L", name, where);
929 return false;
932 attr->dimension = 1;
933 return check_conflict (attr, name, where);
937 bool
938 gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
941 if (check_used (attr, name, where))
942 return false;
944 attr->contiguous = 1;
945 return check_conflict (attr, name, where);
949 bool
950 gfc_add_external (symbol_attribute *attr, locus *where)
953 if (check_used (attr, NULL, where))
954 return false;
956 if (attr->external)
958 duplicate_attr ("EXTERNAL", where);
959 return false;
962 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
964 attr->pointer = 0;
965 attr->proc_pointer = 1;
968 attr->external = 1;
970 return check_conflict (attr, NULL, where);
974 bool
975 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
978 if (check_used (attr, NULL, where))
979 return false;
981 if (attr->intrinsic)
983 duplicate_attr ("INTRINSIC", where);
984 return false;
987 attr->intrinsic = 1;
989 return check_conflict (attr, NULL, where);
993 bool
994 gfc_add_optional (symbol_attribute *attr, locus *where)
997 if (check_used (attr, NULL, where))
998 return false;
1000 if (attr->optional)
1002 duplicate_attr ("OPTIONAL", where);
1003 return false;
1006 attr->optional = 1;
1007 return check_conflict (attr, NULL, where);
1011 bool
1012 gfc_add_pointer (symbol_attribute *attr, locus *where)
1015 if (check_used (attr, NULL, where))
1016 return false;
1018 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
1019 && !gfc_find_state (COMP_INTERFACE)))
1021 duplicate_attr ("POINTER", where);
1022 return false;
1025 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
1026 || (attr->if_source == IFSRC_IFBODY
1027 && !gfc_find_state (COMP_INTERFACE)))
1028 attr->proc_pointer = 1;
1029 else
1030 attr->pointer = 1;
1032 return check_conflict (attr, NULL, where);
1036 bool
1037 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
1040 if (check_used (attr, NULL, where))
1041 return false;
1043 attr->cray_pointer = 1;
1044 return check_conflict (attr, NULL, where);
1048 bool
1049 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
1052 if (check_used (attr, NULL, where))
1053 return false;
1055 if (attr->cray_pointee)
1057 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1058 " statements", where);
1059 return false;
1062 attr->cray_pointee = 1;
1063 return check_conflict (attr, NULL, where);
1067 bool
1068 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1070 if (check_used (attr, name, where))
1071 return false;
1073 if (attr->is_protected)
1075 if (!gfc_notify_std (GFC_STD_LEGACY,
1076 "Duplicate PROTECTED attribute specified at %L",
1077 where))
1078 return false;
1081 attr->is_protected = 1;
1082 return check_conflict (attr, name, where);
1086 bool
1087 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1090 if (check_used (attr, name, where))
1091 return false;
1093 attr->result = 1;
1094 return check_conflict (attr, name, where);
1098 bool
1099 gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
1100 locus *where)
1103 if (check_used (attr, name, where))
1104 return false;
1106 if (s == SAVE_EXPLICIT && gfc_pure (NULL))
1108 gfc_error
1109 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1110 where);
1111 return false;
1114 if (s == SAVE_EXPLICIT && gfc_implicit_pure (NULL))
1115 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1117 if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
1119 if (!gfc_notify_std (GFC_STD_LEGACY,
1120 "Duplicate SAVE attribute specified at %L",
1121 where))
1122 return false;
1125 attr->save = s;
1126 return check_conflict (attr, name, where);
1130 bool
1131 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1134 if (check_used (attr, name, where))
1135 return false;
1137 if (attr->value)
1139 if (!gfc_notify_std (GFC_STD_LEGACY,
1140 "Duplicate VALUE attribute specified at %L",
1141 where))
1142 return false;
1145 attr->value = 1;
1146 return check_conflict (attr, name, where);
1150 bool
1151 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1153 /* No check_used needed as 11.2.1 of the F2003 standard allows
1154 that the local identifier made accessible by a use statement can be
1155 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1157 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1158 if (!gfc_notify_std (GFC_STD_LEGACY,
1159 "Duplicate VOLATILE attribute specified at %L",
1160 where))
1161 return false;
1163 attr->volatile_ = 1;
1164 attr->volatile_ns = gfc_current_ns;
1165 return check_conflict (attr, name, where);
1169 bool
1170 gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1172 /* No check_used needed as 11.2.1 of the F2003 standard allows
1173 that the local identifier made accessible by a use statement can be
1174 given a ASYNCHRONOUS attribute. */
1176 if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
1177 if (!gfc_notify_std (GFC_STD_LEGACY,
1178 "Duplicate ASYNCHRONOUS attribute specified at %L",
1179 where))
1180 return false;
1182 attr->asynchronous = 1;
1183 attr->asynchronous_ns = gfc_current_ns;
1184 return check_conflict (attr, name, where);
1188 bool
1189 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1192 if (check_used (attr, name, where))
1193 return false;
1195 if (attr->threadprivate)
1197 duplicate_attr ("THREADPRIVATE", where);
1198 return false;
1201 attr->threadprivate = 1;
1202 return check_conflict (attr, name, where);
1206 bool
1207 gfc_add_target (symbol_attribute *attr, locus *where)
1210 if (check_used (attr, NULL, where))
1211 return false;
1213 if (attr->target)
1215 duplicate_attr ("TARGET", where);
1216 return false;
1219 attr->target = 1;
1220 return check_conflict (attr, NULL, where);
1224 bool
1225 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1228 if (check_used (attr, name, where))
1229 return false;
1231 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1232 attr->dummy = 1;
1233 return check_conflict (attr, name, where);
1237 bool
1238 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1241 if (check_used (attr, name, where))
1242 return false;
1244 /* Duplicate attribute already checked for. */
1245 attr->in_common = 1;
1246 return check_conflict (attr, name, where);
1250 bool
1251 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1254 /* Duplicate attribute already checked for. */
1255 attr->in_equivalence = 1;
1256 if (!check_conflict (attr, name, where))
1257 return false;
1259 if (attr->flavor == FL_VARIABLE)
1260 return true;
1262 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1266 bool
1267 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1270 if (check_used (attr, name, where))
1271 return false;
1273 attr->data = 1;
1274 return check_conflict (attr, name, where);
1278 bool
1279 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1282 attr->in_namelist = 1;
1283 return check_conflict (attr, name, where);
1287 bool
1288 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1291 if (check_used (attr, name, where))
1292 return false;
1294 attr->sequence = 1;
1295 return check_conflict (attr, name, where);
1299 bool
1300 gfc_add_elemental (symbol_attribute *attr, locus *where)
1303 if (check_used (attr, NULL, where))
1304 return false;
1306 if (attr->elemental)
1308 duplicate_attr ("ELEMENTAL", where);
1309 return false;
1312 attr->elemental = 1;
1313 return check_conflict (attr, NULL, where);
1317 bool
1318 gfc_add_pure (symbol_attribute *attr, locus *where)
1321 if (check_used (attr, NULL, where))
1322 return false;
1324 if (attr->pure)
1326 duplicate_attr ("PURE", where);
1327 return false;
1330 attr->pure = 1;
1331 return check_conflict (attr, NULL, where);
1335 bool
1336 gfc_add_recursive (symbol_attribute *attr, locus *where)
1339 if (check_used (attr, NULL, where))
1340 return false;
1342 if (attr->recursive)
1344 duplicate_attr ("RECURSIVE", where);
1345 return false;
1348 attr->recursive = 1;
1349 return check_conflict (attr, NULL, where);
1353 bool
1354 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1357 if (check_used (attr, name, where))
1358 return false;
1360 if (attr->entry)
1362 duplicate_attr ("ENTRY", where);
1363 return false;
1366 attr->entry = 1;
1367 return check_conflict (attr, name, where);
1371 bool
1372 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1375 if (attr->flavor != FL_PROCEDURE
1376 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1377 return false;
1379 attr->function = 1;
1380 return check_conflict (attr, name, where);
1384 bool
1385 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1388 if (attr->flavor != FL_PROCEDURE
1389 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1390 return false;
1392 attr->subroutine = 1;
1393 return check_conflict (attr, name, where);
1397 bool
1398 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1401 if (attr->flavor != FL_PROCEDURE
1402 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1403 return false;
1405 attr->generic = 1;
1406 return check_conflict (attr, name, where);
1410 bool
1411 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1414 if (check_used (attr, NULL, where))
1415 return false;
1417 if (attr->flavor != FL_PROCEDURE
1418 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1419 return false;
1421 if (attr->procedure)
1423 duplicate_attr ("PROCEDURE", where);
1424 return false;
1427 attr->procedure = 1;
1429 return check_conflict (attr, NULL, where);
1433 bool
1434 gfc_add_abstract (symbol_attribute* attr, locus* where)
1436 if (attr->abstract)
1438 duplicate_attr ("ABSTRACT", where);
1439 return false;
1442 attr->abstract = 1;
1443 return true;
1447 /* Flavors are special because some flavors are not what Fortran
1448 considers attributes and can be reaffirmed multiple times. */
1450 bool
1451 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1452 locus *where)
1455 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1456 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1457 || f == FL_NAMELIST) && check_used (attr, name, where))
1458 return false;
1460 if (attr->flavor == f && f == FL_VARIABLE)
1461 return true;
1463 if (attr->flavor != FL_UNKNOWN)
1465 if (where == NULL)
1466 where = &gfc_current_locus;
1468 if (name)
1469 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1470 gfc_code2string (flavors, attr->flavor), name,
1471 gfc_code2string (flavors, f), where);
1472 else
1473 gfc_error ("%s attribute conflicts with %s attribute at %L",
1474 gfc_code2string (flavors, attr->flavor),
1475 gfc_code2string (flavors, f), where);
1477 return false;
1480 attr->flavor = f;
1482 return check_conflict (attr, name, where);
1486 bool
1487 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1488 const char *name, locus *where)
1491 if (check_used (attr, name, where))
1492 return false;
1494 if (attr->flavor != FL_PROCEDURE
1495 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1496 return false;
1498 if (where == NULL)
1499 where = &gfc_current_locus;
1501 if (attr->proc != PROC_UNKNOWN)
1503 gfc_error ("%s procedure at %L is already declared as %s procedure",
1504 gfc_code2string (procedures, t), where,
1505 gfc_code2string (procedures, attr->proc));
1507 return false;
1510 attr->proc = t;
1512 /* Statement functions are always scalar and functions. */
1513 if (t == PROC_ST_FUNCTION
1514 && ((!attr->function && !gfc_add_function (attr, name, where))
1515 || attr->dimension))
1516 return false;
1518 return check_conflict (attr, name, where);
1522 bool
1523 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1526 if (check_used (attr, NULL, where))
1527 return false;
1529 if (attr->intent == INTENT_UNKNOWN)
1531 attr->intent = intent;
1532 return check_conflict (attr, NULL, where);
1535 if (where == NULL)
1536 where = &gfc_current_locus;
1538 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1539 gfc_intent_string (attr->intent),
1540 gfc_intent_string (intent), where);
1542 return false;
1546 /* No checks for use-association in public and private statements. */
1548 bool
1549 gfc_add_access (symbol_attribute *attr, gfc_access access,
1550 const char *name, locus *where)
1553 if (attr->access == ACCESS_UNKNOWN
1554 || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1556 attr->access = access;
1557 return check_conflict (attr, name, where);
1560 if (where == NULL)
1561 where = &gfc_current_locus;
1562 gfc_error ("ACCESS specification at %L was already specified", where);
1564 return false;
1568 /* Set the is_bind_c field for the given symbol_attribute. */
1570 bool
1571 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1572 int is_proc_lang_bind_spec)
1575 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1576 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1577 "variables or common blocks", where);
1578 else if (attr->is_bind_c)
1579 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1580 else
1581 attr->is_bind_c = 1;
1583 if (where == NULL)
1584 where = &gfc_current_locus;
1586 if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where))
1587 return false;
1589 return check_conflict (attr, name, where);
1593 /* Set the extension field for the given symbol_attribute. */
1595 bool
1596 gfc_add_extension (symbol_attribute *attr, locus *where)
1598 if (where == NULL)
1599 where = &gfc_current_locus;
1601 if (attr->extension)
1602 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1603 else
1604 attr->extension = 1;
1606 if (!gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where))
1607 return false;
1609 return true;
1613 bool
1614 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1615 gfc_formal_arglist * formal, locus *where)
1618 if (check_used (&sym->attr, sym->name, where))
1619 return false;
1621 if (where == NULL)
1622 where = &gfc_current_locus;
1624 if (sym->attr.if_source != IFSRC_UNKNOWN
1625 && sym->attr.if_source != IFSRC_DECL)
1627 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1628 sym->name, where);
1629 return false;
1632 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1634 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1635 "body", sym->name, where);
1636 return false;
1639 sym->formal = formal;
1640 sym->attr.if_source = source;
1642 return true;
1646 /* Add a type to a symbol. */
1648 bool
1649 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1651 sym_flavor flavor;
1652 bt type;
1654 if (where == NULL)
1655 where = &gfc_current_locus;
1657 if (sym->result)
1658 type = sym->result->ts.type;
1659 else
1660 type = sym->ts.type;
1662 if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
1663 type = sym->ns->proc_name->ts.type;
1665 if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
1667 if (sym->attr.use_assoc)
1668 gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
1669 "use-associated at %L", sym->name, where, sym->module,
1670 &sym->declared_at);
1671 else
1672 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1673 where, gfc_basic_typename (type));
1674 return false;
1677 if (sym->attr.procedure && sym->ts.interface)
1679 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1680 sym->name, where, gfc_basic_typename (ts->type));
1681 return false;
1684 flavor = sym->attr.flavor;
1686 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1687 || flavor == FL_LABEL
1688 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1689 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1691 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1692 return false;
1695 sym->ts = *ts;
1696 return true;
1700 /* Clears all attributes. */
1702 void
1703 gfc_clear_attr (symbol_attribute *attr)
1705 memset (attr, 0, sizeof (symbol_attribute));
1709 /* Check for missing attributes in the new symbol. Currently does
1710 nothing, but it's not clear that it is unnecessary yet. */
1712 bool
1713 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1714 locus *where ATTRIBUTE_UNUSED)
1717 return true;
1721 /* Copy an attribute to a symbol attribute, bit by bit. Some
1722 attributes have a lot of side-effects but cannot be present given
1723 where we are called from, so we ignore some bits. */
1725 bool
1726 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1728 int is_proc_lang_bind_spec;
1730 /* In line with the other attributes, we only add bits but do not remove
1731 them; cf. also PR 41034. */
1732 dest->ext_attr |= src->ext_attr;
1734 if (src->allocatable && !gfc_add_allocatable (dest, where))
1735 goto fail;
1737 if (src->dimension && !gfc_add_dimension (dest, NULL, where))
1738 goto fail;
1739 if (src->codimension && !gfc_add_codimension (dest, NULL, where))
1740 goto fail;
1741 if (src->contiguous && !gfc_add_contiguous (dest, NULL, where))
1742 goto fail;
1743 if (src->optional && !gfc_add_optional (dest, where))
1744 goto fail;
1745 if (src->pointer && !gfc_add_pointer (dest, where))
1746 goto fail;
1747 if (src->is_protected && !gfc_add_protected (dest, NULL, where))
1748 goto fail;
1749 if (src->save && !gfc_add_save (dest, src->save, NULL, where))
1750 goto fail;
1751 if (src->value && !gfc_add_value (dest, NULL, where))
1752 goto fail;
1753 if (src->volatile_ && !gfc_add_volatile (dest, NULL, where))
1754 goto fail;
1755 if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where))
1756 goto fail;
1757 if (src->threadprivate
1758 && !gfc_add_threadprivate (dest, NULL, where))
1759 goto fail;
1760 if (src->target && !gfc_add_target (dest, where))
1761 goto fail;
1762 if (src->dummy && !gfc_add_dummy (dest, NULL, where))
1763 goto fail;
1764 if (src->result && !gfc_add_result (dest, NULL, where))
1765 goto fail;
1766 if (src->entry)
1767 dest->entry = 1;
1769 if (src->in_namelist && !gfc_add_in_namelist (dest, NULL, where))
1770 goto fail;
1772 if (src->in_common && !gfc_add_in_common (dest, NULL, where))
1773 goto fail;
1775 if (src->generic && !gfc_add_generic (dest, NULL, where))
1776 goto fail;
1777 if (src->function && !gfc_add_function (dest, NULL, where))
1778 goto fail;
1779 if (src->subroutine && !gfc_add_subroutine (dest, NULL, where))
1780 goto fail;
1782 if (src->sequence && !gfc_add_sequence (dest, NULL, where))
1783 goto fail;
1784 if (src->elemental && !gfc_add_elemental (dest, where))
1785 goto fail;
1786 if (src->pure && !gfc_add_pure (dest, where))
1787 goto fail;
1788 if (src->recursive && !gfc_add_recursive (dest, where))
1789 goto fail;
1791 if (src->flavor != FL_UNKNOWN
1792 && !gfc_add_flavor (dest, src->flavor, NULL, where))
1793 goto fail;
1795 if (src->intent != INTENT_UNKNOWN
1796 && !gfc_add_intent (dest, src->intent, where))
1797 goto fail;
1799 if (src->access != ACCESS_UNKNOWN
1800 && !gfc_add_access (dest, src->access, NULL, where))
1801 goto fail;
1803 if (!gfc_missing_attr (dest, where))
1804 goto fail;
1806 if (src->cray_pointer && !gfc_add_cray_pointer (dest, where))
1807 goto fail;
1808 if (src->cray_pointee && !gfc_add_cray_pointee (dest, where))
1809 goto fail;
1811 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1812 if (src->is_bind_c
1813 && !gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec))
1814 return false;
1816 if (src->is_c_interop)
1817 dest->is_c_interop = 1;
1818 if (src->is_iso_c)
1819 dest->is_iso_c = 1;
1821 if (src->external && !gfc_add_external (dest, where))
1822 goto fail;
1823 if (src->intrinsic && !gfc_add_intrinsic (dest, where))
1824 goto fail;
1825 if (src->proc_pointer)
1826 dest->proc_pointer = 1;
1828 return true;
1830 fail:
1831 return false;
1835 /************** Component name management ************/
1837 /* Component names of a derived type form their own little namespaces
1838 that are separate from all other spaces. The space is composed of
1839 a singly linked list of gfc_component structures whose head is
1840 located in the parent symbol. */
1843 /* Add a component name to a symbol. The call fails if the name is
1844 already present. On success, the component pointer is modified to
1845 point to the additional component structure. */
1847 bool
1848 gfc_add_component (gfc_symbol *sym, const char *name,
1849 gfc_component **component)
1851 gfc_component *p, *tail;
1853 tail = NULL;
1855 for (p = sym->components; p; p = p->next)
1857 if (strcmp (p->name, name) == 0)
1859 gfc_error ("Component '%s' at %C already declared at %L",
1860 name, &p->loc);
1861 return false;
1864 tail = p;
1867 if (sym->attr.extension
1868 && gfc_find_component (sym->components->ts.u.derived, name, true, true))
1870 gfc_error ("Component '%s' at %C already in the parent type "
1871 "at %L", name, &sym->components->ts.u.derived->declared_at);
1872 return false;
1875 /* Allocate a new component. */
1876 p = gfc_get_component ();
1878 if (tail == NULL)
1879 sym->components = p;
1880 else
1881 tail->next = p;
1883 p->name = gfc_get_string (name);
1884 p->loc = gfc_current_locus;
1885 p->ts.type = BT_UNKNOWN;
1887 *component = p;
1888 return true;
1892 /* Recursive function to switch derived types of all symbol in a
1893 namespace. */
1895 static void
1896 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1898 gfc_symbol *sym;
1900 if (st == NULL)
1901 return;
1903 sym = st->n.sym;
1904 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
1905 sym->ts.u.derived = to;
1907 switch_types (st->left, from, to);
1908 switch_types (st->right, from, to);
1912 /* This subroutine is called when a derived type is used in order to
1913 make the final determination about which version to use. The
1914 standard requires that a type be defined before it is 'used', but
1915 such types can appear in IMPLICIT statements before the actual
1916 definition. 'Using' in this context means declaring a variable to
1917 be that type or using the type constructor.
1919 If a type is used and the components haven't been defined, then we
1920 have to have a derived type in a parent unit. We find the node in
1921 the other namespace and point the symtree node in this namespace to
1922 that node. Further reference to this name point to the correct
1923 node. If we can't find the node in a parent namespace, then we have
1924 an error.
1926 This subroutine takes a pointer to a symbol node and returns a
1927 pointer to the translated node or NULL for an error. Usually there
1928 is no translation and we return the node we were passed. */
1930 gfc_symbol *
1931 gfc_use_derived (gfc_symbol *sym)
1933 gfc_symbol *s;
1934 gfc_typespec *t;
1935 gfc_symtree *st;
1936 int i;
1938 if (!sym)
1939 return NULL;
1941 if (sym->attr.unlimited_polymorphic)
1942 return sym;
1944 if (sym->attr.generic)
1945 sym = gfc_find_dt_in_generic (sym);
1947 if (sym->components != NULL || sym->attr.zero_comp)
1948 return sym; /* Already defined. */
1950 if (sym->ns->parent == NULL)
1951 goto bad;
1953 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1955 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1956 return NULL;
1959 if (s == NULL || s->attr.flavor != FL_DERIVED)
1960 goto bad;
1962 /* Get rid of symbol sym, translating all references to s. */
1963 for (i = 0; i < GFC_LETTERS; i++)
1965 t = &sym->ns->default_type[i];
1966 if (t->u.derived == sym)
1967 t->u.derived = s;
1970 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1971 st->n.sym = s;
1973 s->refs++;
1975 /* Unlink from list of modified symbols. */
1976 gfc_commit_symbol (sym);
1978 switch_types (sym->ns->sym_root, sym, s);
1980 /* TODO: Also have to replace sym -> s in other lists like
1981 namelists, common lists and interface lists. */
1982 gfc_free_symbol (sym);
1984 return s;
1986 bad:
1987 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1988 sym->name);
1989 return NULL;
1993 /* Given a derived type node and a component name, try to locate the
1994 component structure. Returns the NULL pointer if the component is
1995 not found or the components are private. If noaccess is set, no access
1996 checks are done. */
1998 gfc_component *
1999 gfc_find_component (gfc_symbol *sym, const char *name,
2000 bool noaccess, bool silent)
2002 gfc_component *p;
2004 if (name == NULL || sym == NULL)
2005 return NULL;
2007 sym = gfc_use_derived (sym);
2009 if (sym == NULL)
2010 return NULL;
2012 for (p = sym->components; p; p = p->next)
2013 if (strcmp (p->name, name) == 0)
2014 break;
2016 if (p && sym->attr.use_assoc && !noaccess)
2018 bool is_parent_comp = sym->attr.extension && (p == sym->components);
2019 if (p->attr.access == ACCESS_PRIVATE ||
2020 (p->attr.access != ACCESS_PUBLIC
2021 && sym->component_access == ACCESS_PRIVATE
2022 && !is_parent_comp))
2024 if (!silent)
2025 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2026 name, sym->name);
2027 return NULL;
2031 if (p == NULL
2032 && sym->attr.extension
2033 && sym->components->ts.type == BT_DERIVED)
2035 p = gfc_find_component (sym->components->ts.u.derived, name,
2036 noaccess, silent);
2037 /* Do not overwrite the error. */
2038 if (p == NULL)
2039 return p;
2042 if (p == NULL && !silent)
2043 gfc_error ("'%s' at %C is not a member of the '%s' structure",
2044 name, sym->name);
2046 return p;
2050 /* Given a symbol, free all of the component structures and everything
2051 they point to. */
2053 static void
2054 free_components (gfc_component *p)
2056 gfc_component *q;
2058 for (; p; p = q)
2060 q = p->next;
2062 gfc_free_array_spec (p->as);
2063 gfc_free_expr (p->initializer);
2064 free (p->tb);
2066 free (p);
2071 /******************** Statement label management ********************/
2073 /* Comparison function for statement labels, used for managing the
2074 binary tree. */
2076 static int
2077 compare_st_labels (void *a1, void *b1)
2079 int a = ((gfc_st_label *) a1)->value;
2080 int b = ((gfc_st_label *) b1)->value;
2082 return (b - a);
2086 /* Free a single gfc_st_label structure, making sure the tree is not
2087 messed up. This function is called only when some parse error
2088 occurs. */
2090 void
2091 gfc_free_st_label (gfc_st_label *label)
2094 if (label == NULL)
2095 return;
2097 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
2099 if (label->format != NULL)
2100 gfc_free_expr (label->format);
2102 free (label);
2106 /* Free a whole tree of gfc_st_label structures. */
2108 static void
2109 free_st_labels (gfc_st_label *label)
2112 if (label == NULL)
2113 return;
2115 free_st_labels (label->left);
2116 free_st_labels (label->right);
2118 if (label->format != NULL)
2119 gfc_free_expr (label->format);
2120 free (label);
2124 /* Given a label number, search for and return a pointer to the label
2125 structure, creating it if it does not exist. */
2127 gfc_st_label *
2128 gfc_get_st_label (int labelno)
2130 gfc_st_label *lp;
2131 gfc_namespace *ns;
2133 if (gfc_current_state () == COMP_DERIVED)
2134 ns = gfc_current_block ()->f2k_derived;
2135 else
2137 /* Find the namespace of the scoping unit:
2138 If we're in a BLOCK construct, jump to the parent namespace. */
2139 ns = gfc_current_ns;
2140 while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2141 ns = ns->parent;
2144 /* First see if the label is already in this namespace. */
2145 lp = ns->st_labels;
2146 while (lp)
2148 if (lp->value == labelno)
2149 return lp;
2151 if (lp->value < labelno)
2152 lp = lp->left;
2153 else
2154 lp = lp->right;
2157 lp = XCNEW (gfc_st_label);
2159 lp->value = labelno;
2160 lp->defined = ST_LABEL_UNKNOWN;
2161 lp->referenced = ST_LABEL_UNKNOWN;
2163 gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2165 return lp;
2169 /* Called when a statement with a statement label is about to be
2170 accepted. We add the label to the list of the current namespace,
2171 making sure it hasn't been defined previously and referenced
2172 correctly. */
2174 void
2175 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2177 int labelno;
2179 labelno = lp->value;
2181 if (lp->defined != ST_LABEL_UNKNOWN)
2182 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2183 &lp->where, label_locus);
2184 else
2186 lp->where = *label_locus;
2188 switch (type)
2190 case ST_LABEL_FORMAT:
2191 if (lp->referenced == ST_LABEL_TARGET
2192 || lp->referenced == ST_LABEL_DO_TARGET)
2193 gfc_error ("Label %d at %C already referenced as branch target",
2194 labelno);
2195 else
2196 lp->defined = ST_LABEL_FORMAT;
2198 break;
2200 case ST_LABEL_TARGET:
2201 case ST_LABEL_DO_TARGET:
2202 if (lp->referenced == ST_LABEL_FORMAT)
2203 gfc_error ("Label %d at %C already referenced as a format label",
2204 labelno);
2205 else
2206 lp->defined = type;
2208 if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
2209 && !gfc_notify_std (GFC_STD_F95_OBS, "DO termination statement "
2210 "which is not END DO or CONTINUE with "
2211 "label %d at %C", labelno))
2212 return;
2213 break;
2215 default:
2216 lp->defined = ST_LABEL_BAD_TARGET;
2217 lp->referenced = ST_LABEL_BAD_TARGET;
2223 /* Reference a label. Given a label and its type, see if that
2224 reference is consistent with what is known about that label,
2225 updating the unknown state. Returns false if something goes
2226 wrong. */
2228 bool
2229 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2231 gfc_sl_type label_type;
2232 int labelno;
2233 bool rc;
2235 if (lp == NULL)
2236 return true;
2238 labelno = lp->value;
2240 if (lp->defined != ST_LABEL_UNKNOWN)
2241 label_type = lp->defined;
2242 else
2244 label_type = lp->referenced;
2245 lp->where = gfc_current_locus;
2248 if (label_type == ST_LABEL_FORMAT
2249 && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
2251 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2252 rc = false;
2253 goto done;
2256 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
2257 || label_type == ST_LABEL_BAD_TARGET)
2258 && type == ST_LABEL_FORMAT)
2260 gfc_error ("Label %d at %C previously used as branch target", labelno);
2261 rc = false;
2262 goto done;
2265 if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
2266 && !gfc_notify_std (GFC_STD_F95_OBS, "Shared DO termination label %d "
2267 "at %C", labelno))
2268 return false;
2270 if (lp->referenced != ST_LABEL_DO_TARGET)
2271 lp->referenced = type;
2272 rc = true;
2274 done:
2275 return rc;
2279 /************** Symbol table management subroutines ****************/
2281 /* Basic details: Fortran 95 requires a potentially unlimited number
2282 of distinct namespaces when compiling a program unit. This case
2283 occurs during a compilation of internal subprograms because all of
2284 the internal subprograms must be read before we can start
2285 generating code for the host.
2287 Given the tricky nature of the Fortran grammar, we must be able to
2288 undo changes made to a symbol table if the current interpretation
2289 of a statement is found to be incorrect. Whenever a symbol is
2290 looked up, we make a copy of it and link to it. All of these
2291 symbols are kept in a vector so that we can commit or
2292 undo the changes at a later time.
2294 A symtree may point to a symbol node outside of its namespace. In
2295 this case, that symbol has been used as a host associated variable
2296 at some previous time. */
2298 /* Allocate a new namespace structure. Copies the implicit types from
2299 PARENT if PARENT_TYPES is set. */
2301 gfc_namespace *
2302 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2304 gfc_namespace *ns;
2305 gfc_typespec *ts;
2306 int in;
2307 int i;
2309 ns = XCNEW (gfc_namespace);
2310 ns->sym_root = NULL;
2311 ns->uop_root = NULL;
2312 ns->tb_sym_root = NULL;
2313 ns->finalizers = NULL;
2314 ns->default_access = ACCESS_UNKNOWN;
2315 ns->parent = parent;
2317 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2319 ns->operator_access[in] = ACCESS_UNKNOWN;
2320 ns->tb_op[in] = NULL;
2323 /* Initialize default implicit types. */
2324 for (i = 'a'; i <= 'z'; i++)
2326 ns->set_flag[i - 'a'] = 0;
2327 ts = &ns->default_type[i - 'a'];
2329 if (parent_types && ns->parent != NULL)
2331 /* Copy parent settings. */
2332 *ts = ns->parent->default_type[i - 'a'];
2333 continue;
2336 if (gfc_option.flag_implicit_none != 0)
2338 gfc_clear_ts (ts);
2339 continue;
2342 if ('i' <= i && i <= 'n')
2344 ts->type = BT_INTEGER;
2345 ts->kind = gfc_default_integer_kind;
2347 else
2349 ts->type = BT_REAL;
2350 ts->kind = gfc_default_real_kind;
2354 ns->refs = 1;
2356 return ns;
2360 /* Comparison function for symtree nodes. */
2362 static int
2363 compare_symtree (void *_st1, void *_st2)
2365 gfc_symtree *st1, *st2;
2367 st1 = (gfc_symtree *) _st1;
2368 st2 = (gfc_symtree *) _st2;
2370 return strcmp (st1->name, st2->name);
2374 /* Allocate a new symtree node and associate it with the new symbol. */
2376 gfc_symtree *
2377 gfc_new_symtree (gfc_symtree **root, const char *name)
2379 gfc_symtree *st;
2381 st = XCNEW (gfc_symtree);
2382 st->name = gfc_get_string (name);
2384 gfc_insert_bbt (root, st, compare_symtree);
2385 return st;
2389 /* Delete a symbol from the tree. Does not free the symbol itself! */
2391 void
2392 gfc_delete_symtree (gfc_symtree **root, const char *name)
2394 gfc_symtree st, *st0;
2396 st0 = gfc_find_symtree (*root, name);
2398 st.name = gfc_get_string (name);
2399 gfc_delete_bbt (root, &st, compare_symtree);
2401 free (st0);
2405 /* Given a root symtree node and a name, try to find the symbol within
2406 the namespace. Returns NULL if the symbol is not found. */
2408 gfc_symtree *
2409 gfc_find_symtree (gfc_symtree *st, const char *name)
2411 int c;
2413 while (st != NULL)
2415 c = strcmp (name, st->name);
2416 if (c == 0)
2417 return st;
2419 st = (c < 0) ? st->left : st->right;
2422 return NULL;
2426 /* Return a symtree node with a name that is guaranteed to be unique
2427 within the namespace and corresponds to an illegal fortran name. */
2429 gfc_symtree *
2430 gfc_get_unique_symtree (gfc_namespace *ns)
2432 char name[GFC_MAX_SYMBOL_LEN + 1];
2433 static int serial = 0;
2435 sprintf (name, "@%d", serial++);
2436 return gfc_new_symtree (&ns->sym_root, name);
2440 /* Given a name find a user operator node, creating it if it doesn't
2441 exist. These are much simpler than symbols because they can't be
2442 ambiguous with one another. */
2444 gfc_user_op *
2445 gfc_get_uop (const char *name)
2447 gfc_user_op *uop;
2448 gfc_symtree *st;
2450 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2451 if (st != NULL)
2452 return st->n.uop;
2454 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2456 uop = st->n.uop = XCNEW (gfc_user_op);
2457 uop->name = gfc_get_string (name);
2458 uop->access = ACCESS_UNKNOWN;
2459 uop->ns = gfc_current_ns;
2461 return uop;
2465 /* Given a name find the user operator node. Returns NULL if it does
2466 not exist. */
2468 gfc_user_op *
2469 gfc_find_uop (const char *name, gfc_namespace *ns)
2471 gfc_symtree *st;
2473 if (ns == NULL)
2474 ns = gfc_current_ns;
2476 st = gfc_find_symtree (ns->uop_root, name);
2477 return (st == NULL) ? NULL : st->n.uop;
2481 /* Remove a gfc_symbol structure and everything it points to. */
2483 void
2484 gfc_free_symbol (gfc_symbol *sym)
2487 if (sym == NULL)
2488 return;
2490 gfc_free_array_spec (sym->as);
2492 free_components (sym->components);
2494 gfc_free_expr (sym->value);
2496 gfc_free_namelist (sym->namelist);
2498 if (sym->ns != sym->formal_ns)
2499 gfc_free_namespace (sym->formal_ns);
2501 if (!sym->attr.generic_copy)
2502 gfc_free_interface (sym->generic);
2504 gfc_free_formal_arglist (sym->formal);
2506 gfc_free_namespace (sym->f2k_derived);
2508 if (sym->common_block && sym->common_block->name[0] != '\0')
2510 sym->common_block->refs--;
2511 if (sym->common_block->refs == 0)
2512 free (sym->common_block);
2515 free (sym);
2519 /* Decrease the reference counter and free memory when we reach zero. */
2521 void
2522 gfc_release_symbol (gfc_symbol *sym)
2524 if (sym == NULL)
2525 return;
2527 if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns
2528 && (!sym->attr.entry || !sym->module))
2530 /* As formal_ns contains a reference to sym, delete formal_ns just
2531 before the deletion of sym. */
2532 gfc_namespace *ns = sym->formal_ns;
2533 sym->formal_ns = NULL;
2534 gfc_free_namespace (ns);
2537 sym->refs--;
2538 if (sym->refs > 0)
2539 return;
2541 gcc_assert (sym->refs == 0);
2542 gfc_free_symbol (sym);
2546 /* Allocate and initialize a new symbol node. */
2548 gfc_symbol *
2549 gfc_new_symbol (const char *name, gfc_namespace *ns)
2551 gfc_symbol *p;
2553 p = XCNEW (gfc_symbol);
2555 gfc_clear_ts (&p->ts);
2556 gfc_clear_attr (&p->attr);
2557 p->ns = ns;
2559 p->declared_at = gfc_current_locus;
2561 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2562 gfc_internal_error ("new_symbol(): Symbol name too long");
2564 p->name = gfc_get_string (name);
2566 /* Make sure flags for symbol being C bound are clear initially. */
2567 p->attr.is_bind_c = 0;
2568 p->attr.is_iso_c = 0;
2570 /* Clear the ptrs we may need. */
2571 p->common_block = NULL;
2572 p->f2k_derived = NULL;
2573 p->assoc = NULL;
2575 return p;
2579 /* Generate an error if a symbol is ambiguous. */
2581 static void
2582 ambiguous_symbol (const char *name, gfc_symtree *st)
2585 if (st->n.sym->module)
2586 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2587 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2588 else
2589 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2590 "from current program unit", name, st->n.sym->name);
2594 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2595 selector on the stack. If yes, replace it by the corresponding temporary. */
2597 static void
2598 select_type_insert_tmp (gfc_symtree **st)
2600 gfc_select_type_stack *stack = select_type_stack;
2601 for (; stack; stack = stack->prev)
2602 if ((*st)->n.sym == stack->selector && stack->tmp)
2603 *st = stack->tmp;
2607 /* Look for a symtree in the current procedure -- that is, go up to
2608 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
2610 gfc_symtree*
2611 gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
2613 while (ns)
2615 gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
2616 if (st)
2617 return st;
2619 if (!ns->construct_entities)
2620 break;
2621 ns = ns->parent;
2624 return NULL;
2628 /* Search for a symtree starting in the current namespace, resorting to
2629 any parent namespaces if requested by a nonzero parent_flag.
2630 Returns nonzero if the name is ambiguous. */
2633 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2634 gfc_symtree **result)
2636 gfc_symtree *st;
2638 if (ns == NULL)
2639 ns = gfc_current_ns;
2643 st = gfc_find_symtree (ns->sym_root, name);
2644 if (st != NULL)
2646 select_type_insert_tmp (&st);
2648 *result = st;
2649 /* Ambiguous generic interfaces are permitted, as long
2650 as the specific interfaces are different. */
2651 if (st->ambiguous && !st->n.sym->attr.generic)
2653 ambiguous_symbol (name, st);
2654 return 1;
2657 return 0;
2660 if (!parent_flag)
2661 break;
2663 /* Don't escape an interface block. */
2664 if (ns && !ns->has_import_set
2665 && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
2666 break;
2668 ns = ns->parent;
2670 while (ns != NULL);
2672 *result = NULL;
2673 return 0;
2677 /* Same, but returns the symbol instead. */
2680 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2681 gfc_symbol **result)
2683 gfc_symtree *st;
2684 int i;
2686 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2688 if (st == NULL)
2689 *result = NULL;
2690 else
2691 *result = st->n.sym;
2693 return i;
2697 /* Tells whether there is only one set of changes in the stack. */
2699 static bool
2700 single_undo_checkpoint_p (void)
2702 if (latest_undo_chgset == &default_undo_chgset_var)
2704 gcc_assert (latest_undo_chgset->previous == NULL);
2705 return true;
2707 else
2709 gcc_assert (latest_undo_chgset->previous != NULL);
2710 return false;
2714 /* Save symbol with the information necessary to back it out. */
2716 static void
2717 save_symbol_data (gfc_symbol *sym)
2719 gfc_symbol *s;
2720 unsigned i;
2722 if (!single_undo_checkpoint_p ())
2724 /* If there is more than one change set, look for the symbol in the
2725 current one. If it is found there, we can reuse it. */
2726 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
2727 if (s == sym)
2729 gcc_assert (sym->gfc_new || sym->old_symbol != NULL);
2730 return;
2733 else if (sym->gfc_new || sym->old_symbol != NULL)
2734 return;
2736 s = XCNEW (gfc_symbol);
2737 *s = *sym;
2738 sym->old_symbol = s;
2739 sym->gfc_new = 0;
2741 latest_undo_chgset->syms.safe_push (sym);
2745 /* Given a name, find a symbol, or create it if it does not exist yet
2746 in the current namespace. If the symbol is found we make sure that
2747 it's OK.
2749 The integer return code indicates
2750 0 All OK
2751 1 The symbol name was ambiguous
2752 2 The name meant to be established was already host associated.
2754 So if the return value is nonzero, then an error was issued. */
2757 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2758 bool allow_subroutine)
2760 gfc_symtree *st;
2761 gfc_symbol *p;
2763 /* This doesn't usually happen during resolution. */
2764 if (ns == NULL)
2765 ns = gfc_current_ns;
2767 /* Try to find the symbol in ns. */
2768 st = gfc_find_symtree (ns->sym_root, name);
2770 if (st == NULL)
2772 /* If not there, create a new symbol. */
2773 p = gfc_new_symbol (name, ns);
2775 /* Add to the list of tentative symbols. */
2776 p->old_symbol = NULL;
2777 p->mark = 1;
2778 p->gfc_new = 1;
2779 latest_undo_chgset->syms.safe_push (p);
2781 st = gfc_new_symtree (&ns->sym_root, name);
2782 st->n.sym = p;
2783 p->refs++;
2786 else
2788 /* Make sure the existing symbol is OK. Ambiguous
2789 generic interfaces are permitted, as long as the
2790 specific interfaces are different. */
2791 if (st->ambiguous && !st->n.sym->attr.generic)
2793 ambiguous_symbol (name, st);
2794 return 1;
2797 p = st->n.sym;
2798 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2799 && !(allow_subroutine && p->attr.subroutine)
2800 && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2801 && (ns->has_import_set || p->attr.imported)))
2803 /* Symbol is from another namespace. */
2804 gfc_error ("Symbol '%s' at %C has already been host associated",
2805 name);
2806 return 2;
2809 p->mark = 1;
2811 /* Copy in case this symbol is changed. */
2812 save_symbol_data (p);
2815 *result = st;
2816 return 0;
2821 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2823 gfc_symtree *st;
2824 int i;
2826 i = gfc_get_sym_tree (name, ns, &st, false);
2827 if (i != 0)
2828 return i;
2830 if (st)
2831 *result = st->n.sym;
2832 else
2833 *result = NULL;
2834 return i;
2838 /* Subroutine that searches for a symbol, creating it if it doesn't
2839 exist, but tries to host-associate the symbol if possible. */
2842 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2844 gfc_symtree *st;
2845 int i;
2847 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2849 if (st != NULL)
2851 save_symbol_data (st->n.sym);
2852 *result = st;
2853 return i;
2856 i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st);
2857 if (i)
2858 return i;
2860 if (st != NULL)
2862 *result = st;
2863 return 0;
2866 return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2871 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2873 int i;
2874 gfc_symtree *st;
2876 i = gfc_get_ha_sym_tree (name, &st);
2878 if (st)
2879 *result = st->n.sym;
2880 else
2881 *result = NULL;
2883 return i;
2887 /* Search for the symtree belonging to a gfc_common_head; we cannot use
2888 head->name as the common_root symtree's name might be mangled. */
2890 static gfc_symtree *
2891 find_common_symtree (gfc_symtree *st, gfc_common_head *head)
2894 gfc_symtree *result;
2896 if (st == NULL)
2897 return NULL;
2899 if (st->n.common == head)
2900 return st;
2902 result = find_common_symtree (st->left, head);
2903 if (!result)
2904 result = find_common_symtree (st->right, head);
2906 return result;
2910 /* Clear the given storage, and make it the current change set for registering
2911 changed symbols. Its contents are freed after a call to
2912 gfc_restore_last_undo_checkpoint or gfc_drop_last_undo_checkpoint, but
2913 it is up to the caller to free the storage itself. It is usually a local
2914 variable, so there is nothing to do anyway. */
2916 void
2917 gfc_new_undo_checkpoint (gfc_undo_change_set &chg_syms)
2919 chg_syms.syms = vNULL;
2920 chg_syms.tbps = vNULL;
2921 chg_syms.previous = latest_undo_chgset;
2922 latest_undo_chgset = &chg_syms;
2926 /* Restore previous state of symbol. Just copy simple stuff. */
2928 static void
2929 restore_old_symbol (gfc_symbol *p)
2931 gfc_symbol *old;
2933 p->mark = 0;
2934 old = p->old_symbol;
2936 p->ts.type = old->ts.type;
2937 p->ts.kind = old->ts.kind;
2939 p->attr = old->attr;
2941 if (p->value != old->value)
2943 gcc_checking_assert (old->value == NULL);
2944 gfc_free_expr (p->value);
2945 p->value = NULL;
2948 if (p->as != old->as)
2950 if (p->as)
2951 gfc_free_array_spec (p->as);
2952 p->as = old->as;
2955 p->generic = old->generic;
2956 p->component_access = old->component_access;
2958 if (p->namelist != NULL && old->namelist == NULL)
2960 gfc_free_namelist (p->namelist);
2961 p->namelist = NULL;
2963 else
2965 if (p->namelist_tail != old->namelist_tail)
2967 gfc_free_namelist (old->namelist_tail->next);
2968 old->namelist_tail->next = NULL;
2972 p->namelist_tail = old->namelist_tail;
2974 if (p->formal != old->formal)
2976 gfc_free_formal_arglist (p->formal);
2977 p->formal = old->formal;
2980 p->old_symbol = old->old_symbol;
2981 free (old);
2985 /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
2986 the structure itself. */
2988 static void
2989 free_undo_change_set_data (gfc_undo_change_set &cs)
2991 cs.syms.release ();
2992 cs.tbps.release ();
2996 /* Given a change set pointer, free its target's contents and update it with
2997 the address of the previous change set. Note that only the contents are
2998 freed, not the target itself (the contents' container). It is not a problem
2999 as the latter will be a local variable usually. */
3001 static void
3002 pop_undo_change_set (gfc_undo_change_set *&cs)
3004 free_undo_change_set_data (*cs);
3005 cs = cs->previous;
3009 static void free_old_symbol (gfc_symbol *sym);
3012 /* Merges the current change set into the previous one. The changes themselves
3013 are left untouched; only one checkpoint is forgotten. */
3015 void
3016 gfc_drop_last_undo_checkpoint (void)
3018 gfc_symbol *s, *t;
3019 unsigned i, j;
3021 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
3023 /* No need to loop in this case. */
3024 if (s->old_symbol == NULL)
3025 continue;
3027 /* Remove the duplicate symbols. */
3028 FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)
3029 if (t == s)
3031 latest_undo_chgset->previous->syms.unordered_remove (j);
3033 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3034 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3035 shall contain from now on the backup symbol for S as it was
3036 at the checkpoint before. */
3037 if (s->old_symbol->gfc_new)
3039 gcc_assert (s->old_symbol->old_symbol == NULL);
3040 s->gfc_new = s->old_symbol->gfc_new;
3041 free_old_symbol (s);
3043 else
3044 restore_old_symbol (s->old_symbol);
3045 break;
3049 latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
3050 latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);
3052 pop_undo_change_set (latest_undo_chgset);
3056 /* Undoes all the changes made to symbols since the previous checkpoint.
3057 This subroutine is made simpler due to the fact that attributes are
3058 never removed once added. */
3060 void
3061 gfc_restore_last_undo_checkpoint (void)
3063 gfc_symbol *p;
3064 unsigned i;
3066 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3068 if (p->gfc_new)
3070 /* Symbol was new. */
3071 if (p->attr.in_common && p->common_block && p->common_block->head)
3073 /* If the symbol was added to any common block, it
3074 needs to be removed to stop the resolver looking
3075 for a (possibly) dead symbol. */
3077 if (p->common_block->head == p && !p->common_next)
3079 gfc_symtree st, *st0;
3080 st0 = find_common_symtree (p->ns->common_root,
3081 p->common_block);
3082 if (st0)
3084 st.name = st0->name;
3085 gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
3086 free (st0);
3090 if (p->common_block->head == p)
3091 p->common_block->head = p->common_next;
3092 else
3094 gfc_symbol *cparent, *csym;
3096 cparent = p->common_block->head;
3097 csym = cparent->common_next;
3099 while (csym != p)
3101 cparent = csym;
3102 csym = csym->common_next;
3105 gcc_assert(cparent->common_next == p);
3107 cparent->common_next = csym->common_next;
3111 /* The derived type is saved in the symtree with the first
3112 letter capitalized; the all lower-case version to the
3113 derived type contains its associated generic function. */
3114 if (p->attr.flavor == FL_DERIVED)
3115 gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
3116 (char) TOUPPER ((unsigned char) p->name[0]),
3117 &p->name[1]));
3118 else
3119 gfc_delete_symtree (&p->ns->sym_root, p->name);
3121 gfc_release_symbol (p);
3123 else
3124 restore_old_symbol (p);
3127 latest_undo_chgset->syms.truncate (0);
3128 latest_undo_chgset->tbps.truncate (0);
3130 if (!single_undo_checkpoint_p ())
3131 pop_undo_change_set (latest_undo_chgset);
3135 /* Makes sure that there is only one set of changes; in other words we haven't
3136 forgotten to pair a call to gfc_new_checkpoint with a call to either
3137 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3139 static void
3140 enforce_single_undo_checkpoint (void)
3142 gcc_checking_assert (single_undo_checkpoint_p ());
3146 /* Undoes all the changes made to symbols in the current statement. */
3148 void
3149 gfc_undo_symbols (void)
3151 enforce_single_undo_checkpoint ();
3152 gfc_restore_last_undo_checkpoint ();
3156 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3157 components of old_symbol that might need deallocation are the "allocatables"
3158 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3159 namelist_tail. In case these differ between old_symbol and sym, it's just
3160 because sym->namelist has gotten a few more items. */
3162 static void
3163 free_old_symbol (gfc_symbol *sym)
3166 if (sym->old_symbol == NULL)
3167 return;
3169 if (sym->old_symbol->as != sym->as)
3170 gfc_free_array_spec (sym->old_symbol->as);
3172 if (sym->old_symbol->value != sym->value)
3173 gfc_free_expr (sym->old_symbol->value);
3175 if (sym->old_symbol->formal != sym->formal)
3176 gfc_free_formal_arglist (sym->old_symbol->formal);
3178 free (sym->old_symbol);
3179 sym->old_symbol = NULL;
3183 /* Makes the changes made in the current statement permanent-- gets
3184 rid of undo information. */
3186 void
3187 gfc_commit_symbols (void)
3189 gfc_symbol *p;
3190 gfc_typebound_proc *tbp;
3191 unsigned i;
3193 enforce_single_undo_checkpoint ();
3195 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3197 p->mark = 0;
3198 p->gfc_new = 0;
3199 free_old_symbol (p);
3201 latest_undo_chgset->syms.truncate (0);
3203 FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)
3204 tbp->error = 0;
3205 latest_undo_chgset->tbps.truncate (0);
3209 /* Makes the changes made in one symbol permanent -- gets rid of undo
3210 information. */
3212 void
3213 gfc_commit_symbol (gfc_symbol *sym)
3215 gfc_symbol *p;
3216 unsigned i;
3218 enforce_single_undo_checkpoint ();
3220 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3221 if (p == sym)
3223 latest_undo_chgset->syms.unordered_remove (i);
3224 break;
3227 sym->mark = 0;
3228 sym->gfc_new = 0;
3230 free_old_symbol (sym);
3234 /* Recursively free trees containing type-bound procedures. */
3236 static void
3237 free_tb_tree (gfc_symtree *t)
3239 if (t == NULL)
3240 return;
3242 free_tb_tree (t->left);
3243 free_tb_tree (t->right);
3245 /* TODO: Free type-bound procedure structs themselves; probably needs some
3246 sort of ref-counting mechanism. */
3248 free (t);
3252 /* Recursive function that deletes an entire tree and all the common
3253 head structures it points to. */
3255 static void
3256 free_common_tree (gfc_symtree * common_tree)
3258 if (common_tree == NULL)
3259 return;
3261 free_common_tree (common_tree->left);
3262 free_common_tree (common_tree->right);
3264 free (common_tree);
3268 /* Recursive function that deletes an entire tree and all the user
3269 operator nodes that it contains. */
3271 static void
3272 free_uop_tree (gfc_symtree *uop_tree)
3274 if (uop_tree == NULL)
3275 return;
3277 free_uop_tree (uop_tree->left);
3278 free_uop_tree (uop_tree->right);
3280 gfc_free_interface (uop_tree->n.uop->op);
3281 free (uop_tree->n.uop);
3282 free (uop_tree);
3286 /* Recursive function that deletes an entire tree and all the symbols
3287 that it contains. */
3289 static void
3290 free_sym_tree (gfc_symtree *sym_tree)
3292 if (sym_tree == NULL)
3293 return;
3295 free_sym_tree (sym_tree->left);
3296 free_sym_tree (sym_tree->right);
3298 gfc_release_symbol (sym_tree->n.sym);
3299 free (sym_tree);
3303 /* Free the derived type list. */
3305 void
3306 gfc_free_dt_list (void)
3308 gfc_dt_list *dt, *n;
3310 for (dt = gfc_derived_types; dt; dt = n)
3312 n = dt->next;
3313 free (dt);
3316 gfc_derived_types = NULL;
3320 /* Free the gfc_equiv_info's. */
3322 static void
3323 gfc_free_equiv_infos (gfc_equiv_info *s)
3325 if (s == NULL)
3326 return;
3327 gfc_free_equiv_infos (s->next);
3328 free (s);
3332 /* Free the gfc_equiv_lists. */
3334 static void
3335 gfc_free_equiv_lists (gfc_equiv_list *l)
3337 if (l == NULL)
3338 return;
3339 gfc_free_equiv_lists (l->next);
3340 gfc_free_equiv_infos (l->equiv);
3341 free (l);
3345 /* Free a finalizer procedure list. */
3347 void
3348 gfc_free_finalizer (gfc_finalizer* el)
3350 if (el)
3352 gfc_release_symbol (el->proc_sym);
3353 free (el);
3357 static void
3358 gfc_free_finalizer_list (gfc_finalizer* list)
3360 while (list)
3362 gfc_finalizer* current = list;
3363 list = list->next;
3364 gfc_free_finalizer (current);
3369 /* Create a new gfc_charlen structure and add it to a namespace.
3370 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3372 gfc_charlen*
3373 gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3375 gfc_charlen *cl;
3376 cl = gfc_get_charlen ();
3378 /* Copy old_cl. */
3379 if (old_cl)
3381 /* Put into namespace, but don't allow reject_statement
3382 to free it if old_cl is given. */
3383 gfc_charlen **prev = &ns->cl_list;
3384 cl->next = ns->old_cl_list;
3385 while (*prev != ns->old_cl_list)
3386 prev = &(*prev)->next;
3387 *prev = cl;
3388 ns->old_cl_list = cl;
3389 cl->length = gfc_copy_expr (old_cl->length);
3390 cl->length_from_typespec = old_cl->length_from_typespec;
3391 cl->backend_decl = old_cl->backend_decl;
3392 cl->passed_length = old_cl->passed_length;
3393 cl->resolved = old_cl->resolved;
3395 else
3397 /* Put into namespace. */
3398 cl->next = ns->cl_list;
3399 ns->cl_list = cl;
3402 return cl;
3406 /* Free the charlen list from cl to end (end is not freed).
3407 Free the whole list if end is NULL. */
3409 void
3410 gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3412 gfc_charlen *cl2;
3414 for (; cl != end; cl = cl2)
3416 gcc_assert (cl);
3418 cl2 = cl->next;
3419 gfc_free_expr (cl->length);
3420 free (cl);
3425 /* Free entry list structs. */
3427 static void
3428 free_entry_list (gfc_entry_list *el)
3430 gfc_entry_list *next;
3432 if (el == NULL)
3433 return;
3435 next = el->next;
3436 free (el);
3437 free_entry_list (next);
3441 /* Free a namespace structure and everything below it. Interface
3442 lists associated with intrinsic operators are not freed. These are
3443 taken care of when a specific name is freed. */
3445 void
3446 gfc_free_namespace (gfc_namespace *ns)
3448 gfc_namespace *p, *q;
3449 int i;
3451 if (ns == NULL)
3452 return;
3454 ns->refs--;
3455 if (ns->refs > 0)
3456 return;
3457 gcc_assert (ns->refs == 0);
3459 gfc_free_statements (ns->code);
3461 free_sym_tree (ns->sym_root);
3462 free_uop_tree (ns->uop_root);
3463 free_common_tree (ns->common_root);
3464 free_tb_tree (ns->tb_sym_root);
3465 free_tb_tree (ns->tb_uop_root);
3466 gfc_free_finalizer_list (ns->finalizers);
3467 gfc_free_charlen (ns->cl_list, NULL);
3468 free_st_labels (ns->st_labels);
3470 free_entry_list (ns->entries);
3471 gfc_free_equiv (ns->equiv);
3472 gfc_free_equiv_lists (ns->equiv_lists);
3473 gfc_free_use_stmts (ns->use_stmts);
3475 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3476 gfc_free_interface (ns->op[i]);
3478 gfc_free_data (ns->data);
3479 p = ns->contained;
3480 free (ns);
3482 /* Recursively free any contained namespaces. */
3483 while (p != NULL)
3485 q = p;
3486 p = p->sibling;
3487 gfc_free_namespace (q);
3492 void
3493 gfc_symbol_init_2 (void)
3496 gfc_current_ns = gfc_get_namespace (NULL, 0);
3500 void
3501 gfc_symbol_done_2 (void)
3503 gfc_free_namespace (gfc_current_ns);
3504 gfc_current_ns = NULL;
3505 gfc_free_dt_list ();
3507 enforce_single_undo_checkpoint ();
3508 free_undo_change_set_data (*latest_undo_chgset);
3512 /* Count how many nodes a symtree has. */
3514 static unsigned
3515 count_st_nodes (const gfc_symtree *st)
3517 unsigned nodes;
3518 if (!st)
3519 return 0;
3521 nodes = count_st_nodes (st->left);
3522 nodes++;
3523 nodes += count_st_nodes (st->right);
3525 return nodes;
3529 /* Convert symtree tree into symtree vector. */
3531 static unsigned
3532 fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
3534 if (!st)
3535 return node_cntr;
3537 node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
3538 st_vec[node_cntr++] = st;
3539 node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
3541 return node_cntr;
3545 /* Traverse namespace. As the functions might modify the symtree, we store the
3546 symtree as a vector and operate on this vector. Note: We assume that
3547 sym_func or st_func never deletes nodes from the symtree - only adding is
3548 allowed. Additionally, newly added nodes are not traversed. */
3550 static void
3551 do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
3552 void (*sym_func) (gfc_symbol *))
3554 gfc_symtree **st_vec;
3555 unsigned nodes, i, node_cntr;
3557 gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
3558 nodes = count_st_nodes (st);
3559 st_vec = XALLOCAVEC (gfc_symtree *, nodes);
3560 node_cntr = 0;
3561 fill_st_vector (st, st_vec, node_cntr);
3563 if (sym_func)
3565 /* Clear marks. */
3566 for (i = 0; i < nodes; i++)
3567 st_vec[i]->n.sym->mark = 0;
3568 for (i = 0; i < nodes; i++)
3569 if (!st_vec[i]->n.sym->mark)
3571 (*sym_func) (st_vec[i]->n.sym);
3572 st_vec[i]->n.sym->mark = 1;
3575 else
3576 for (i = 0; i < nodes; i++)
3577 (*st_func) (st_vec[i]);
3581 /* Recursively traverse the symtree nodes. */
3583 void
3584 gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
3586 do_traverse_symtree (st, st_func, NULL);
3590 /* Call a given function for all symbols in the namespace. We take
3591 care that each gfc_symbol node is called exactly once. */
3593 void
3594 gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
3596 do_traverse_symtree (ns->sym_root, NULL, sym_func);
3600 /* Return TRUE when name is the name of an intrinsic type. */
3602 bool
3603 gfc_is_intrinsic_typename (const char *name)
3605 if (strcmp (name, "integer") == 0
3606 || strcmp (name, "real") == 0
3607 || strcmp (name, "character") == 0
3608 || strcmp (name, "logical") == 0
3609 || strcmp (name, "complex") == 0
3610 || strcmp (name, "doubleprecision") == 0
3611 || strcmp (name, "doublecomplex") == 0)
3612 return true;
3613 else
3614 return false;
3618 /* Return TRUE if the symbol is an automatic variable. */
3620 static bool
3621 gfc_is_var_automatic (gfc_symbol *sym)
3623 /* Pointer and allocatable variables are never automatic. */
3624 if (sym->attr.pointer || sym->attr.allocatable)
3625 return false;
3626 /* Check for arrays with non-constant size. */
3627 if (sym->attr.dimension && sym->as
3628 && !gfc_is_compile_time_shape (sym->as))
3629 return true;
3630 /* Check for non-constant length character variables. */
3631 if (sym->ts.type == BT_CHARACTER
3632 && sym->ts.u.cl
3633 && !gfc_is_constant_expr (sym->ts.u.cl->length))
3634 return true;
3635 return false;
3638 /* Given a symbol, mark it as SAVEd if it is allowed. */
3640 static void
3641 save_symbol (gfc_symbol *sym)
3644 if (sym->attr.use_assoc)
3645 return;
3647 if (sym->attr.in_common
3648 || sym->attr.dummy
3649 || sym->attr.result
3650 || sym->attr.flavor != FL_VARIABLE)
3651 return;
3652 /* Automatic objects are not saved. */
3653 if (gfc_is_var_automatic (sym))
3654 return;
3655 gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
3659 /* Mark those symbols which can be SAVEd as such. */
3661 void
3662 gfc_save_all (gfc_namespace *ns)
3664 gfc_traverse_ns (ns, save_symbol);
3668 /* Make sure that no changes to symbols are pending. */
3670 void
3671 gfc_enforce_clean_symbol_state(void)
3673 enforce_single_undo_checkpoint ();
3674 gcc_assert (latest_undo_chgset->syms.is_empty ());
3678 /************** Global symbol handling ************/
3681 /* Search a tree for the global symbol. */
3683 gfc_gsymbol *
3684 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3686 int c;
3688 if (symbol == NULL)
3689 return NULL;
3691 while (symbol)
3693 c = strcmp (name, symbol->name);
3694 if (!c)
3695 return symbol;
3697 symbol = (c < 0) ? symbol->left : symbol->right;
3700 return NULL;
3704 /* Compare two global symbols. Used for managing the BB tree. */
3706 static int
3707 gsym_compare (void *_s1, void *_s2)
3709 gfc_gsymbol *s1, *s2;
3711 s1 = (gfc_gsymbol *) _s1;
3712 s2 = (gfc_gsymbol *) _s2;
3713 return strcmp (s1->name, s2->name);
3717 /* Get a global symbol, creating it if it doesn't exist. */
3719 gfc_gsymbol *
3720 gfc_get_gsymbol (const char *name)
3722 gfc_gsymbol *s;
3724 s = gfc_find_gsymbol (gfc_gsym_root, name);
3725 if (s != NULL)
3726 return s;
3728 s = XCNEW (gfc_gsymbol);
3729 s->type = GSYM_UNKNOWN;
3730 s->name = gfc_get_string (name);
3732 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3734 return s;
3738 static gfc_symbol *
3739 get_iso_c_binding_dt (int sym_id)
3741 gfc_dt_list *dt_list;
3743 dt_list = gfc_derived_types;
3745 /* Loop through the derived types in the name list, searching for
3746 the desired symbol from iso_c_binding. Search the parent namespaces
3747 if necessary and requested to (parent_flag). */
3748 while (dt_list != NULL)
3750 if (dt_list->derived->from_intmod != INTMOD_NONE
3751 && dt_list->derived->intmod_sym_id == sym_id)
3752 return dt_list->derived;
3754 dt_list = dt_list->next;
3757 return NULL;
3761 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3762 with C. This is necessary for any derived type that is BIND(C) and for
3763 derived types that are parameters to functions that are BIND(C). All
3764 fields of the derived type are required to be interoperable, and are tested
3765 for such. If an error occurs, the errors are reported here, allowing for
3766 multiple errors to be handled for a single derived type. */
3768 bool
3769 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3771 gfc_component *curr_comp = NULL;
3772 bool is_c_interop = false;
3773 bool retval = true;
3775 if (derived_sym == NULL)
3776 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3777 "unexpectedly NULL");
3779 /* If we've already looked at this derived symbol, do not look at it again
3780 so we don't repeat warnings/errors. */
3781 if (derived_sym->ts.is_c_interop)
3782 return true;
3784 /* The derived type must have the BIND attribute to be interoperable
3785 J3/04-007, Section 15.2.3. */
3786 if (derived_sym->attr.is_bind_c != 1)
3788 derived_sym->ts.is_c_interop = 0;
3789 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3790 "attribute to be C interoperable", derived_sym->name,
3791 &(derived_sym->declared_at));
3792 retval = false;
3795 curr_comp = derived_sym->components;
3797 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
3798 empty struct. Section 15.2 in Fortran 2003 states: "The following
3799 subclauses define the conditions under which a Fortran entity is
3800 interoperable. If a Fortran entity is interoperable, an equivalent
3801 entity may be defined by means of C and the Fortran entity is said
3802 to be interoperable with the C entity. There does not have to be such
3803 an interoperating C entity."
3805 if (curr_comp == NULL)
3807 gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
3808 "and may be inaccessible by the C companion processor",
3809 derived_sym->name, &(derived_sym->declared_at));
3810 derived_sym->ts.is_c_interop = 1;
3811 derived_sym->attr.is_bind_c = 1;
3812 return true;
3816 /* Initialize the derived type as being C interoperable.
3817 If we find an error in the components, this will be set false. */
3818 derived_sym->ts.is_c_interop = 1;
3820 /* Loop through the list of components to verify that the kind of
3821 each is a C interoperable type. */
3824 /* The components cannot be pointers (fortran sense).
3825 J3/04-007, Section 15.2.3, C1505. */
3826 if (curr_comp->attr.pointer != 0)
3828 gfc_error ("Component '%s' at %L cannot have the "
3829 "POINTER attribute because it is a member "
3830 "of the BIND(C) derived type '%s' at %L",
3831 curr_comp->name, &(curr_comp->loc),
3832 derived_sym->name, &(derived_sym->declared_at));
3833 retval = false;
3836 if (curr_comp->attr.proc_pointer != 0)
3838 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3839 " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3840 &curr_comp->loc, derived_sym->name,
3841 &derived_sym->declared_at);
3842 retval = false;
3845 /* The components cannot be allocatable.
3846 J3/04-007, Section 15.2.3, C1505. */
3847 if (curr_comp->attr.allocatable != 0)
3849 gfc_error ("Component '%s' at %L cannot have the "
3850 "ALLOCATABLE attribute because it is a member "
3851 "of the BIND(C) derived type '%s' at %L",
3852 curr_comp->name, &(curr_comp->loc),
3853 derived_sym->name, &(derived_sym->declared_at));
3854 retval = false;
3857 /* BIND(C) derived types must have interoperable components. */
3858 if (curr_comp->ts.type == BT_DERIVED
3859 && curr_comp->ts.u.derived->ts.is_iso_c != 1
3860 && curr_comp->ts.u.derived != derived_sym)
3862 /* This should be allowed; the draft says a derived-type can not
3863 have type parameters if it is has the BIND attribute. Type
3864 parameters seem to be for making parameterized derived types.
3865 There's no need to verify the type if it is c_ptr/c_funptr. */
3866 retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3868 else
3870 /* Grab the typespec for the given component and test the kind. */
3871 is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
3873 if (!is_c_interop)
3875 /* Report warning and continue since not fatal. The
3876 draft does specify a constraint that requires all fields
3877 to interoperate, but if the user says real(4), etc., it
3878 may interoperate with *something* in C, but the compiler
3879 most likely won't know exactly what. Further, it may not
3880 interoperate with the same data type(s) in C if the user
3881 recompiles with different flags (e.g., -m32 and -m64 on
3882 x86_64 and using integer(4) to claim interop with a
3883 C_LONG). */
3884 if (derived_sym->attr.is_bind_c == 1
3885 && gfc_option.warn_c_binding_type)
3886 /* If the derived type is bind(c), all fields must be
3887 interop. */
3888 gfc_warning ("Component '%s' in derived type '%s' at %L "
3889 "may not be C interoperable, even though "
3890 "derived type '%s' is BIND(C)",
3891 curr_comp->name, derived_sym->name,
3892 &(curr_comp->loc), derived_sym->name);
3893 else if (gfc_option.warn_c_binding_type)
3894 /* If derived type is param to bind(c) routine, or to one
3895 of the iso_c_binding procs, it must be interoperable, so
3896 all fields must interop too. */
3897 gfc_warning ("Component '%s' in derived type '%s' at %L "
3898 "may not be C interoperable",
3899 curr_comp->name, derived_sym->name,
3900 &(curr_comp->loc));
3904 curr_comp = curr_comp->next;
3905 } while (curr_comp != NULL);
3908 /* Make sure we don't have conflicts with the attributes. */
3909 if (derived_sym->attr.access == ACCESS_PRIVATE)
3911 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3912 "PRIVATE and BIND(C) attributes", derived_sym->name,
3913 &(derived_sym->declared_at));
3914 retval = false;
3917 if (derived_sym->attr.sequence != 0)
3919 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3920 "attribute because it is BIND(C)", derived_sym->name,
3921 &(derived_sym->declared_at));
3922 retval = false;
3925 /* Mark the derived type as not being C interoperable if we found an
3926 error. If there were only warnings, proceed with the assumption
3927 it's interoperable. */
3928 if (!retval)
3929 derived_sym->ts.is_c_interop = 0;
3931 return retval;
3935 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3937 static bool
3938 gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree)
3940 gfc_constructor *c;
3942 gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym);
3943 dt_symtree->n.sym->attr.referenced = 1;
3945 tmp_sym->attr.is_c_interop = 1;
3946 tmp_sym->attr.is_bind_c = 1;
3947 tmp_sym->ts.is_c_interop = 1;
3948 tmp_sym->ts.is_iso_c = 1;
3949 tmp_sym->ts.type = BT_DERIVED;
3950 tmp_sym->ts.f90_type = BT_VOID;
3951 tmp_sym->attr.flavor = FL_PARAMETER;
3952 tmp_sym->ts.u.derived = dt_symtree->n.sym;
3954 /* Set the c_address field of c_null_ptr and c_null_funptr to
3955 the value of NULL. */
3956 tmp_sym->value = gfc_get_expr ();
3957 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3958 tmp_sym->value->ts.type = BT_DERIVED;
3959 tmp_sym->value->ts.f90_type = BT_VOID;
3960 tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
3961 gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
3962 c = gfc_constructor_first (tmp_sym->value->value.constructor);
3963 c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
3964 c->expr->ts.is_iso_c = 1;
3966 return true;
3970 /* Add a formal argument, gfc_formal_arglist, to the
3971 end of the given list of arguments. Set the reference to the
3972 provided symbol, param_sym, in the argument. */
3974 static void
3975 add_formal_arg (gfc_formal_arglist **head,
3976 gfc_formal_arglist **tail,
3977 gfc_formal_arglist *formal_arg,
3978 gfc_symbol *param_sym)
3980 /* Put in list, either as first arg or at the tail (curr arg). */
3981 if (*head == NULL)
3982 *head = *tail = formal_arg;
3983 else
3985 (*tail)->next = formal_arg;
3986 (*tail) = formal_arg;
3989 (*tail)->sym = param_sym;
3990 (*tail)->next = NULL;
3992 return;
3996 /* Add a procedure interface to the given symbol (i.e., store a
3997 reference to the list of formal arguments). */
3999 static void
4000 add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
4003 sym->formal = formal;
4004 sym->attr.if_source = source;
4008 /* Copy the formal args from an existing symbol, src, into a new
4009 symbol, dest. New formal args are created, and the description of
4010 each arg is set according to the existing ones. This function is
4011 used when creating procedure declaration variables from a procedure
4012 declaration statement (see match_proc_decl()) to create the formal
4013 args based on the args of a given named interface. */
4015 void
4016 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
4018 gfc_formal_arglist *head = NULL;
4019 gfc_formal_arglist *tail = NULL;
4020 gfc_formal_arglist *formal_arg = NULL;
4021 gfc_intrinsic_arg *curr_arg = NULL;
4022 gfc_formal_arglist *formal_prev = NULL;
4023 /* Save current namespace so we can change it for formal args. */
4024 gfc_namespace *parent_ns = gfc_current_ns;
4026 /* Create a new namespace, which will be the formal ns (namespace
4027 of the formal args). */
4028 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4029 gfc_current_ns->proc_name = dest;
4031 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4033 formal_arg = gfc_get_formal_arglist ();
4034 gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4036 /* May need to copy more info for the symbol. */
4037 formal_arg->sym->ts = curr_arg->ts;
4038 formal_arg->sym->attr.optional = curr_arg->optional;
4039 formal_arg->sym->attr.value = curr_arg->value;
4040 formal_arg->sym->attr.intent = curr_arg->intent;
4041 formal_arg->sym->attr.flavor = FL_VARIABLE;
4042 formal_arg->sym->attr.dummy = 1;
4044 if (formal_arg->sym->ts.type == BT_CHARACTER)
4045 formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4047 /* If this isn't the first arg, set up the next ptr. For the
4048 last arg built, the formal_arg->next will never get set to
4049 anything other than NULL. */
4050 if (formal_prev != NULL)
4051 formal_prev->next = formal_arg;
4052 else
4053 formal_arg->next = NULL;
4055 formal_prev = formal_arg;
4057 /* Add arg to list of formal args. */
4058 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4060 /* Validate changes. */
4061 gfc_commit_symbol (formal_arg->sym);
4064 /* Add the interface to the symbol. */
4065 add_proc_interface (dest, IFSRC_DECL, head);
4067 /* Store the formal namespace information. */
4068 if (dest->formal != NULL)
4069 /* The current ns should be that for the dest proc. */
4070 dest->formal_ns = gfc_current_ns;
4071 /* Restore the current namespace to what it was on entry. */
4072 gfc_current_ns = parent_ns;
4076 static int
4077 std_for_isocbinding_symbol (int id)
4079 switch (id)
4081 #define NAMED_INTCST(a,b,c,d) \
4082 case a:\
4083 return d;
4084 #include "iso-c-binding.def"
4085 #undef NAMED_INTCST
4087 #define NAMED_FUNCTION(a,b,c,d) \
4088 case a:\
4089 return d;
4090 #define NAMED_SUBROUTINE(a,b,c,d) \
4091 case a:\
4092 return d;
4093 #include "iso-c-binding.def"
4094 #undef NAMED_FUNCTION
4095 #undef NAMED_SUBROUTINE
4097 default:
4098 return GFC_STD_F2003;
4102 /* Generate the given set of C interoperable kind objects, or all
4103 interoperable kinds. This function will only be given kind objects
4104 for valid iso_c_binding defined types because this is verified when
4105 the 'use' statement is parsed. If the user gives an 'only' clause,
4106 the specific kinds are looked up; if they don't exist, an error is
4107 reported. If the user does not give an 'only' clause, all
4108 iso_c_binding symbols are generated. If a list of specific kinds
4109 is given, it must have a NULL in the first empty spot to mark the
4110 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4111 point to the symtree for c_(fun)ptr. */
4113 gfc_symtree *
4114 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4115 const char *local_name, gfc_symtree *dt_symtree,
4116 bool hidden)
4118 const char *const name = (local_name && local_name[0])
4119 ? local_name : c_interop_kinds_table[s].name;
4120 gfc_symtree *tmp_symtree;
4121 gfc_symbol *tmp_sym = NULL;
4122 int index;
4124 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4125 return NULL;
4127 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4128 if (hidden
4129 && (!tmp_symtree || !tmp_symtree->n.sym
4130 || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING
4131 || tmp_symtree->n.sym->intmod_sym_id != s))
4132 tmp_symtree = NULL;
4134 /* Already exists in this scope so don't re-add it. */
4135 if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
4136 && (!tmp_sym->attr.generic
4137 || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
4138 && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
4140 if (tmp_sym->attr.flavor == FL_DERIVED
4141 && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
4143 gfc_dt_list *dt_list;
4144 dt_list = gfc_get_dt_list ();
4145 dt_list->derived = tmp_sym;
4146 dt_list->next = gfc_derived_types;
4147 gfc_derived_types = dt_list;
4150 return tmp_symtree;
4153 /* Create the sym tree in the current ns. */
4154 if (hidden)
4156 tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
4157 tmp_sym = gfc_new_symbol (name, gfc_current_ns);
4159 /* Add to the list of tentative symbols. */
4160 latest_undo_chgset->syms.safe_push (tmp_sym);
4161 tmp_sym->old_symbol = NULL;
4162 tmp_sym->mark = 1;
4163 tmp_sym->gfc_new = 1;
4165 tmp_symtree->n.sym = tmp_sym;
4166 tmp_sym->refs++;
4168 else
4170 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4171 gcc_assert (tmp_symtree);
4172 tmp_sym = tmp_symtree->n.sym;
4175 /* Say what module this symbol belongs to. */
4176 tmp_sym->module = gfc_get_string (mod_name);
4177 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4178 tmp_sym->intmod_sym_id = s;
4179 tmp_sym->attr.is_iso_c = 1;
4180 tmp_sym->attr.use_assoc = 1;
4182 gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR
4183 || s == ISOCBINDING_NULL_PTR);
4185 switch (s)
4188 #define NAMED_INTCST(a,b,c,d) case a :
4189 #define NAMED_REALCST(a,b,c,d) case a :
4190 #define NAMED_CMPXCST(a,b,c,d) case a :
4191 #define NAMED_LOGCST(a,b,c) case a :
4192 #define NAMED_CHARKNDCST(a,b,c) case a :
4193 #include "iso-c-binding.def"
4195 tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4196 c_interop_kinds_table[s].value);
4198 /* Initialize an integer constant expression node. */
4199 tmp_sym->attr.flavor = FL_PARAMETER;
4200 tmp_sym->ts.type = BT_INTEGER;
4201 tmp_sym->ts.kind = gfc_default_integer_kind;
4203 /* Mark this type as a C interoperable one. */
4204 tmp_sym->ts.is_c_interop = 1;
4205 tmp_sym->ts.is_iso_c = 1;
4206 tmp_sym->value->ts.is_c_interop = 1;
4207 tmp_sym->value->ts.is_iso_c = 1;
4208 tmp_sym->attr.is_c_interop = 1;
4210 /* Tell what f90 type this c interop kind is valid. */
4211 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4213 break;
4216 #define NAMED_CHARCST(a,b,c) case a :
4217 #include "iso-c-binding.def"
4219 /* Initialize an integer constant expression node for the
4220 length of the character. */
4221 tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
4222 &gfc_current_locus, NULL, 1);
4223 tmp_sym->value->ts.is_c_interop = 1;
4224 tmp_sym->value->ts.is_iso_c = 1;
4225 tmp_sym->value->value.character.length = 1;
4226 tmp_sym->value->value.character.string[0]
4227 = (gfc_char_t) c_interop_kinds_table[s].value;
4228 tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4229 tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
4230 NULL, 1);
4232 /* May not need this in both attr and ts, but do need in
4233 attr for writing module file. */
4234 tmp_sym->attr.is_c_interop = 1;
4236 tmp_sym->attr.flavor = FL_PARAMETER;
4237 tmp_sym->ts.type = BT_CHARACTER;
4239 /* Need to set it to the C_CHAR kind. */
4240 tmp_sym->ts.kind = gfc_default_character_kind;
4242 /* Mark this type as a C interoperable one. */
4243 tmp_sym->ts.is_c_interop = 1;
4244 tmp_sym->ts.is_iso_c = 1;
4246 /* Tell what f90 type this c interop kind is valid. */
4247 tmp_sym->ts.f90_type = BT_CHARACTER;
4249 break;
4251 case ISOCBINDING_PTR:
4252 case ISOCBINDING_FUNPTR:
4254 gfc_symbol *dt_sym;
4255 gfc_dt_list **dt_list_ptr = NULL;
4256 gfc_component *tmp_comp = NULL;
4258 /* Generate real derived type. */
4259 if (hidden)
4260 dt_sym = tmp_sym;
4261 else
4263 const char *hidden_name;
4264 gfc_interface *intr, *head;
4266 hidden_name = gfc_get_string ("%c%s",
4267 (char) TOUPPER ((unsigned char)
4268 tmp_sym->name[0]),
4269 &tmp_sym->name[1]);
4270 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4271 hidden_name);
4272 gcc_assert (tmp_symtree == NULL);
4273 gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
4274 dt_sym = tmp_symtree->n.sym;
4275 dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR
4276 ? "c_ptr" : "c_funptr");
4278 /* Generate an artificial generic function. */
4279 head = tmp_sym->generic;
4280 intr = gfc_get_interface ();
4281 intr->sym = dt_sym;
4282 intr->where = gfc_current_locus;
4283 intr->next = head;
4284 tmp_sym->generic = intr;
4286 if (!tmp_sym->attr.generic
4287 && !gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL))
4288 return NULL;
4290 if (!tmp_sym->attr.function
4291 && !gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL))
4292 return NULL;
4295 /* Say what module this symbol belongs to. */
4296 dt_sym->module = gfc_get_string (mod_name);
4297 dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
4298 dt_sym->intmod_sym_id = s;
4299 dt_sym->attr.use_assoc = 1;
4301 /* Initialize an integer constant expression node. */
4302 dt_sym->attr.flavor = FL_DERIVED;
4303 dt_sym->ts.is_c_interop = 1;
4304 dt_sym->attr.is_c_interop = 1;
4305 dt_sym->attr.private_comp = 1;
4306 dt_sym->component_access = ACCESS_PRIVATE;
4307 dt_sym->ts.is_iso_c = 1;
4308 dt_sym->ts.type = BT_DERIVED;
4309 dt_sym->ts.f90_type = BT_VOID;
4311 /* A derived type must have the bind attribute to be
4312 interoperable (J3/04-007, Section 15.2.3), even though
4313 the binding label is not used. */
4314 dt_sym->attr.is_bind_c = 1;
4316 dt_sym->attr.referenced = 1;
4317 dt_sym->ts.u.derived = dt_sym;
4319 /* Add the symbol created for the derived type to the current ns. */
4320 dt_list_ptr = &(gfc_derived_types);
4321 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4322 dt_list_ptr = &((*dt_list_ptr)->next);
4324 /* There is already at least one derived type in the list, so append
4325 the one we're currently building for c_ptr or c_funptr. */
4326 if (*dt_list_ptr != NULL)
4327 dt_list_ptr = &((*dt_list_ptr)->next);
4328 (*dt_list_ptr) = gfc_get_dt_list ();
4329 (*dt_list_ptr)->derived = dt_sym;
4330 (*dt_list_ptr)->next = NULL;
4332 gfc_add_component (dt_sym, "c_address", &tmp_comp);
4333 if (tmp_comp == NULL)
4334 gcc_unreachable ();
4336 tmp_comp->ts.type = BT_INTEGER;
4338 /* Set this because the module will need to read/write this field. */
4339 tmp_comp->ts.f90_type = BT_INTEGER;
4341 /* The kinds for c_ptr and c_funptr are the same. */
4342 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4343 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4344 tmp_comp->attr.access = ACCESS_PRIVATE;
4346 /* Mark the component as C interoperable. */
4347 tmp_comp->ts.is_c_interop = 1;
4350 break;
4352 case ISOCBINDING_NULL_PTR:
4353 case ISOCBINDING_NULL_FUNPTR:
4354 gen_special_c_interop_ptr (tmp_sym, dt_symtree);
4355 break;
4357 default:
4358 gcc_unreachable ();
4360 gfc_commit_symbol (tmp_sym);
4361 return tmp_symtree;
4365 /* Check that a symbol is already typed. If strict is not set, an untyped
4366 symbol is acceptable for non-standard-conforming mode. */
4368 bool
4369 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4370 bool strict, locus where)
4372 gcc_assert (sym);
4374 if (gfc_matching_prefix)
4375 return true;
4377 /* Check for the type and try to give it an implicit one. */
4378 if (sym->ts.type == BT_UNKNOWN
4379 && !gfc_set_default_type (sym, 0, ns))
4381 if (strict)
4383 gfc_error ("Symbol '%s' is used before it is typed at %L",
4384 sym->name, &where);
4385 return false;
4388 if (!gfc_notify_std (GFC_STD_GNU, "Symbol '%s' is used before"
4389 " it is typed at %L", sym->name, &where))
4390 return false;
4393 /* Everything is ok. */
4394 return true;
4398 /* Construct a typebound-procedure structure. Those are stored in a tentative
4399 list and marked `error' until symbols are committed. */
4401 gfc_typebound_proc*
4402 gfc_get_typebound_proc (gfc_typebound_proc *tb0)
4404 gfc_typebound_proc *result;
4406 result = XCNEW (gfc_typebound_proc);
4407 if (tb0)
4408 *result = *tb0;
4409 result->error = 1;
4411 latest_undo_chgset->tbps.safe_push (result);
4413 return result;
4417 /* Get the super-type of a given derived type. */
4419 gfc_symbol*
4420 gfc_get_derived_super_type (gfc_symbol* derived)
4422 gcc_assert (derived);
4424 if (derived->attr.generic)
4425 derived = gfc_find_dt_in_generic (derived);
4427 if (!derived->attr.extension)
4428 return NULL;
4430 gcc_assert (derived->components);
4431 gcc_assert (derived->components->ts.type == BT_DERIVED);
4432 gcc_assert (derived->components->ts.u.derived);
4434 if (derived->components->ts.u.derived->attr.generic)
4435 return gfc_find_dt_in_generic (derived->components->ts.u.derived);
4437 return derived->components->ts.u.derived;
4441 /* Get the ultimate super-type of a given derived type. */
4443 gfc_symbol*
4444 gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
4446 if (!derived->attr.extension)
4447 return NULL;
4449 derived = gfc_get_derived_super_type (derived);
4451 if (derived->attr.extension)
4452 return gfc_get_ultimate_derived_super_type (derived);
4453 else
4454 return derived;
4458 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4460 bool
4461 gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
4463 while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
4464 t2 = gfc_get_derived_super_type (t2);
4465 return gfc_compare_derived_types (t1, t2);
4469 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4470 If ts1 is nonpolymorphic, ts2 must be the same type.
4471 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4473 bool
4474 gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
4476 bool is_class1 = (ts1->type == BT_CLASS);
4477 bool is_class2 = (ts2->type == BT_CLASS);
4478 bool is_derived1 = (ts1->type == BT_DERIVED);
4479 bool is_derived2 = (ts2->type == BT_DERIVED);
4481 if (is_class1
4482 && ts1->u.derived->components
4483 && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
4484 return 1;
4486 if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
4487 return (ts1->type == ts2->type);
4489 if (is_derived1 && is_derived2)
4490 return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
4492 if (is_derived1 && is_class2)
4493 return gfc_compare_derived_types (ts1->u.derived,
4494 ts2->u.derived->components->ts.u.derived);
4495 if (is_class1 && is_derived2)
4496 return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4497 ts2->u.derived);
4498 else if (is_class1 && is_class2)
4499 return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4500 ts2->u.derived->components->ts.u.derived);
4501 else
4502 return 0;
4506 /* Find the parent-namespace of the current function. If we're inside
4507 BLOCK constructs, it may not be the current one. */
4509 gfc_namespace*
4510 gfc_find_proc_namespace (gfc_namespace* ns)
4512 while (ns->construct_entities)
4514 ns = ns->parent;
4515 gcc_assert (ns);
4518 return ns;
4522 /* Check if an associate-variable should be translated as an `implicit' pointer
4523 internally (if it is associated to a variable and not an array with
4524 descriptor). */
4526 bool
4527 gfc_is_associate_pointer (gfc_symbol* sym)
4529 if (!sym->assoc)
4530 return false;
4532 if (sym->ts.type == BT_CLASS)
4533 return true;
4535 if (!sym->assoc->variable)
4536 return false;
4538 if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
4539 return false;
4541 return true;
4545 gfc_symbol *
4546 gfc_find_dt_in_generic (gfc_symbol *sym)
4548 gfc_interface *intr = NULL;
4550 if (!sym || sym->attr.flavor == FL_DERIVED)
4551 return sym;
4553 if (sym->attr.generic)
4554 for (intr = sym->generic; intr; intr = intr->next)
4555 if (intr->sym->attr.flavor == FL_DERIVED)
4556 break;
4557 return intr ? intr->sym : NULL;
4561 /* Get the dummy arguments from a procedure symbol. If it has been declared
4562 via a PROCEDURE statement with a named interface, ts.interface will be set
4563 and the arguments need to be taken from there. */
4565 gfc_formal_arglist *
4566 gfc_sym_get_dummy_args (gfc_symbol *sym)
4568 gfc_formal_arglist *dummies;
4570 dummies = sym->formal;
4571 if (dummies == NULL && sym->ts.interface != NULL)
4572 dummies = sym->ts.interface->formal;
4574 return dummies;