1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000-2014 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
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
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/>. */
24 #include "coretypes.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
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),
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),
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),
67 const mstring access_types[] =
69 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
70 minit ("PUBLIC", ACCESS_PUBLIC),
71 minit ("PRIVATE", ACCESS_PRIVATE),
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
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. */
117 gfc_set_implicit_none (bool type, bool external)
121 if (gfc_current_ns->seen_implicit_none
122 || gfc_current_ns->has_implicit_none_export)
124 gfc_error_now ("Duplicate IMPLICIT NONE statement at %C");
129 gfc_current_ns->has_implicit_none_export = 1;
133 gfc_current_ns->seen_implicit_none = 1;
134 for (i = 0; i < GFC_LETTERS; i++)
136 if (gfc_current_ns->set_flag[i])
138 gfc_error_now ("IMPLICIT NONE (type) statement at %C following an "
139 "IMPLICIT statement");
142 gfc_clear_ts (&gfc_current_ns->default_type[i]);
143 gfc_current_ns->set_flag[i] = 1;
149 /* Reset the implicit range flags. */
152 gfc_clear_new_implicit (void)
156 for (i = 0; i < GFC_LETTERS; i++)
161 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
164 gfc_add_new_implicit_range (int c1, int c2)
171 for (i = c1; i <= c2; i++)
175 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
187 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
188 the new implicit types back into the existing types will work. */
191 gfc_merge_new_implicit (gfc_typespec *ts)
195 if (gfc_current_ns->seen_implicit_none)
197 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
201 for (i = 0; i < GFC_LETTERS; i++)
205 if (gfc_current_ns->set_flag[i])
207 gfc_error ("Letter %c already has an IMPLICIT type at %C",
212 gfc_current_ns->default_type[i] = *ts;
213 gfc_current_ns->implicit_loc[i] = gfc_current_locus;
214 gfc_current_ns->set_flag[i] = 1;
221 /* Given a symbol, return a pointer to the typespec for its default type. */
224 gfc_get_default_type (const char *name, gfc_namespace *ns)
230 if (gfc_option.flag_allow_leading_underscore && letter == '_')
231 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
232 "gfortran developers, and should not be used for "
233 "implicitly typed variables");
235 if (letter < 'a' || letter > 'z')
236 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
241 return &ns->default_type[letter - 'a'];
245 /* Given a pointer to a symbol, set its type according to the first
246 letter of its name. Fails if the letter in question has no default
250 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
254 if (sym->ts.type != BT_UNKNOWN)
255 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
257 ts = gfc_get_default_type (sym->name, ns);
259 if (ts->type == BT_UNKNOWN)
261 if (error_flag && !sym->attr.untyped)
263 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
264 sym->name, &sym->declared_at);
265 sym->attr.untyped = 1; /* Ensure we only give an error once. */
272 sym->attr.implicit_type = 1;
274 if (ts->type == BT_CHARACTER && ts->u.cl)
275 sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
276 else if (ts->type == BT_CLASS
277 && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
280 if (sym->attr.is_bind_c == 1 && gfc_option.warn_c_binding_type)
282 /* BIND(C) variables should not be implicitly declared. */
283 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
284 "not be C interoperable", sym->name, &sym->declared_at);
285 sym->ts.f90_type = sym->ts.type;
288 if (sym->attr.dummy != 0)
290 if (sym->ns->proc_name != NULL
291 && (sym->ns->proc_name->attr.subroutine != 0
292 || sym->ns->proc_name->attr.function != 0)
293 && sym->ns->proc_name->attr.is_bind_c != 0
294 && gfc_option.warn_c_binding_type)
296 /* Dummy args to a BIND(C) routine may not be interoperable if
297 they are implicitly typed. */
298 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
299 "be C interoperable but it is a dummy argument to "
300 "the BIND(C) procedure '%s' at %L", sym->name,
301 &(sym->declared_at), sym->ns->proc_name->name,
302 &(sym->ns->proc_name->declared_at));
303 sym->ts.f90_type = sym->ts.type;
311 /* This function is called from parse.c(parse_progunit) to check the
312 type of the function is not implicitly typed in the host namespace
313 and to implicitly type the function result, if necessary. */
316 gfc_check_function_type (gfc_namespace *ns)
318 gfc_symbol *proc = ns->proc_name;
320 if (!proc->attr.contained || proc->result->attr.implicit_type)
323 if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
325 if (gfc_set_default_type (proc->result, 0, gfc_current_ns))
327 if (proc->result != proc)
329 proc->ts = proc->result->ts;
330 proc->as = gfc_copy_array_spec (proc->result->as);
331 proc->attr.dimension = proc->result->attr.dimension;
332 proc->attr.pointer = proc->result->attr.pointer;
333 proc->attr.allocatable = proc->result->attr.allocatable;
336 else if (!proc->result->attr.proc_pointer)
338 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
339 proc->result->name, &proc->result->declared_at);
340 proc->result->attr.untyped = 1;
346 /******************** Symbol attribute stuff *********************/
348 /* This is a generic conflict-checker. We do this to avoid having a
349 single conflict in two places. */
351 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
352 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
353 #define conf_std(a, b, std) if (attr->a && attr->b)\
362 check_conflict (symbol_attribute *attr, const char *name, locus *where)
364 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
365 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
366 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
367 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
368 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
369 *privat = "PRIVATE", *recursive = "RECURSIVE",
370 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
371 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
372 *function = "FUNCTION", *subroutine = "SUBROUTINE",
373 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
374 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
375 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
376 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
377 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
378 *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT",
379 *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
380 *contiguous = "CONTIGUOUS", *generic = "GENERIC";
381 static const char *threadprivate = "THREADPRIVATE";
382 static const char *omp_declare_target = "OMP DECLARE TARGET";
388 where = &gfc_current_locus;
390 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
394 standard = GFC_STD_F2003;
398 if (attr->in_namelist && (attr->allocatable || attr->pointer))
401 a2 = attr->allocatable ? allocatable : pointer;
402 standard = GFC_STD_F2003;
406 /* Check for attributes not allowed in a BLOCK DATA. */
407 if (gfc_current_state () == COMP_BLOCK_DATA)
411 if (attr->in_namelist)
413 if (attr->allocatable)
419 if (attr->access == ACCESS_PRIVATE)
421 if (attr->access == ACCESS_PUBLIC)
423 if (attr->intent != INTENT_UNKNOWN)
429 ("%s attribute not allowed in BLOCK DATA program unit at %L",
435 if (attr->save == SAVE_EXPLICIT)
438 conf (in_common, save);
441 switch (attr->flavor)
449 a1 = gfc_code2string (flavors, attr->flavor);
453 gfc_error ("Namelist group name at %L cannot have the "
454 "SAVE attribute", where);
458 /* Conflicts between SAVE and PROCEDURE will be checked at
459 resolution stage, see "resolve_fl_procedure". */
467 conf (dummy, intrinsic);
468 conf (dummy, threadprivate);
469 conf (dummy, omp_declare_target);
470 conf (pointer, target);
471 conf (pointer, intrinsic);
472 conf (pointer, elemental);
473 conf (pointer, codimension);
474 conf (allocatable, elemental);
476 conf (target, external);
477 conf (target, intrinsic);
479 if (!attr->if_source)
480 conf (external, dimension); /* See Fortran 95's R504. */
482 conf (external, intrinsic);
483 conf (entry, intrinsic);
485 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
486 conf (external, subroutine);
488 if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003,
489 "Procedure pointer at %C"))
492 conf (allocatable, pointer);
493 conf_std (allocatable, dummy, GFC_STD_F2003);
494 conf_std (allocatable, function, GFC_STD_F2003);
495 conf_std (allocatable, result, GFC_STD_F2003);
496 conf (elemental, recursive);
498 conf (in_common, dummy);
499 conf (in_common, allocatable);
500 conf (in_common, codimension);
501 conf (in_common, result);
503 conf (in_equivalence, use_assoc);
504 conf (in_equivalence, codimension);
505 conf (in_equivalence, dummy);
506 conf (in_equivalence, target);
507 conf (in_equivalence, pointer);
508 conf (in_equivalence, function);
509 conf (in_equivalence, result);
510 conf (in_equivalence, entry);
511 conf (in_equivalence, allocatable);
512 conf (in_equivalence, threadprivate);
513 conf (in_equivalence, omp_declare_target);
515 conf (dummy, result);
516 conf (entry, result);
517 conf (generic, result);
519 conf (function, subroutine);
521 if (!function && !subroutine)
522 conf (is_bind_c, dummy);
524 conf (is_bind_c, cray_pointer);
525 conf (is_bind_c, cray_pointee);
526 conf (is_bind_c, codimension);
527 conf (is_bind_c, allocatable);
528 conf (is_bind_c, elemental);
530 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
531 Parameter conflict caught below. Also, value cannot be specified
532 for a dummy procedure. */
534 /* Cray pointer/pointee conflicts. */
535 conf (cray_pointer, cray_pointee);
536 conf (cray_pointer, dimension);
537 conf (cray_pointer, codimension);
538 conf (cray_pointer, contiguous);
539 conf (cray_pointer, pointer);
540 conf (cray_pointer, target);
541 conf (cray_pointer, allocatable);
542 conf (cray_pointer, external);
543 conf (cray_pointer, intrinsic);
544 conf (cray_pointer, in_namelist);
545 conf (cray_pointer, function);
546 conf (cray_pointer, subroutine);
547 conf (cray_pointer, entry);
549 conf (cray_pointee, allocatable);
550 conf (cray_pointee, contiguous);
551 conf (cray_pointee, codimension);
552 conf (cray_pointee, intent);
553 conf (cray_pointee, optional);
554 conf (cray_pointee, dummy);
555 conf (cray_pointee, target);
556 conf (cray_pointee, intrinsic);
557 conf (cray_pointee, pointer);
558 conf (cray_pointee, entry);
559 conf (cray_pointee, in_common);
560 conf (cray_pointee, in_equivalence);
561 conf (cray_pointee, threadprivate);
562 conf (cray_pointee, omp_declare_target);
565 conf (data, function);
567 conf (data, allocatable);
569 conf (value, pointer)
570 conf (value, allocatable)
571 conf (value, subroutine)
572 conf (value, function)
573 conf (value, volatile_)
574 conf (value, dimension)
575 conf (value, codimension)
576 conf (value, external)
578 conf (codimension, result)
581 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
584 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
588 conf (is_protected, intrinsic)
589 conf (is_protected, in_common)
591 conf (asynchronous, intrinsic)
592 conf (asynchronous, external)
594 conf (volatile_, intrinsic)
595 conf (volatile_, external)
597 if (attr->volatile_ && attr->intent == INTENT_IN)
604 conf (procedure, allocatable)
605 conf (procedure, dimension)
606 conf (procedure, codimension)
607 conf (procedure, intrinsic)
608 conf (procedure, target)
609 conf (procedure, value)
610 conf (procedure, volatile_)
611 conf (procedure, asynchronous)
612 conf (procedure, entry)
614 conf (proc_pointer, abstract)
616 conf (entry, omp_declare_target)
618 a1 = gfc_code2string (flavors, attr->flavor);
620 if (attr->in_namelist
621 && attr->flavor != FL_VARIABLE
622 && attr->flavor != FL_PROCEDURE
623 && attr->flavor != FL_UNKNOWN)
629 switch (attr->flavor)
639 conf2 (asynchronous);
642 conf2 (is_protected);
652 conf2 (threadprivate);
653 conf2 (omp_declare_target);
655 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
657 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
658 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
665 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
679 /* Conflicts with INTENT, SAVE and RESULT will be checked
680 at resolution stage, see "resolve_fl_procedure". */
682 if (attr->subroutine)
688 conf2 (asynchronous);
693 if (!attr->proc_pointer)
694 conf2 (threadprivate);
697 if (!attr->proc_pointer)
702 case PROC_ST_FUNCTION:
713 conf2 (threadprivate);
733 conf2 (threadprivate);
735 conf2 (omp_declare_target);
737 if (attr->intent != INTENT_UNKNOWN)
754 conf2 (is_protected);
760 conf2 (asynchronous);
761 conf2 (threadprivate);
777 gfc_error ("%s attribute conflicts with %s attribute at %L",
780 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
781 a1, a2, name, where);
788 return gfc_notify_std (standard, "%s attribute "
789 "with %s attribute at %L", a1, a2,
794 return gfc_notify_std (standard, "%s attribute "
795 "with %s attribute in '%s' at %L",
796 a1, a2, name, where);
805 /* Mark a symbol as referenced. */
808 gfc_set_sym_referenced (gfc_symbol *sym)
811 if (sym->attr.referenced)
814 sym->attr.referenced = 1;
816 /* Remember which order dummy variables are accessed in. */
818 sym->dummy_order = next_dummy_order++;
822 /* Common subroutine called by attribute changing subroutines in order
823 to prevent them from changing a symbol that has been
824 use-associated. Returns zero if it is OK to change the symbol,
828 check_used (symbol_attribute *attr, const char *name, locus *where)
831 if (attr->use_assoc == 0)
835 where = &gfc_current_locus;
838 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
841 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
848 /* Generate an error because of a duplicate attribute. */
851 duplicate_attr (const char *attr, locus *where)
855 where = &gfc_current_locus;
857 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
862 gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
863 locus *where ATTRIBUTE_UNUSED)
865 attr->ext_attr |= 1 << ext_attr;
870 /* Called from decl.c (attr_decl1) to check attributes, when declared
874 gfc_add_attribute (symbol_attribute *attr, locus *where)
876 if (check_used (attr, NULL, where))
879 return check_conflict (attr, NULL, where);
884 gfc_add_allocatable (symbol_attribute *attr, locus *where)
887 if (check_used (attr, NULL, where))
890 if (attr->allocatable)
892 duplicate_attr ("ALLOCATABLE", where);
896 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
897 && !gfc_find_state (COMP_INTERFACE))
899 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
904 attr->allocatable = 1;
905 return check_conflict (attr, NULL, where);
910 gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
913 if (check_used (attr, name, where))
916 if (attr->codimension)
918 duplicate_attr ("CODIMENSION", where);
922 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
923 && !gfc_find_state (COMP_INTERFACE))
925 gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
926 "at %L", name, where);
930 attr->codimension = 1;
931 return check_conflict (attr, name, where);
936 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
939 if (check_used (attr, name, where))
944 duplicate_attr ("DIMENSION", where);
948 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
949 && !gfc_find_state (COMP_INTERFACE))
951 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
952 "at %L", name, where);
957 return check_conflict (attr, name, where);
962 gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
965 if (check_used (attr, name, where))
968 attr->contiguous = 1;
969 return check_conflict (attr, name, where);
974 gfc_add_external (symbol_attribute *attr, locus *where)
977 if (check_used (attr, NULL, where))
982 duplicate_attr ("EXTERNAL", where);
986 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
989 attr->proc_pointer = 1;
994 return check_conflict (attr, NULL, where);
999 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
1002 if (check_used (attr, NULL, where))
1005 if (attr->intrinsic)
1007 duplicate_attr ("INTRINSIC", where);
1011 attr->intrinsic = 1;
1013 return check_conflict (attr, NULL, where);
1018 gfc_add_optional (symbol_attribute *attr, locus *where)
1021 if (check_used (attr, NULL, where))
1026 duplicate_attr ("OPTIONAL", where);
1031 return check_conflict (attr, NULL, where);
1036 gfc_add_pointer (symbol_attribute *attr, locus *where)
1039 if (check_used (attr, NULL, where))
1042 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
1043 && !gfc_find_state (COMP_INTERFACE)))
1045 duplicate_attr ("POINTER", where);
1049 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
1050 || (attr->if_source == IFSRC_IFBODY
1051 && !gfc_find_state (COMP_INTERFACE)))
1052 attr->proc_pointer = 1;
1056 return check_conflict (attr, NULL, where);
1061 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
1064 if (check_used (attr, NULL, where))
1067 attr->cray_pointer = 1;
1068 return check_conflict (attr, NULL, where);
1073 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
1076 if (check_used (attr, NULL, where))
1079 if (attr->cray_pointee)
1081 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1082 " statements", where);
1086 attr->cray_pointee = 1;
1087 return check_conflict (attr, NULL, where);
1092 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1094 if (check_used (attr, name, where))
1097 if (attr->is_protected)
1099 if (!gfc_notify_std (GFC_STD_LEGACY,
1100 "Duplicate PROTECTED attribute specified at %L",
1105 attr->is_protected = 1;
1106 return check_conflict (attr, name, where);
1111 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1114 if (check_used (attr, name, where))
1118 return check_conflict (attr, name, where);
1123 gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
1127 if (check_used (attr, name, where))
1130 if (s == SAVE_EXPLICIT && gfc_pure (NULL))
1133 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1138 if (s == SAVE_EXPLICIT)
1139 gfc_unset_implicit_pure (NULL);
1141 if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
1143 if (!gfc_notify_std (GFC_STD_LEGACY,
1144 "Duplicate SAVE attribute specified at %L",
1150 return check_conflict (attr, name, where);
1155 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1158 if (check_used (attr, name, where))
1163 if (!gfc_notify_std (GFC_STD_LEGACY,
1164 "Duplicate VALUE attribute specified at %L",
1170 return check_conflict (attr, name, where);
1175 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1177 /* No check_used needed as 11.2.1 of the F2003 standard allows
1178 that the local identifier made accessible by a use statement can be
1179 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1181 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1182 if (!gfc_notify_std (GFC_STD_LEGACY,
1183 "Duplicate VOLATILE attribute specified at %L",
1187 attr->volatile_ = 1;
1188 attr->volatile_ns = gfc_current_ns;
1189 return check_conflict (attr, name, where);
1194 gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1196 /* No check_used needed as 11.2.1 of the F2003 standard allows
1197 that the local identifier made accessible by a use statement can be
1198 given a ASYNCHRONOUS attribute. */
1200 if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
1201 if (!gfc_notify_std (GFC_STD_LEGACY,
1202 "Duplicate ASYNCHRONOUS attribute specified at %L",
1206 attr->asynchronous = 1;
1207 attr->asynchronous_ns = gfc_current_ns;
1208 return check_conflict (attr, name, where);
1213 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1216 if (check_used (attr, name, where))
1219 if (attr->threadprivate)
1221 duplicate_attr ("THREADPRIVATE", where);
1225 attr->threadprivate = 1;
1226 return check_conflict (attr, name, where);
1231 gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
1235 if (check_used (attr, name, where))
1238 if (attr->omp_declare_target)
1241 attr->omp_declare_target = 1;
1242 return check_conflict (attr, name, where);
1247 gfc_add_target (symbol_attribute *attr, locus *where)
1250 if (check_used (attr, NULL, where))
1255 duplicate_attr ("TARGET", where);
1260 return check_conflict (attr, NULL, where);
1265 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1268 if (check_used (attr, name, where))
1271 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1273 return check_conflict (attr, name, where);
1278 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1281 if (check_used (attr, name, where))
1284 /* Duplicate attribute already checked for. */
1285 attr->in_common = 1;
1286 return check_conflict (attr, name, where);
1291 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1294 /* Duplicate attribute already checked for. */
1295 attr->in_equivalence = 1;
1296 if (!check_conflict (attr, name, where))
1299 if (attr->flavor == FL_VARIABLE)
1302 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1307 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1310 if (check_used (attr, name, where))
1314 return check_conflict (attr, name, where);
1319 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1322 attr->in_namelist = 1;
1323 return check_conflict (attr, name, where);
1328 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1331 if (check_used (attr, name, where))
1335 return check_conflict (attr, name, where);
1340 gfc_add_elemental (symbol_attribute *attr, locus *where)
1343 if (check_used (attr, NULL, where))
1346 if (attr->elemental)
1348 duplicate_attr ("ELEMENTAL", where);
1352 attr->elemental = 1;
1353 return check_conflict (attr, NULL, where);
1358 gfc_add_pure (symbol_attribute *attr, locus *where)
1361 if (check_used (attr, NULL, where))
1366 duplicate_attr ("PURE", where);
1371 return check_conflict (attr, NULL, where);
1376 gfc_add_recursive (symbol_attribute *attr, locus *where)
1379 if (check_used (attr, NULL, where))
1382 if (attr->recursive)
1384 duplicate_attr ("RECURSIVE", where);
1388 attr->recursive = 1;
1389 return check_conflict (attr, NULL, where);
1394 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1397 if (check_used (attr, name, where))
1402 duplicate_attr ("ENTRY", where);
1407 return check_conflict (attr, name, where);
1412 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1415 if (attr->flavor != FL_PROCEDURE
1416 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1420 return check_conflict (attr, name, where);
1425 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1428 if (attr->flavor != FL_PROCEDURE
1429 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1432 attr->subroutine = 1;
1433 return check_conflict (attr, name, where);
1438 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1441 if (attr->flavor != FL_PROCEDURE
1442 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1446 return check_conflict (attr, name, where);
1451 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1454 if (check_used (attr, NULL, where))
1457 if (attr->flavor != FL_PROCEDURE
1458 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1461 if (attr->procedure)
1463 duplicate_attr ("PROCEDURE", where);
1467 attr->procedure = 1;
1469 return check_conflict (attr, NULL, where);
1474 gfc_add_abstract (symbol_attribute* attr, locus* where)
1478 duplicate_attr ("ABSTRACT", where);
1484 return check_conflict (attr, NULL, where);
1488 /* Flavors are special because some flavors are not what Fortran
1489 considers attributes and can be reaffirmed multiple times. */
1492 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1496 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1497 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1498 || f == FL_NAMELIST) && check_used (attr, name, where))
1501 if (attr->flavor == f && f == FL_VARIABLE)
1504 if (attr->flavor != FL_UNKNOWN)
1507 where = &gfc_current_locus;
1510 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1511 gfc_code2string (flavors, attr->flavor), name,
1512 gfc_code2string (flavors, f), where);
1514 gfc_error ("%s attribute conflicts with %s attribute at %L",
1515 gfc_code2string (flavors, attr->flavor),
1516 gfc_code2string (flavors, f), where);
1523 return check_conflict (attr, name, where);
1528 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1529 const char *name, locus *where)
1532 if (check_used (attr, name, where))
1535 if (attr->flavor != FL_PROCEDURE
1536 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1540 where = &gfc_current_locus;
1542 if (attr->proc != PROC_UNKNOWN)
1544 gfc_error ("%s procedure at %L is already declared as %s procedure",
1545 gfc_code2string (procedures, t), where,
1546 gfc_code2string (procedures, attr->proc));
1553 /* Statement functions are always scalar and functions. */
1554 if (t == PROC_ST_FUNCTION
1555 && ((!attr->function && !gfc_add_function (attr, name, where))
1556 || attr->dimension))
1559 return check_conflict (attr, name, where);
1564 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1567 if (check_used (attr, NULL, where))
1570 if (attr->intent == INTENT_UNKNOWN)
1572 attr->intent = intent;
1573 return check_conflict (attr, NULL, where);
1577 where = &gfc_current_locus;
1579 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1580 gfc_intent_string (attr->intent),
1581 gfc_intent_string (intent), where);
1587 /* No checks for use-association in public and private statements. */
1590 gfc_add_access (symbol_attribute *attr, gfc_access access,
1591 const char *name, locus *where)
1594 if (attr->access == ACCESS_UNKNOWN
1595 || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1597 attr->access = access;
1598 return check_conflict (attr, name, where);
1602 where = &gfc_current_locus;
1603 gfc_error ("ACCESS specification at %L was already specified", where);
1609 /* Set the is_bind_c field for the given symbol_attribute. */
1612 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1613 int is_proc_lang_bind_spec)
1616 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1617 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1618 "variables or common blocks", where);
1619 else if (attr->is_bind_c)
1620 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1622 attr->is_bind_c = 1;
1625 where = &gfc_current_locus;
1627 if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where))
1630 return check_conflict (attr, name, where);
1634 /* Set the extension field for the given symbol_attribute. */
1637 gfc_add_extension (symbol_attribute *attr, locus *where)
1640 where = &gfc_current_locus;
1642 if (attr->extension)
1643 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1645 attr->extension = 1;
1647 if (!gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where))
1655 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1656 gfc_formal_arglist * formal, locus *where)
1659 if (check_used (&sym->attr, sym->name, where))
1663 where = &gfc_current_locus;
1665 if (sym->attr.if_source != IFSRC_UNKNOWN
1666 && sym->attr.if_source != IFSRC_DECL)
1668 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1673 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1675 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1676 "body", sym->name, where);
1680 sym->formal = formal;
1681 sym->attr.if_source = source;
1687 /* Add a type to a symbol. */
1690 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1696 where = &gfc_current_locus;
1699 type = sym->result->ts.type;
1701 type = sym->ts.type;
1703 if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
1704 type = sym->ns->proc_name->ts.type;
1706 if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
1708 if (sym->attr.use_assoc)
1709 gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
1710 "use-associated at %L", sym->name, where, sym->module,
1713 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1714 where, gfc_basic_typename (type));
1718 if (sym->attr.procedure && sym->ts.interface)
1720 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1721 sym->name, where, gfc_basic_typename (ts->type));
1725 flavor = sym->attr.flavor;
1727 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1728 || flavor == FL_LABEL
1729 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1730 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1732 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1741 /* Clears all attributes. */
1744 gfc_clear_attr (symbol_attribute *attr)
1746 memset (attr, 0, sizeof (symbol_attribute));
1750 /* Check for missing attributes in the new symbol. Currently does
1751 nothing, but it's not clear that it is unnecessary yet. */
1754 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1755 locus *where ATTRIBUTE_UNUSED)
1762 /* Copy an attribute to a symbol attribute, bit by bit. Some
1763 attributes have a lot of side-effects but cannot be present given
1764 where we are called from, so we ignore some bits. */
1767 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1769 int is_proc_lang_bind_spec;
1771 /* In line with the other attributes, we only add bits but do not remove
1772 them; cf. also PR 41034. */
1773 dest->ext_attr |= src->ext_attr;
1775 if (src->allocatable && !gfc_add_allocatable (dest, where))
1778 if (src->dimension && !gfc_add_dimension (dest, NULL, where))
1780 if (src->codimension && !gfc_add_codimension (dest, NULL, where))
1782 if (src->contiguous && !gfc_add_contiguous (dest, NULL, where))
1784 if (src->optional && !gfc_add_optional (dest, where))
1786 if (src->pointer && !gfc_add_pointer (dest, where))
1788 if (src->is_protected && !gfc_add_protected (dest, NULL, where))
1790 if (src->save && !gfc_add_save (dest, src->save, NULL, where))
1792 if (src->value && !gfc_add_value (dest, NULL, where))
1794 if (src->volatile_ && !gfc_add_volatile (dest, NULL, where))
1796 if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where))
1798 if (src->threadprivate
1799 && !gfc_add_threadprivate (dest, NULL, where))
1801 if (src->omp_declare_target
1802 && !gfc_add_omp_declare_target (dest, NULL, where))
1804 if (src->target && !gfc_add_target (dest, where))
1806 if (src->dummy && !gfc_add_dummy (dest, NULL, where))
1808 if (src->result && !gfc_add_result (dest, NULL, where))
1813 if (src->in_namelist && !gfc_add_in_namelist (dest, NULL, where))
1816 if (src->in_common && !gfc_add_in_common (dest, NULL, where))
1819 if (src->generic && !gfc_add_generic (dest, NULL, where))
1821 if (src->function && !gfc_add_function (dest, NULL, where))
1823 if (src->subroutine && !gfc_add_subroutine (dest, NULL, where))
1826 if (src->sequence && !gfc_add_sequence (dest, NULL, where))
1828 if (src->elemental && !gfc_add_elemental (dest, where))
1830 if (src->pure && !gfc_add_pure (dest, where))
1832 if (src->recursive && !gfc_add_recursive (dest, where))
1835 if (src->flavor != FL_UNKNOWN
1836 && !gfc_add_flavor (dest, src->flavor, NULL, where))
1839 if (src->intent != INTENT_UNKNOWN
1840 && !gfc_add_intent (dest, src->intent, where))
1843 if (src->access != ACCESS_UNKNOWN
1844 && !gfc_add_access (dest, src->access, NULL, where))
1847 if (!gfc_missing_attr (dest, where))
1850 if (src->cray_pointer && !gfc_add_cray_pointer (dest, where))
1852 if (src->cray_pointee && !gfc_add_cray_pointee (dest, where))
1855 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1857 && !gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec))
1860 if (src->is_c_interop)
1861 dest->is_c_interop = 1;
1865 if (src->external && !gfc_add_external (dest, where))
1867 if (src->intrinsic && !gfc_add_intrinsic (dest, where))
1869 if (src->proc_pointer)
1870 dest->proc_pointer = 1;
1879 /************** Component name management ************/
1881 /* Component names of a derived type form their own little namespaces
1882 that are separate from all other spaces. The space is composed of
1883 a singly linked list of gfc_component structures whose head is
1884 located in the parent symbol. */
1887 /* Add a component name to a symbol. The call fails if the name is
1888 already present. On success, the component pointer is modified to
1889 point to the additional component structure. */
1892 gfc_add_component (gfc_symbol *sym, const char *name,
1893 gfc_component **component)
1895 gfc_component *p, *tail;
1899 for (p = sym->components; p; p = p->next)
1901 if (strcmp (p->name, name) == 0)
1903 gfc_error ("Component '%s' at %C already declared at %L",
1911 if (sym->attr.extension
1912 && gfc_find_component (sym->components->ts.u.derived, name, true, true))
1914 gfc_error ("Component '%s' at %C already in the parent type "
1915 "at %L", name, &sym->components->ts.u.derived->declared_at);
1919 /* Allocate a new component. */
1920 p = gfc_get_component ();
1923 sym->components = p;
1927 p->name = gfc_get_string (name);
1928 p->loc = gfc_current_locus;
1929 p->ts.type = BT_UNKNOWN;
1936 /* Recursive function to switch derived types of all symbol in a
1940 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1948 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
1949 sym->ts.u.derived = to;
1951 switch_types (st->left, from, to);
1952 switch_types (st->right, from, to);
1956 /* This subroutine is called when a derived type is used in order to
1957 make the final determination about which version to use. The
1958 standard requires that a type be defined before it is 'used', but
1959 such types can appear in IMPLICIT statements before the actual
1960 definition. 'Using' in this context means declaring a variable to
1961 be that type or using the type constructor.
1963 If a type is used and the components haven't been defined, then we
1964 have to have a derived type in a parent unit. We find the node in
1965 the other namespace and point the symtree node in this namespace to
1966 that node. Further reference to this name point to the correct
1967 node. If we can't find the node in a parent namespace, then we have
1970 This subroutine takes a pointer to a symbol node and returns a
1971 pointer to the translated node or NULL for an error. Usually there
1972 is no translation and we return the node we were passed. */
1975 gfc_use_derived (gfc_symbol *sym)
1985 if (sym->attr.unlimited_polymorphic)
1988 if (sym->attr.generic)
1989 sym = gfc_find_dt_in_generic (sym);
1991 if (sym->components != NULL || sym->attr.zero_comp)
1992 return sym; /* Already defined. */
1994 if (sym->ns->parent == NULL)
1997 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1999 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
2003 if (s == NULL || s->attr.flavor != FL_DERIVED)
2006 /* Get rid of symbol sym, translating all references to s. */
2007 for (i = 0; i < GFC_LETTERS; i++)
2009 t = &sym->ns->default_type[i];
2010 if (t->u.derived == sym)
2014 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
2019 /* Unlink from list of modified symbols. */
2020 gfc_commit_symbol (sym);
2022 switch_types (sym->ns->sym_root, sym, s);
2024 /* TODO: Also have to replace sym -> s in other lists like
2025 namelists, common lists and interface lists. */
2026 gfc_free_symbol (sym);
2031 gfc_error ("Derived type '%s' at %C is being used before it is defined",
2037 /* Given a derived type node and a component name, try to locate the
2038 component structure. Returns the NULL pointer if the component is
2039 not found or the components are private. If noaccess is set, no access
2043 gfc_find_component (gfc_symbol *sym, const char *name,
2044 bool noaccess, bool silent)
2048 if (name == NULL || sym == NULL)
2051 sym = gfc_use_derived (sym);
2056 for (p = sym->components; p; p = p->next)
2057 if (strcmp (p->name, name) == 0)
2060 if (p && sym->attr.use_assoc && !noaccess)
2062 bool is_parent_comp = sym->attr.extension && (p == sym->components);
2063 if (p->attr.access == ACCESS_PRIVATE ||
2064 (p->attr.access != ACCESS_PUBLIC
2065 && sym->component_access == ACCESS_PRIVATE
2066 && !is_parent_comp))
2069 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2076 && sym->attr.extension
2077 && sym->components->ts.type == BT_DERIVED)
2079 p = gfc_find_component (sym->components->ts.u.derived, name,
2081 /* Do not overwrite the error. */
2086 if (p == NULL && !silent)
2087 gfc_error ("'%s' at %C is not a member of the '%s' structure",
2094 /* Given a symbol, free all of the component structures and everything
2098 free_components (gfc_component *p)
2106 gfc_free_array_spec (p->as);
2107 gfc_free_expr (p->initializer);
2115 /******************** Statement label management ********************/
2117 /* Comparison function for statement labels, used for managing the
2121 compare_st_labels (void *a1, void *b1)
2123 int a = ((gfc_st_label *) a1)->value;
2124 int b = ((gfc_st_label *) b1)->value;
2130 /* Free a single gfc_st_label structure, making sure the tree is not
2131 messed up. This function is called only when some parse error
2135 gfc_free_st_label (gfc_st_label *label)
2141 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
2143 if (label->format != NULL)
2144 gfc_free_expr (label->format);
2150 /* Free a whole tree of gfc_st_label structures. */
2153 free_st_labels (gfc_st_label *label)
2159 free_st_labels (label->left);
2160 free_st_labels (label->right);
2162 if (label->format != NULL)
2163 gfc_free_expr (label->format);
2168 /* Given a label number, search for and return a pointer to the label
2169 structure, creating it if it does not exist. */
2172 gfc_get_st_label (int labelno)
2177 if (gfc_current_state () == COMP_DERIVED)
2178 ns = gfc_current_block ()->f2k_derived;
2181 /* Find the namespace of the scoping unit:
2182 If we're in a BLOCK construct, jump to the parent namespace. */
2183 ns = gfc_current_ns;
2184 while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2188 /* First see if the label is already in this namespace. */
2192 if (lp->value == labelno)
2195 if (lp->value < labelno)
2201 lp = XCNEW (gfc_st_label);
2203 lp->value = labelno;
2204 lp->defined = ST_LABEL_UNKNOWN;
2205 lp->referenced = ST_LABEL_UNKNOWN;
2207 gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2213 /* Called when a statement with a statement label is about to be
2214 accepted. We add the label to the list of the current namespace,
2215 making sure it hasn't been defined previously and referenced
2219 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2223 labelno = lp->value;
2225 if (lp->defined != ST_LABEL_UNKNOWN)
2226 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2227 &lp->where, label_locus);
2230 lp->where = *label_locus;
2234 case ST_LABEL_FORMAT:
2235 if (lp->referenced == ST_LABEL_TARGET
2236 || lp->referenced == ST_LABEL_DO_TARGET)
2237 gfc_error ("Label %d at %C already referenced as branch target",
2240 lp->defined = ST_LABEL_FORMAT;
2244 case ST_LABEL_TARGET:
2245 case ST_LABEL_DO_TARGET:
2246 if (lp->referenced == ST_LABEL_FORMAT)
2247 gfc_error ("Label %d at %C already referenced as a format label",
2252 if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
2253 && !gfc_notify_std (GFC_STD_F95_OBS, "DO termination statement "
2254 "which is not END DO or CONTINUE with "
2255 "label %d at %C", labelno))
2260 lp->defined = ST_LABEL_BAD_TARGET;
2261 lp->referenced = ST_LABEL_BAD_TARGET;
2267 /* Reference a label. Given a label and its type, see if that
2268 reference is consistent with what is known about that label,
2269 updating the unknown state. Returns false if something goes
2273 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2275 gfc_sl_type label_type;
2282 labelno = lp->value;
2284 if (lp->defined != ST_LABEL_UNKNOWN)
2285 label_type = lp->defined;
2288 label_type = lp->referenced;
2289 lp->where = gfc_current_locus;
2292 if (label_type == ST_LABEL_FORMAT
2293 && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
2295 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2300 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
2301 || label_type == ST_LABEL_BAD_TARGET)
2302 && type == ST_LABEL_FORMAT)
2304 gfc_error ("Label %d at %C previously used as branch target", labelno);
2309 if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
2310 && !gfc_notify_std (GFC_STD_F95_OBS, "Shared DO termination label %d "
2314 if (lp->referenced != ST_LABEL_DO_TARGET)
2315 lp->referenced = type;
2323 /************** Symbol table management subroutines ****************/
2325 /* Basic details: Fortran 95 requires a potentially unlimited number
2326 of distinct namespaces when compiling a program unit. This case
2327 occurs during a compilation of internal subprograms because all of
2328 the internal subprograms must be read before we can start
2329 generating code for the host.
2331 Given the tricky nature of the Fortran grammar, we must be able to
2332 undo changes made to a symbol table if the current interpretation
2333 of a statement is found to be incorrect. Whenever a symbol is
2334 looked up, we make a copy of it and link to it. All of these
2335 symbols are kept in a vector so that we can commit or
2336 undo the changes at a later time.
2338 A symtree may point to a symbol node outside of its namespace. In
2339 this case, that symbol has been used as a host associated variable
2340 at some previous time. */
2342 /* Allocate a new namespace structure. Copies the implicit types from
2343 PARENT if PARENT_TYPES is set. */
2346 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2353 ns = XCNEW (gfc_namespace);
2354 ns->sym_root = NULL;
2355 ns->uop_root = NULL;
2356 ns->tb_sym_root = NULL;
2357 ns->finalizers = NULL;
2358 ns->default_access = ACCESS_UNKNOWN;
2359 ns->parent = parent;
2361 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2363 ns->operator_access[in] = ACCESS_UNKNOWN;
2364 ns->tb_op[in] = NULL;
2367 /* Initialize default implicit types. */
2368 for (i = 'a'; i <= 'z'; i++)
2370 ns->set_flag[i - 'a'] = 0;
2371 ts = &ns->default_type[i - 'a'];
2373 if (parent_types && ns->parent != NULL)
2375 /* Copy parent settings. */
2376 *ts = ns->parent->default_type[i - 'a'];
2380 if (gfc_option.flag_implicit_none != 0)
2386 if ('i' <= i && i <= 'n')
2388 ts->type = BT_INTEGER;
2389 ts->kind = gfc_default_integer_kind;
2394 ts->kind = gfc_default_real_kind;
2398 if (parent_types && ns->parent != NULL)
2399 ns->has_implicit_none_export = ns->parent->has_implicit_none_export;
2407 /* Comparison function for symtree nodes. */
2410 compare_symtree (void *_st1, void *_st2)
2412 gfc_symtree *st1, *st2;
2414 st1 = (gfc_symtree *) _st1;
2415 st2 = (gfc_symtree *) _st2;
2417 return strcmp (st1->name, st2->name);
2421 /* Allocate a new symtree node and associate it with the new symbol. */
2424 gfc_new_symtree (gfc_symtree **root, const char *name)
2428 st = XCNEW (gfc_symtree);
2429 st->name = gfc_get_string (name);
2431 gfc_insert_bbt (root, st, compare_symtree);
2436 /* Delete a symbol from the tree. Does not free the symbol itself! */
2439 gfc_delete_symtree (gfc_symtree **root, const char *name)
2441 gfc_symtree st, *st0;
2443 st0 = gfc_find_symtree (*root, name);
2445 st.name = gfc_get_string (name);
2446 gfc_delete_bbt (root, &st, compare_symtree);
2452 /* Given a root symtree node and a name, try to find the symbol within
2453 the namespace. Returns NULL if the symbol is not found. */
2456 gfc_find_symtree (gfc_symtree *st, const char *name)
2462 c = strcmp (name, st->name);
2466 st = (c < 0) ? st->left : st->right;
2473 /* Return a symtree node with a name that is guaranteed to be unique
2474 within the namespace and corresponds to an illegal fortran name. */
2477 gfc_get_unique_symtree (gfc_namespace *ns)
2479 char name[GFC_MAX_SYMBOL_LEN + 1];
2480 static int serial = 0;
2482 sprintf (name, "@%d", serial++);
2483 return gfc_new_symtree (&ns->sym_root, name);
2487 /* Given a name find a user operator node, creating it if it doesn't
2488 exist. These are much simpler than symbols because they can't be
2489 ambiguous with one another. */
2492 gfc_get_uop (const char *name)
2496 gfc_namespace *ns = gfc_current_ns;
2500 st = gfc_find_symtree (ns->uop_root, name);
2504 st = gfc_new_symtree (&ns->uop_root, name);
2506 uop = st->n.uop = XCNEW (gfc_user_op);
2507 uop->name = gfc_get_string (name);
2508 uop->access = ACCESS_UNKNOWN;
2515 /* Given a name find the user operator node. Returns NULL if it does
2519 gfc_find_uop (const char *name, gfc_namespace *ns)
2524 ns = gfc_current_ns;
2526 st = gfc_find_symtree (ns->uop_root, name);
2527 return (st == NULL) ? NULL : st->n.uop;
2531 /* Remove a gfc_symbol structure and everything it points to. */
2534 gfc_free_symbol (gfc_symbol *sym)
2540 gfc_free_array_spec (sym->as);
2542 free_components (sym->components);
2544 gfc_free_expr (sym->value);
2546 gfc_free_namelist (sym->namelist);
2548 if (sym->ns != sym->formal_ns)
2549 gfc_free_namespace (sym->formal_ns);
2551 if (!sym->attr.generic_copy)
2552 gfc_free_interface (sym->generic);
2554 gfc_free_formal_arglist (sym->formal);
2556 gfc_free_namespace (sym->f2k_derived);
2558 if (sym->common_block && sym->common_block->name[0] != '\0')
2560 sym->common_block->refs--;
2561 if (sym->common_block->refs == 0)
2562 free (sym->common_block);
2569 /* Decrease the reference counter and free memory when we reach zero. */
2572 gfc_release_symbol (gfc_symbol *sym)
2577 if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns
2578 && (!sym->attr.entry || !sym->module))
2580 /* As formal_ns contains a reference to sym, delete formal_ns just
2581 before the deletion of sym. */
2582 gfc_namespace *ns = sym->formal_ns;
2583 sym->formal_ns = NULL;
2584 gfc_free_namespace (ns);
2591 gcc_assert (sym->refs == 0);
2592 gfc_free_symbol (sym);
2596 /* Allocate and initialize a new symbol node. */
2599 gfc_new_symbol (const char *name, gfc_namespace *ns)
2603 p = XCNEW (gfc_symbol);
2605 gfc_clear_ts (&p->ts);
2606 gfc_clear_attr (&p->attr);
2609 p->declared_at = gfc_current_locus;
2611 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2612 gfc_internal_error ("new_symbol(): Symbol name too long");
2614 p->name = gfc_get_string (name);
2616 /* Make sure flags for symbol being C bound are clear initially. */
2617 p->attr.is_bind_c = 0;
2618 p->attr.is_iso_c = 0;
2620 /* Clear the ptrs we may need. */
2621 p->common_block = NULL;
2622 p->f2k_derived = NULL;
2629 /* Generate an error if a symbol is ambiguous. */
2632 ambiguous_symbol (const char *name, gfc_symtree *st)
2635 if (st->n.sym->module)
2636 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2637 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2639 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2640 "from current program unit", name, st->n.sym->name);
2644 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2645 selector on the stack. If yes, replace it by the corresponding temporary. */
2648 select_type_insert_tmp (gfc_symtree **st)
2650 gfc_select_type_stack *stack = select_type_stack;
2651 for (; stack; stack = stack->prev)
2652 if ((*st)->n.sym == stack->selector && stack->tmp)
2657 /* Look for a symtree in the current procedure -- that is, go up to
2658 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
2661 gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
2665 gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
2669 if (!ns->construct_entities)
2678 /* Search for a symtree starting in the current namespace, resorting to
2679 any parent namespaces if requested by a nonzero parent_flag.
2680 Returns nonzero if the name is ambiguous. */
2683 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2684 gfc_symtree **result)
2689 ns = gfc_current_ns;
2693 st = gfc_find_symtree (ns->sym_root, name);
2696 select_type_insert_tmp (&st);
2699 /* Ambiguous generic interfaces are permitted, as long
2700 as the specific interfaces are different. */
2701 if (st->ambiguous && !st->n.sym->attr.generic)
2703 ambiguous_symbol (name, st);
2713 /* Don't escape an interface block. */
2714 if (ns && !ns->has_import_set
2715 && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
2727 /* Same, but returns the symbol instead. */
2730 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2731 gfc_symbol **result)
2736 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2741 *result = st->n.sym;
2747 /* Tells whether there is only one set of changes in the stack. */
2750 single_undo_checkpoint_p (void)
2752 if (latest_undo_chgset == &default_undo_chgset_var)
2754 gcc_assert (latest_undo_chgset->previous == NULL);
2759 gcc_assert (latest_undo_chgset->previous != NULL);
2764 /* Save symbol with the information necessary to back it out. */
2767 save_symbol_data (gfc_symbol *sym)
2772 if (!single_undo_checkpoint_p ())
2774 /* If there is more than one change set, look for the symbol in the
2775 current one. If it is found there, we can reuse it. */
2776 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
2779 gcc_assert (sym->gfc_new || sym->old_symbol != NULL);
2783 else if (sym->gfc_new || sym->old_symbol != NULL)
2786 s = XCNEW (gfc_symbol);
2788 sym->old_symbol = s;
2791 latest_undo_chgset->syms.safe_push (sym);
2795 /* Given a name, find a symbol, or create it if it does not exist yet
2796 in the current namespace. If the symbol is found we make sure that
2799 The integer return code indicates
2801 1 The symbol name was ambiguous
2802 2 The name meant to be established was already host associated.
2804 So if the return value is nonzero, then an error was issued. */
2807 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2808 bool allow_subroutine)
2813 /* This doesn't usually happen during resolution. */
2815 ns = gfc_current_ns;
2817 /* Try to find the symbol in ns. */
2818 st = gfc_find_symtree (ns->sym_root, name);
2820 if (st == NULL && ns->omp_udr_ns)
2823 st = gfc_find_symtree (ns->sym_root, name);
2828 /* If not there, create a new symbol. */
2829 p = gfc_new_symbol (name, ns);
2831 /* Add to the list of tentative symbols. */
2832 p->old_symbol = NULL;
2835 latest_undo_chgset->syms.safe_push (p);
2837 st = gfc_new_symtree (&ns->sym_root, name);
2844 /* Make sure the existing symbol is OK. Ambiguous
2845 generic interfaces are permitted, as long as the
2846 specific interfaces are different. */
2847 if (st->ambiguous && !st->n.sym->attr.generic)
2849 ambiguous_symbol (name, st);
2854 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2855 && !(allow_subroutine && p->attr.subroutine)
2856 && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2857 && (ns->has_import_set || p->attr.imported)))
2859 /* Symbol is from another namespace. */
2860 gfc_error ("Symbol '%s' at %C has already been host associated",
2867 /* Copy in case this symbol is changed. */
2868 save_symbol_data (p);
2877 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2882 i = gfc_get_sym_tree (name, ns, &st, false);
2887 *result = st->n.sym;
2894 /* Subroutine that searches for a symbol, creating it if it doesn't
2895 exist, but tries to host-associate the symbol if possible. */
2898 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2903 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2907 save_symbol_data (st->n.sym);
2912 i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st);
2922 return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2927 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2932 i = gfc_get_ha_sym_tree (name, &st);
2935 *result = st->n.sym;
2943 /* Search for the symtree belonging to a gfc_common_head; we cannot use
2944 head->name as the common_root symtree's name might be mangled. */
2946 static gfc_symtree *
2947 find_common_symtree (gfc_symtree *st, gfc_common_head *head)
2950 gfc_symtree *result;
2955 if (st->n.common == head)
2958 result = find_common_symtree (st->left, head);
2960 result = find_common_symtree (st->right, head);
2966 /* Clear the given storage, and make it the current change set for registering
2967 changed symbols. Its contents are freed after a call to
2968 gfc_restore_last_undo_checkpoint or gfc_drop_last_undo_checkpoint, but
2969 it is up to the caller to free the storage itself. It is usually a local
2970 variable, so there is nothing to do anyway. */
2973 gfc_new_undo_checkpoint (gfc_undo_change_set &chg_syms)
2975 chg_syms.syms = vNULL;
2976 chg_syms.tbps = vNULL;
2977 chg_syms.previous = latest_undo_chgset;
2978 latest_undo_chgset = &chg_syms;
2982 /* Restore previous state of symbol. Just copy simple stuff. */
2985 restore_old_symbol (gfc_symbol *p)
2990 old = p->old_symbol;
2992 p->ts.type = old->ts.type;
2993 p->ts.kind = old->ts.kind;
2995 p->attr = old->attr;
2997 if (p->value != old->value)
2999 gcc_checking_assert (old->value == NULL);
3000 gfc_free_expr (p->value);
3004 if (p->as != old->as)
3007 gfc_free_array_spec (p->as);
3011 p->generic = old->generic;
3012 p->component_access = old->component_access;
3014 if (p->namelist != NULL && old->namelist == NULL)
3016 gfc_free_namelist (p->namelist);
3021 if (p->namelist_tail != old->namelist_tail)
3023 gfc_free_namelist (old->namelist_tail->next);
3024 old->namelist_tail->next = NULL;
3028 p->namelist_tail = old->namelist_tail;
3030 if (p->formal != old->formal)
3032 gfc_free_formal_arglist (p->formal);
3033 p->formal = old->formal;
3036 p->old_symbol = old->old_symbol;
3041 /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3042 the structure itself. */
3045 free_undo_change_set_data (gfc_undo_change_set &cs)
3052 /* Given a change set pointer, free its target's contents and update it with
3053 the address of the previous change set. Note that only the contents are
3054 freed, not the target itself (the contents' container). It is not a problem
3055 as the latter will be a local variable usually. */
3058 pop_undo_change_set (gfc_undo_change_set *&cs)
3060 free_undo_change_set_data (*cs);
3065 static void free_old_symbol (gfc_symbol *sym);
3068 /* Merges the current change set into the previous one. The changes themselves
3069 are left untouched; only one checkpoint is forgotten. */
3072 gfc_drop_last_undo_checkpoint (void)
3077 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
3079 /* No need to loop in this case. */
3080 if (s->old_symbol == NULL)
3083 /* Remove the duplicate symbols. */
3084 FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)
3087 latest_undo_chgset->previous->syms.unordered_remove (j);
3089 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3090 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3091 shall contain from now on the backup symbol for S as it was
3092 at the checkpoint before. */
3093 if (s->old_symbol->gfc_new)
3095 gcc_assert (s->old_symbol->old_symbol == NULL);
3096 s->gfc_new = s->old_symbol->gfc_new;
3097 free_old_symbol (s);
3100 restore_old_symbol (s->old_symbol);
3105 latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
3106 latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);
3108 pop_undo_change_set (latest_undo_chgset);
3112 /* Undoes all the changes made to symbols since the previous checkpoint.
3113 This subroutine is made simpler due to the fact that attributes are
3114 never removed once added. */
3117 gfc_restore_last_undo_checkpoint (void)
3122 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3126 /* Symbol was new. */
3127 if (p->attr.in_common && p->common_block && p->common_block->head)
3129 /* If the symbol was added to any common block, it
3130 needs to be removed to stop the resolver looking
3131 for a (possibly) dead symbol. */
3133 if (p->common_block->head == p && !p->common_next)
3135 gfc_symtree st, *st0;
3136 st0 = find_common_symtree (p->ns->common_root,
3140 st.name = st0->name;
3141 gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
3146 if (p->common_block->head == p)
3147 p->common_block->head = p->common_next;
3150 gfc_symbol *cparent, *csym;
3152 cparent = p->common_block->head;
3153 csym = cparent->common_next;
3158 csym = csym->common_next;
3161 gcc_assert(cparent->common_next == p);
3163 cparent->common_next = csym->common_next;
3167 /* The derived type is saved in the symtree with the first
3168 letter capitalized; the all lower-case version to the
3169 derived type contains its associated generic function. */
3170 if (p->attr.flavor == FL_DERIVED)
3171 gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
3172 (char) TOUPPER ((unsigned char) p->name[0]),
3175 gfc_delete_symtree (&p->ns->sym_root, p->name);
3177 gfc_release_symbol (p);
3180 restore_old_symbol (p);
3183 latest_undo_chgset->syms.truncate (0);
3184 latest_undo_chgset->tbps.truncate (0);
3186 if (!single_undo_checkpoint_p ())
3187 pop_undo_change_set (latest_undo_chgset);
3191 /* Makes sure that there is only one set of changes; in other words we haven't
3192 forgotten to pair a call to gfc_new_checkpoint with a call to either
3193 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3196 enforce_single_undo_checkpoint (void)
3198 gcc_checking_assert (single_undo_checkpoint_p ());
3202 /* Undoes all the changes made to symbols in the current statement. */
3205 gfc_undo_symbols (void)
3207 enforce_single_undo_checkpoint ();
3208 gfc_restore_last_undo_checkpoint ();
3212 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3213 components of old_symbol that might need deallocation are the "allocatables"
3214 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3215 namelist_tail. In case these differ between old_symbol and sym, it's just
3216 because sym->namelist has gotten a few more items. */
3219 free_old_symbol (gfc_symbol *sym)
3222 if (sym->old_symbol == NULL)
3225 if (sym->old_symbol->as != sym->as)
3226 gfc_free_array_spec (sym->old_symbol->as);
3228 if (sym->old_symbol->value != sym->value)
3229 gfc_free_expr (sym->old_symbol->value);
3231 if (sym->old_symbol->formal != sym->formal)
3232 gfc_free_formal_arglist (sym->old_symbol->formal);
3234 free (sym->old_symbol);
3235 sym->old_symbol = NULL;
3239 /* Makes the changes made in the current statement permanent-- gets
3240 rid of undo information. */
3243 gfc_commit_symbols (void)
3246 gfc_typebound_proc *tbp;
3249 enforce_single_undo_checkpoint ();
3251 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3255 free_old_symbol (p);
3257 latest_undo_chgset->syms.truncate (0);
3259 FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)
3261 latest_undo_chgset->tbps.truncate (0);
3265 /* Makes the changes made in one symbol permanent -- gets rid of undo
3269 gfc_commit_symbol (gfc_symbol *sym)
3274 enforce_single_undo_checkpoint ();
3276 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3279 latest_undo_chgset->syms.unordered_remove (i);
3286 free_old_symbol (sym);
3290 /* Recursively free trees containing type-bound procedures. */
3293 free_tb_tree (gfc_symtree *t)
3298 free_tb_tree (t->left);
3299 free_tb_tree (t->right);
3301 /* TODO: Free type-bound procedure structs themselves; probably needs some
3302 sort of ref-counting mechanism. */
3308 /* Recursive function that deletes an entire tree and all the common
3309 head structures it points to. */
3312 free_common_tree (gfc_symtree * common_tree)
3314 if (common_tree == NULL)
3317 free_common_tree (common_tree->left);
3318 free_common_tree (common_tree->right);
3324 /* Recursive function that deletes an entire tree and all the common
3325 head structures it points to. */
3328 free_omp_udr_tree (gfc_symtree * omp_udr_tree)
3330 if (omp_udr_tree == NULL)
3333 free_omp_udr_tree (omp_udr_tree->left);
3334 free_omp_udr_tree (omp_udr_tree->right);
3336 gfc_free_omp_udr (omp_udr_tree->n.omp_udr);
3337 free (omp_udr_tree);
3341 /* Recursive function that deletes an entire tree and all the user
3342 operator nodes that it contains. */
3345 free_uop_tree (gfc_symtree *uop_tree)
3347 if (uop_tree == NULL)
3350 free_uop_tree (uop_tree->left);
3351 free_uop_tree (uop_tree->right);
3353 gfc_free_interface (uop_tree->n.uop->op);
3354 free (uop_tree->n.uop);
3359 /* Recursive function that deletes an entire tree and all the symbols
3360 that it contains. */
3363 free_sym_tree (gfc_symtree *sym_tree)
3365 if (sym_tree == NULL)
3368 free_sym_tree (sym_tree->left);
3369 free_sym_tree (sym_tree->right);
3371 gfc_release_symbol (sym_tree->n.sym);
3376 /* Free the derived type list. */
3379 gfc_free_dt_list (void)
3381 gfc_dt_list *dt, *n;
3383 for (dt = gfc_derived_types; dt; dt = n)
3389 gfc_derived_types = NULL;
3393 /* Free the gfc_equiv_info's. */
3396 gfc_free_equiv_infos (gfc_equiv_info *s)
3400 gfc_free_equiv_infos (s->next);
3405 /* Free the gfc_equiv_lists. */
3408 gfc_free_equiv_lists (gfc_equiv_list *l)
3412 gfc_free_equiv_lists (l->next);
3413 gfc_free_equiv_infos (l->equiv);
3418 /* Free a finalizer procedure list. */
3421 gfc_free_finalizer (gfc_finalizer* el)
3425 gfc_release_symbol (el->proc_sym);
3431 gfc_free_finalizer_list (gfc_finalizer* list)
3435 gfc_finalizer* current = list;
3437 gfc_free_finalizer (current);
3442 /* Create a new gfc_charlen structure and add it to a namespace.
3443 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3446 gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3449 cl = gfc_get_charlen ();
3454 /* Put into namespace, but don't allow reject_statement
3455 to free it if old_cl is given. */
3456 gfc_charlen **prev = &ns->cl_list;
3457 cl->next = ns->old_cl_list;
3458 while (*prev != ns->old_cl_list)
3459 prev = &(*prev)->next;
3461 ns->old_cl_list = cl;
3462 cl->length = gfc_copy_expr (old_cl->length);
3463 cl->length_from_typespec = old_cl->length_from_typespec;
3464 cl->backend_decl = old_cl->backend_decl;
3465 cl->passed_length = old_cl->passed_length;
3466 cl->resolved = old_cl->resolved;
3470 /* Put into namespace. */
3471 cl->next = ns->cl_list;
3479 /* Free the charlen list from cl to end (end is not freed).
3480 Free the whole list if end is NULL. */
3483 gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3487 for (; cl != end; cl = cl2)
3492 gfc_free_expr (cl->length);
3498 /* Free entry list structs. */
3501 free_entry_list (gfc_entry_list *el)
3503 gfc_entry_list *next;
3510 free_entry_list (next);
3514 /* Free a namespace structure and everything below it. Interface
3515 lists associated with intrinsic operators are not freed. These are
3516 taken care of when a specific name is freed. */
3519 gfc_free_namespace (gfc_namespace *ns)
3521 gfc_namespace *p, *q;
3530 gcc_assert (ns->refs == 0);
3532 gfc_free_statements (ns->code);
3534 free_sym_tree (ns->sym_root);
3535 free_uop_tree (ns->uop_root);
3536 free_common_tree (ns->common_root);
3537 free_omp_udr_tree (ns->omp_udr_root);
3538 free_tb_tree (ns->tb_sym_root);
3539 free_tb_tree (ns->tb_uop_root);
3540 gfc_free_finalizer_list (ns->finalizers);
3541 gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
3542 gfc_free_charlen (ns->cl_list, NULL);
3543 free_st_labels (ns->st_labels);
3545 free_entry_list (ns->entries);
3546 gfc_free_equiv (ns->equiv);
3547 gfc_free_equiv_lists (ns->equiv_lists);
3548 gfc_free_use_stmts (ns->use_stmts);
3550 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3551 gfc_free_interface (ns->op[i]);
3553 gfc_free_data (ns->data);
3557 /* Recursively free any contained namespaces. */
3562 gfc_free_namespace (q);
3568 gfc_symbol_init_2 (void)
3571 gfc_current_ns = gfc_get_namespace (NULL, 0);
3576 gfc_symbol_done_2 (void)
3578 gfc_free_namespace (gfc_current_ns);
3579 gfc_current_ns = NULL;
3580 gfc_free_dt_list ();
3582 enforce_single_undo_checkpoint ();
3583 free_undo_change_set_data (*latest_undo_chgset);
3587 /* Count how many nodes a symtree has. */
3590 count_st_nodes (const gfc_symtree *st)
3596 nodes = count_st_nodes (st->left);
3598 nodes += count_st_nodes (st->right);
3604 /* Convert symtree tree into symtree vector. */
3607 fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
3612 node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
3613 st_vec[node_cntr++] = st;
3614 node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
3620 /* Traverse namespace. As the functions might modify the symtree, we store the
3621 symtree as a vector and operate on this vector. Note: We assume that
3622 sym_func or st_func never deletes nodes from the symtree - only adding is
3623 allowed. Additionally, newly added nodes are not traversed. */
3626 do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
3627 void (*sym_func) (gfc_symbol *))
3629 gfc_symtree **st_vec;
3630 unsigned nodes, i, node_cntr;
3632 gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
3633 nodes = count_st_nodes (st);
3634 st_vec = XALLOCAVEC (gfc_symtree *, nodes);
3636 fill_st_vector (st, st_vec, node_cntr);
3641 for (i = 0; i < nodes; i++)
3642 st_vec[i]->n.sym->mark = 0;
3643 for (i = 0; i < nodes; i++)
3644 if (!st_vec[i]->n.sym->mark)
3646 (*sym_func) (st_vec[i]->n.sym);
3647 st_vec[i]->n.sym->mark = 1;
3651 for (i = 0; i < nodes; i++)
3652 (*st_func) (st_vec[i]);
3656 /* Recursively traverse the symtree nodes. */
3659 gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
3661 do_traverse_symtree (st, st_func, NULL);
3665 /* Call a given function for all symbols in the namespace. We take
3666 care that each gfc_symbol node is called exactly once. */
3669 gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
3671 do_traverse_symtree (ns->sym_root, NULL, sym_func);
3675 /* Return TRUE when name is the name of an intrinsic type. */
3678 gfc_is_intrinsic_typename (const char *name)
3680 if (strcmp (name, "integer") == 0
3681 || strcmp (name, "real") == 0
3682 || strcmp (name, "character") == 0
3683 || strcmp (name, "logical") == 0
3684 || strcmp (name, "complex") == 0
3685 || strcmp (name, "doubleprecision") == 0
3686 || strcmp (name, "doublecomplex") == 0)
3693 /* Return TRUE if the symbol is an automatic variable. */
3696 gfc_is_var_automatic (gfc_symbol *sym)
3698 /* Pointer and allocatable variables are never automatic. */
3699 if (sym->attr.pointer || sym->attr.allocatable)
3701 /* Check for arrays with non-constant size. */
3702 if (sym->attr.dimension && sym->as
3703 && !gfc_is_compile_time_shape (sym->as))
3705 /* Check for non-constant length character variables. */
3706 if (sym->ts.type == BT_CHARACTER
3708 && !gfc_is_constant_expr (sym->ts.u.cl->length))
3713 /* Given a symbol, mark it as SAVEd if it is allowed. */
3716 save_symbol (gfc_symbol *sym)
3719 if (sym->attr.use_assoc)
3722 if (sym->attr.in_common
3725 || sym->attr.flavor != FL_VARIABLE)
3727 /* Automatic objects are not saved. */
3728 if (gfc_is_var_automatic (sym))
3730 gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
3734 /* Mark those symbols which can be SAVEd as such. */
3737 gfc_save_all (gfc_namespace *ns)
3739 gfc_traverse_ns (ns, save_symbol);
3743 /* Make sure that no changes to symbols are pending. */
3746 gfc_enforce_clean_symbol_state(void)
3748 enforce_single_undo_checkpoint ();
3749 gcc_assert (latest_undo_chgset->syms.is_empty ());
3753 /************** Global symbol handling ************/
3756 /* Search a tree for the global symbol. */
3759 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3768 c = strcmp (name, symbol->name);
3772 symbol = (c < 0) ? symbol->left : symbol->right;
3779 /* Compare two global symbols. Used for managing the BB tree. */
3782 gsym_compare (void *_s1, void *_s2)
3784 gfc_gsymbol *s1, *s2;
3786 s1 = (gfc_gsymbol *) _s1;
3787 s2 = (gfc_gsymbol *) _s2;
3788 return strcmp (s1->name, s2->name);
3792 /* Get a global symbol, creating it if it doesn't exist. */
3795 gfc_get_gsymbol (const char *name)
3799 s = gfc_find_gsymbol (gfc_gsym_root, name);
3803 s = XCNEW (gfc_gsymbol);
3804 s->type = GSYM_UNKNOWN;
3805 s->name = gfc_get_string (name);
3807 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3814 get_iso_c_binding_dt (int sym_id)
3816 gfc_dt_list *dt_list;
3818 dt_list = gfc_derived_types;
3820 /* Loop through the derived types in the name list, searching for
3821 the desired symbol from iso_c_binding. Search the parent namespaces
3822 if necessary and requested to (parent_flag). */
3823 while (dt_list != NULL)
3825 if (dt_list->derived->from_intmod != INTMOD_NONE
3826 && dt_list->derived->intmod_sym_id == sym_id)
3827 return dt_list->derived;
3829 dt_list = dt_list->next;
3836 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3837 with C. This is necessary for any derived type that is BIND(C) and for
3838 derived types that are parameters to functions that are BIND(C). All
3839 fields of the derived type are required to be interoperable, and are tested
3840 for such. If an error occurs, the errors are reported here, allowing for
3841 multiple errors to be handled for a single derived type. */
3844 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3846 gfc_component *curr_comp = NULL;
3847 bool is_c_interop = false;
3850 if (derived_sym == NULL)
3851 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3852 "unexpectedly NULL");
3854 /* If we've already looked at this derived symbol, do not look at it again
3855 so we don't repeat warnings/errors. */
3856 if (derived_sym->ts.is_c_interop)
3859 /* The derived type must have the BIND attribute to be interoperable
3860 J3/04-007, Section 15.2.3. */
3861 if (derived_sym->attr.is_bind_c != 1)
3863 derived_sym->ts.is_c_interop = 0;
3864 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3865 "attribute to be C interoperable", derived_sym->name,
3866 &(derived_sym->declared_at));
3870 curr_comp = derived_sym->components;
3872 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
3873 empty struct. Section 15.2 in Fortran 2003 states: "The following
3874 subclauses define the conditions under which a Fortran entity is
3875 interoperable. If a Fortran entity is interoperable, an equivalent
3876 entity may be defined by means of C and the Fortran entity is said
3877 to be interoperable with the C entity. There does not have to be such
3878 an interoperating C entity."
3880 if (curr_comp == NULL)
3882 gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
3883 "and may be inaccessible by the C companion processor",
3884 derived_sym->name, &(derived_sym->declared_at));
3885 derived_sym->ts.is_c_interop = 1;
3886 derived_sym->attr.is_bind_c = 1;
3891 /* Initialize the derived type as being C interoperable.
3892 If we find an error in the components, this will be set false. */
3893 derived_sym->ts.is_c_interop = 1;
3895 /* Loop through the list of components to verify that the kind of
3896 each is a C interoperable type. */
3899 /* The components cannot be pointers (fortran sense).
3900 J3/04-007, Section 15.2.3, C1505. */
3901 if (curr_comp->attr.pointer != 0)
3903 gfc_error ("Component '%s' at %L cannot have the "
3904 "POINTER attribute because it is a member "
3905 "of the BIND(C) derived type '%s' at %L",
3906 curr_comp->name, &(curr_comp->loc),
3907 derived_sym->name, &(derived_sym->declared_at));
3911 if (curr_comp->attr.proc_pointer != 0)
3913 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3914 " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3915 &curr_comp->loc, derived_sym->name,
3916 &derived_sym->declared_at);
3920 /* The components cannot be allocatable.
3921 J3/04-007, Section 15.2.3, C1505. */
3922 if (curr_comp->attr.allocatable != 0)
3924 gfc_error ("Component '%s' at %L cannot have the "
3925 "ALLOCATABLE attribute because it is a member "
3926 "of the BIND(C) derived type '%s' at %L",
3927 curr_comp->name, &(curr_comp->loc),
3928 derived_sym->name, &(derived_sym->declared_at));
3932 /* BIND(C) derived types must have interoperable components. */
3933 if (curr_comp->ts.type == BT_DERIVED
3934 && curr_comp->ts.u.derived->ts.is_iso_c != 1
3935 && curr_comp->ts.u.derived != derived_sym)
3937 /* This should be allowed; the draft says a derived-type can not
3938 have type parameters if it is has the BIND attribute. Type
3939 parameters seem to be for making parameterized derived types.
3940 There's no need to verify the type if it is c_ptr/c_funptr. */
3941 retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3945 /* Grab the typespec for the given component and test the kind. */
3946 is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
3950 /* Report warning and continue since not fatal. The
3951 draft does specify a constraint that requires all fields
3952 to interoperate, but if the user says real(4), etc., it
3953 may interoperate with *something* in C, but the compiler
3954 most likely won't know exactly what. Further, it may not
3955 interoperate with the same data type(s) in C if the user
3956 recompiles with different flags (e.g., -m32 and -m64 on
3957 x86_64 and using integer(4) to claim interop with a
3959 if (derived_sym->attr.is_bind_c == 1
3960 && gfc_option.warn_c_binding_type)
3961 /* If the derived type is bind(c), all fields must be
3963 gfc_warning ("Component '%s' in derived type '%s' at %L "
3964 "may not be C interoperable, even though "
3965 "derived type '%s' is BIND(C)",
3966 curr_comp->name, derived_sym->name,
3967 &(curr_comp->loc), derived_sym->name);
3968 else if (gfc_option.warn_c_binding_type)
3969 /* If derived type is param to bind(c) routine, or to one
3970 of the iso_c_binding procs, it must be interoperable, so
3971 all fields must interop too. */
3972 gfc_warning ("Component '%s' in derived type '%s' at %L "
3973 "may not be C interoperable",
3974 curr_comp->name, derived_sym->name,
3979 curr_comp = curr_comp->next;
3980 } while (curr_comp != NULL);
3983 /* Make sure we don't have conflicts with the attributes. */
3984 if (derived_sym->attr.access == ACCESS_PRIVATE)
3986 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3987 "PRIVATE and BIND(C) attributes", derived_sym->name,
3988 &(derived_sym->declared_at));
3992 if (derived_sym->attr.sequence != 0)
3994 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3995 "attribute because it is BIND(C)", derived_sym->name,
3996 &(derived_sym->declared_at));
4000 /* Mark the derived type as not being C interoperable if we found an
4001 error. If there were only warnings, proceed with the assumption
4002 it's interoperable. */
4004 derived_sym->ts.is_c_interop = 0;
4010 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
4013 gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree)
4017 gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym);
4018 dt_symtree->n.sym->attr.referenced = 1;
4020 tmp_sym->attr.is_c_interop = 1;
4021 tmp_sym->attr.is_bind_c = 1;
4022 tmp_sym->ts.is_c_interop = 1;
4023 tmp_sym->ts.is_iso_c = 1;
4024 tmp_sym->ts.type = BT_DERIVED;
4025 tmp_sym->ts.f90_type = BT_VOID;
4026 tmp_sym->attr.flavor = FL_PARAMETER;
4027 tmp_sym->ts.u.derived = dt_symtree->n.sym;
4029 /* Set the c_address field of c_null_ptr and c_null_funptr to
4030 the value of NULL. */
4031 tmp_sym->value = gfc_get_expr ();
4032 tmp_sym->value->expr_type = EXPR_STRUCTURE;
4033 tmp_sym->value->ts.type = BT_DERIVED;
4034 tmp_sym->value->ts.f90_type = BT_VOID;
4035 tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
4036 gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
4037 c = gfc_constructor_first (tmp_sym->value->value.constructor);
4038 c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
4039 c->expr->ts.is_iso_c = 1;
4045 /* Add a formal argument, gfc_formal_arglist, to the
4046 end of the given list of arguments. Set the reference to the
4047 provided symbol, param_sym, in the argument. */
4050 add_formal_arg (gfc_formal_arglist **head,
4051 gfc_formal_arglist **tail,
4052 gfc_formal_arglist *formal_arg,
4053 gfc_symbol *param_sym)
4055 /* Put in list, either as first arg or at the tail (curr arg). */
4057 *head = *tail = formal_arg;
4060 (*tail)->next = formal_arg;
4061 (*tail) = formal_arg;
4064 (*tail)->sym = param_sym;
4065 (*tail)->next = NULL;
4071 /* Add a procedure interface to the given symbol (i.e., store a
4072 reference to the list of formal arguments). */
4075 add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
4078 sym->formal = formal;
4079 sym->attr.if_source = source;
4083 /* Copy the formal args from an existing symbol, src, into a new
4084 symbol, dest. New formal args are created, and the description of
4085 each arg is set according to the existing ones. This function is
4086 used when creating procedure declaration variables from a procedure
4087 declaration statement (see match_proc_decl()) to create the formal
4088 args based on the args of a given named interface.
4090 When an actual argument list is provided, skip the absent arguments.
4091 To be used together with gfc_se->ignore_optional. */
4094 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
4095 gfc_actual_arglist *actual)
4097 gfc_formal_arglist *head = NULL;
4098 gfc_formal_arglist *tail = NULL;
4099 gfc_formal_arglist *formal_arg = NULL;
4100 gfc_intrinsic_arg *curr_arg = NULL;
4101 gfc_formal_arglist *formal_prev = NULL;
4102 gfc_actual_arglist *act_arg = actual;
4103 /* Save current namespace so we can change it for formal args. */
4104 gfc_namespace *parent_ns = gfc_current_ns;
4106 /* Create a new namespace, which will be the formal ns (namespace
4107 of the formal args). */
4108 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4109 gfc_current_ns->proc_name = dest;
4111 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4113 /* Skip absent arguments. */
4116 gcc_assert (act_arg != NULL);
4117 if (act_arg->expr == NULL)
4119 act_arg = act_arg->next;
4122 act_arg = act_arg->next;
4124 formal_arg = gfc_get_formal_arglist ();
4125 gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4127 /* May need to copy more info for the symbol. */
4128 formal_arg->sym->ts = curr_arg->ts;
4129 formal_arg->sym->attr.optional = curr_arg->optional;
4130 formal_arg->sym->attr.value = curr_arg->value;
4131 formal_arg->sym->attr.intent = curr_arg->intent;
4132 formal_arg->sym->attr.flavor = FL_VARIABLE;
4133 formal_arg->sym->attr.dummy = 1;
4135 if (formal_arg->sym->ts.type == BT_CHARACTER)
4136 formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4138 /* If this isn't the first arg, set up the next ptr. For the
4139 last arg built, the formal_arg->next will never get set to
4140 anything other than NULL. */
4141 if (formal_prev != NULL)
4142 formal_prev->next = formal_arg;
4144 formal_arg->next = NULL;
4146 formal_prev = formal_arg;
4148 /* Add arg to list of formal args. */
4149 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4151 /* Validate changes. */
4152 gfc_commit_symbol (formal_arg->sym);
4155 /* Add the interface to the symbol. */
4156 add_proc_interface (dest, IFSRC_DECL, head);
4158 /* Store the formal namespace information. */
4159 if (dest->formal != NULL)
4160 /* The current ns should be that for the dest proc. */
4161 dest->formal_ns = gfc_current_ns;
4162 /* Restore the current namespace to what it was on entry. */
4163 gfc_current_ns = parent_ns;
4168 std_for_isocbinding_symbol (int id)
4172 #define NAMED_INTCST(a,b,c,d) \
4175 #include "iso-c-binding.def"
4178 #define NAMED_FUNCTION(a,b,c,d) \
4181 #define NAMED_SUBROUTINE(a,b,c,d) \
4184 #include "iso-c-binding.def"
4185 #undef NAMED_FUNCTION
4186 #undef NAMED_SUBROUTINE
4189 return GFC_STD_F2003;
4193 /* Generate the given set of C interoperable kind objects, or all
4194 interoperable kinds. This function will only be given kind objects
4195 for valid iso_c_binding defined types because this is verified when
4196 the 'use' statement is parsed. If the user gives an 'only' clause,
4197 the specific kinds are looked up; if they don't exist, an error is
4198 reported. If the user does not give an 'only' clause, all
4199 iso_c_binding symbols are generated. If a list of specific kinds
4200 is given, it must have a NULL in the first empty spot to mark the
4201 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4202 point to the symtree for c_(fun)ptr. */
4205 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4206 const char *local_name, gfc_symtree *dt_symtree,
4209 const char *const name = (local_name && local_name[0])
4210 ? local_name : c_interop_kinds_table[s].name;
4211 gfc_symtree *tmp_symtree;
4212 gfc_symbol *tmp_sym = NULL;
4215 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4218 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4220 && (!tmp_symtree || !tmp_symtree->n.sym
4221 || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING
4222 || tmp_symtree->n.sym->intmod_sym_id != s))
4225 /* Already exists in this scope so don't re-add it. */
4226 if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
4227 && (!tmp_sym->attr.generic
4228 || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
4229 && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
4231 if (tmp_sym->attr.flavor == FL_DERIVED
4232 && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
4234 gfc_dt_list *dt_list;
4235 dt_list = gfc_get_dt_list ();
4236 dt_list->derived = tmp_sym;
4237 dt_list->next = gfc_derived_types;
4238 gfc_derived_types = dt_list;
4244 /* Create the sym tree in the current ns. */
4247 tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
4248 tmp_sym = gfc_new_symbol (name, gfc_current_ns);
4250 /* Add to the list of tentative symbols. */
4251 latest_undo_chgset->syms.safe_push (tmp_sym);
4252 tmp_sym->old_symbol = NULL;
4254 tmp_sym->gfc_new = 1;
4256 tmp_symtree->n.sym = tmp_sym;
4261 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4262 gcc_assert (tmp_symtree);
4263 tmp_sym = tmp_symtree->n.sym;
4266 /* Say what module this symbol belongs to. */
4267 tmp_sym->module = gfc_get_string (mod_name);
4268 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4269 tmp_sym->intmod_sym_id = s;
4270 tmp_sym->attr.is_iso_c = 1;
4271 tmp_sym->attr.use_assoc = 1;
4273 gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR
4274 || s == ISOCBINDING_NULL_PTR);
4279 #define NAMED_INTCST(a,b,c,d) case a :
4280 #define NAMED_REALCST(a,b,c,d) case a :
4281 #define NAMED_CMPXCST(a,b,c,d) case a :
4282 #define NAMED_LOGCST(a,b,c) case a :
4283 #define NAMED_CHARKNDCST(a,b,c) case a :
4284 #include "iso-c-binding.def"
4286 tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4287 c_interop_kinds_table[s].value);
4289 /* Initialize an integer constant expression node. */
4290 tmp_sym->attr.flavor = FL_PARAMETER;
4291 tmp_sym->ts.type = BT_INTEGER;
4292 tmp_sym->ts.kind = gfc_default_integer_kind;
4294 /* Mark this type as a C interoperable one. */
4295 tmp_sym->ts.is_c_interop = 1;
4296 tmp_sym->ts.is_iso_c = 1;
4297 tmp_sym->value->ts.is_c_interop = 1;
4298 tmp_sym->value->ts.is_iso_c = 1;
4299 tmp_sym->attr.is_c_interop = 1;
4301 /* Tell what f90 type this c interop kind is valid. */
4302 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4307 #define NAMED_CHARCST(a,b,c) case a :
4308 #include "iso-c-binding.def"
4310 /* Initialize an integer constant expression node for the
4311 length of the character. */
4312 tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
4313 &gfc_current_locus, NULL, 1);
4314 tmp_sym->value->ts.is_c_interop = 1;
4315 tmp_sym->value->ts.is_iso_c = 1;
4316 tmp_sym->value->value.character.length = 1;
4317 tmp_sym->value->value.character.string[0]
4318 = (gfc_char_t) c_interop_kinds_table[s].value;
4319 tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4320 tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
4323 /* May not need this in both attr and ts, but do need in
4324 attr for writing module file. */
4325 tmp_sym->attr.is_c_interop = 1;
4327 tmp_sym->attr.flavor = FL_PARAMETER;
4328 tmp_sym->ts.type = BT_CHARACTER;
4330 /* Need to set it to the C_CHAR kind. */
4331 tmp_sym->ts.kind = gfc_default_character_kind;
4333 /* Mark this type as a C interoperable one. */
4334 tmp_sym->ts.is_c_interop = 1;
4335 tmp_sym->ts.is_iso_c = 1;
4337 /* Tell what f90 type this c interop kind is valid. */
4338 tmp_sym->ts.f90_type = BT_CHARACTER;
4342 case ISOCBINDING_PTR:
4343 case ISOCBINDING_FUNPTR:
4346 gfc_dt_list **dt_list_ptr = NULL;
4347 gfc_component *tmp_comp = NULL;
4349 /* Generate real derived type. */
4354 const char *hidden_name;
4355 gfc_interface *intr, *head;
4357 hidden_name = gfc_get_string ("%c%s",
4358 (char) TOUPPER ((unsigned char)
4361 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4363 gcc_assert (tmp_symtree == NULL);
4364 gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
4365 dt_sym = tmp_symtree->n.sym;
4366 dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR
4367 ? "c_ptr" : "c_funptr");
4369 /* Generate an artificial generic function. */
4370 head = tmp_sym->generic;
4371 intr = gfc_get_interface ();
4373 intr->where = gfc_current_locus;
4375 tmp_sym->generic = intr;
4377 if (!tmp_sym->attr.generic
4378 && !gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL))
4381 if (!tmp_sym->attr.function
4382 && !gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL))
4386 /* Say what module this symbol belongs to. */
4387 dt_sym->module = gfc_get_string (mod_name);
4388 dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
4389 dt_sym->intmod_sym_id = s;
4390 dt_sym->attr.use_assoc = 1;
4392 /* Initialize an integer constant expression node. */
4393 dt_sym->attr.flavor = FL_DERIVED;
4394 dt_sym->ts.is_c_interop = 1;
4395 dt_sym->attr.is_c_interop = 1;
4396 dt_sym->attr.private_comp = 1;
4397 dt_sym->component_access = ACCESS_PRIVATE;
4398 dt_sym->ts.is_iso_c = 1;
4399 dt_sym->ts.type = BT_DERIVED;
4400 dt_sym->ts.f90_type = BT_VOID;
4402 /* A derived type must have the bind attribute to be
4403 interoperable (J3/04-007, Section 15.2.3), even though
4404 the binding label is not used. */
4405 dt_sym->attr.is_bind_c = 1;
4407 dt_sym->attr.referenced = 1;
4408 dt_sym->ts.u.derived = dt_sym;
4410 /* Add the symbol created for the derived type to the current ns. */
4411 dt_list_ptr = &(gfc_derived_types);
4412 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4413 dt_list_ptr = &((*dt_list_ptr)->next);
4415 /* There is already at least one derived type in the list, so append
4416 the one we're currently building for c_ptr or c_funptr. */
4417 if (*dt_list_ptr != NULL)
4418 dt_list_ptr = &((*dt_list_ptr)->next);
4419 (*dt_list_ptr) = gfc_get_dt_list ();
4420 (*dt_list_ptr)->derived = dt_sym;
4421 (*dt_list_ptr)->next = NULL;
4423 gfc_add_component (dt_sym, "c_address", &tmp_comp);
4424 if (tmp_comp == NULL)
4427 tmp_comp->ts.type = BT_INTEGER;
4429 /* Set this because the module will need to read/write this field. */
4430 tmp_comp->ts.f90_type = BT_INTEGER;
4432 /* The kinds for c_ptr and c_funptr are the same. */
4433 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4434 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4435 tmp_comp->attr.access = ACCESS_PRIVATE;
4437 /* Mark the component as C interoperable. */
4438 tmp_comp->ts.is_c_interop = 1;
4443 case ISOCBINDING_NULL_PTR:
4444 case ISOCBINDING_NULL_FUNPTR:
4445 gen_special_c_interop_ptr (tmp_sym, dt_symtree);
4451 gfc_commit_symbol (tmp_sym);
4456 /* Check that a symbol is already typed. If strict is not set, an untyped
4457 symbol is acceptable for non-standard-conforming mode. */
4460 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4461 bool strict, locus where)
4465 if (gfc_matching_prefix)
4468 /* Check for the type and try to give it an implicit one. */
4469 if (sym->ts.type == BT_UNKNOWN
4470 && !gfc_set_default_type (sym, 0, ns))
4474 gfc_error ("Symbol '%s' is used before it is typed at %L",
4479 if (!gfc_notify_std (GFC_STD_GNU, "Symbol '%s' is used before"
4480 " it is typed at %L", sym->name, &where))
4484 /* Everything is ok. */
4489 /* Construct a typebound-procedure structure. Those are stored in a tentative
4490 list and marked `error' until symbols are committed. */
4493 gfc_get_typebound_proc (gfc_typebound_proc *tb0)
4495 gfc_typebound_proc *result;
4497 result = XCNEW (gfc_typebound_proc);
4502 latest_undo_chgset->tbps.safe_push (result);
4508 /* Get the super-type of a given derived type. */
4511 gfc_get_derived_super_type (gfc_symbol* derived)
4513 gcc_assert (derived);
4515 if (derived->attr.generic)
4516 derived = gfc_find_dt_in_generic (derived);
4518 if (!derived->attr.extension)
4521 gcc_assert (derived->components);
4522 gcc_assert (derived->components->ts.type == BT_DERIVED);
4523 gcc_assert (derived->components->ts.u.derived);
4525 if (derived->components->ts.u.derived->attr.generic)
4526 return gfc_find_dt_in_generic (derived->components->ts.u.derived);
4528 return derived->components->ts.u.derived;
4532 /* Get the ultimate super-type of a given derived type. */
4535 gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
4537 if (!derived->attr.extension)
4540 derived = gfc_get_derived_super_type (derived);
4542 if (derived->attr.extension)
4543 return gfc_get_ultimate_derived_super_type (derived);
4549 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4552 gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
4554 while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
4555 t2 = gfc_get_derived_super_type (t2);
4556 return gfc_compare_derived_types (t1, t2);
4560 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4561 If ts1 is nonpolymorphic, ts2 must be the same type.
4562 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4565 gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
4567 bool is_class1 = (ts1->type == BT_CLASS);
4568 bool is_class2 = (ts2->type == BT_CLASS);
4569 bool is_derived1 = (ts1->type == BT_DERIVED);
4570 bool is_derived2 = (ts2->type == BT_DERIVED);
4573 && ts1->u.derived->components
4574 && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
4577 if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
4578 return (ts1->type == ts2->type);
4580 if (is_derived1 && is_derived2)
4581 return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
4583 if (is_derived1 && is_class2)
4584 return gfc_compare_derived_types (ts1->u.derived,
4585 ts2->u.derived->components->ts.u.derived);
4586 if (is_class1 && is_derived2)
4587 return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4589 else if (is_class1 && is_class2)
4590 return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4591 ts2->u.derived->components->ts.u.derived);
4597 /* Find the parent-namespace of the current function. If we're inside
4598 BLOCK constructs, it may not be the current one. */
4601 gfc_find_proc_namespace (gfc_namespace* ns)
4603 while (ns->construct_entities)
4613 /* Check if an associate-variable should be translated as an `implicit' pointer
4614 internally (if it is associated to a variable and not an array with
4618 gfc_is_associate_pointer (gfc_symbol* sym)
4623 if (sym->ts.type == BT_CLASS)
4626 if (!sym->assoc->variable)
4629 if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
4637 gfc_find_dt_in_generic (gfc_symbol *sym)
4639 gfc_interface *intr = NULL;
4641 if (!sym || sym->attr.flavor == FL_DERIVED)
4644 if (sym->attr.generic)
4645 for (intr = sym->generic; intr; intr = intr->next)
4646 if (intr->sym->attr.flavor == FL_DERIVED)
4648 return intr ? intr->sym : NULL;
4652 /* Get the dummy arguments from a procedure symbol. If it has been declared
4653 via a PROCEDURE statement with a named interface, ts.interface will be set
4654 and the arguments need to be taken from there. */
4656 gfc_formal_arglist *
4657 gfc_sym_get_dummy_args (gfc_symbol *sym)
4659 gfc_formal_arglist *dummies;
4661 dummies = sym->formal;
4662 if (dummies == NULL && sym->ts.interface != NULL)
4663 dummies = sym->ts.interface->formal;