1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
30 #include "constructor.h"
33 /* Strings for all symbol attributes. We use these for dumping the
34 parse tree, in error messages, and also when reading and writing
37 const mstring flavors[] =
39 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
40 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
41 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
42 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
43 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
47 const mstring procedures[] =
49 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
50 minit ("MODULE-PROC", PROC_MODULE),
51 minit ("INTERNAL-PROC", PROC_INTERNAL),
52 minit ("DUMMY-PROC", PROC_DUMMY),
53 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
54 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
55 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
59 const mstring intents[] =
61 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
62 minit ("IN", INTENT_IN),
63 minit ("OUT", INTENT_OUT),
64 minit ("INOUT", INTENT_INOUT),
68 const mstring access_types[] =
70 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
71 minit ("PUBLIC", ACCESS_PUBLIC),
72 minit ("PRIVATE", ACCESS_PRIVATE),
76 const mstring ifsrc_types[] =
78 minit ("UNKNOWN", IFSRC_UNKNOWN),
79 minit ("DECL", IFSRC_DECL),
80 minit ("BODY", IFSRC_IFBODY)
83 const mstring save_status[] =
85 minit ("UNKNOWN", SAVE_NONE),
86 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
87 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
90 /* This is to make sure the backend generates setup code in the correct
93 static int next_dummy_order = 1;
96 gfc_namespace *gfc_current_ns;
97 gfc_namespace *gfc_global_ns_list;
99 gfc_gsymbol *gfc_gsym_root = NULL;
101 static gfc_symbol *changed_syms = NULL;
103 gfc_dt_list *gfc_derived_types;
106 /* List of tentative typebound-procedures. */
108 typedef struct tentative_tbp
110 gfc_typebound_proc *proc;
111 struct tentative_tbp *next;
115 static tentative_tbp *tentative_tbp_list = NULL;
118 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
120 /* The following static variable indicates whether a particular element has
121 been explicitly set or not. */
123 static int new_flag[GFC_LETTERS];
126 /* Handle a correctly parsed IMPLICIT NONE. */
129 gfc_set_implicit_none (void)
133 if (gfc_current_ns->seen_implicit_none)
135 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
139 gfc_current_ns->seen_implicit_none = 1;
141 for (i = 0; i < GFC_LETTERS; i++)
143 gfc_clear_ts (&gfc_current_ns->default_type[i]);
144 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);
277 if (sym->attr.is_bind_c == 1)
279 /* BIND(C) variables should not be implicitly declared. */
280 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
281 "not be C interoperable", sym->name, &sym->declared_at);
282 sym->ts.f90_type = sym->ts.type;
285 if (sym->attr.dummy != 0)
287 if (sym->ns->proc_name != NULL
288 && (sym->ns->proc_name->attr.subroutine != 0
289 || sym->ns->proc_name->attr.function != 0)
290 && sym->ns->proc_name->attr.is_bind_c != 0)
292 /* Dummy args to a BIND(C) routine may not be interoperable if
293 they are implicitly typed. */
294 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
295 "be C interoperable but it is a dummy argument to "
296 "the BIND(C) procedure '%s' at %L", sym->name,
297 &(sym->declared_at), sym->ns->proc_name->name,
298 &(sym->ns->proc_name->declared_at));
299 sym->ts.f90_type = sym->ts.type;
307 /* This function is called from parse.c(parse_progunit) to check the
308 type of the function is not implicitly typed in the host namespace
309 and to implicitly type the function result, if necessary. */
312 gfc_check_function_type (gfc_namespace *ns)
314 gfc_symbol *proc = ns->proc_name;
316 if (!proc->attr.contained || proc->result->attr.implicit_type)
319 if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
321 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
324 if (proc->result != proc)
326 proc->ts = proc->result->ts;
327 proc->as = gfc_copy_array_spec (proc->result->as);
328 proc->attr.dimension = proc->result->attr.dimension;
329 proc->attr.pointer = proc->result->attr.pointer;
330 proc->attr.allocatable = proc->result->attr.allocatable;
333 else if (!proc->result->attr.proc_pointer)
335 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
336 proc->result->name, &proc->result->declared_at);
337 proc->result->attr.untyped = 1;
343 /******************** Symbol attribute stuff *********************/
345 /* This is a generic conflict-checker. We do this to avoid having a
346 single conflict in two places. */
348 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
349 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
350 #define conf_std(a, b, std) if (attr->a && attr->b)\
359 check_conflict (symbol_attribute *attr, const char *name, locus *where)
361 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
362 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
363 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
364 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
365 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
366 *privat = "PRIVATE", *recursive = "RECURSIVE",
367 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
368 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
369 *function = "FUNCTION", *subroutine = "SUBROUTINE",
370 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
371 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
372 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
373 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
374 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
375 *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
376 *contiguous = "CONTIGUOUS", *generic = "GENERIC";
377 static const char *threadprivate = "THREADPRIVATE";
383 where = &gfc_current_locus;
385 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
389 standard = GFC_STD_F2003;
393 if (attr->in_namelist && (attr->allocatable || attr->pointer))
396 a2 = attr->allocatable ? allocatable : pointer;
397 standard = GFC_STD_F2003;
401 /* Check for attributes not allowed in a BLOCK DATA. */
402 if (gfc_current_state () == COMP_BLOCK_DATA)
406 if (attr->in_namelist)
408 if (attr->allocatable)
414 if (attr->access == ACCESS_PRIVATE)
416 if (attr->access == ACCESS_PUBLIC)
418 if (attr->intent != INTENT_UNKNOWN)
424 ("%s attribute not allowed in BLOCK DATA program unit at %L",
430 if (attr->save == SAVE_EXPLICIT)
433 conf (in_common, save);
436 switch (attr->flavor)
444 a1 = gfc_code2string (flavors, attr->flavor);
449 /* Conflicts between SAVE and PROCEDURE will be checked at
450 resolution stage, see "resolve_fl_procedure". */
459 conf (dummy, intrinsic);
460 conf (dummy, threadprivate);
461 conf (pointer, target);
462 conf (pointer, intrinsic);
463 conf (pointer, elemental);
464 conf (allocatable, elemental);
466 conf (target, external);
467 conf (target, intrinsic);
469 if (!attr->if_source)
470 conf (external, dimension); /* See Fortran 95's R504. */
472 conf (external, intrinsic);
473 conf (entry, intrinsic);
475 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
476 conf (external, subroutine);
478 if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
479 "Fortran 2003: Procedure pointer at %C") == FAILURE)
482 conf (allocatable, pointer);
483 conf_std (allocatable, dummy, GFC_STD_F2003);
484 conf_std (allocatable, function, GFC_STD_F2003);
485 conf_std (allocatable, result, GFC_STD_F2003);
486 conf (elemental, recursive);
488 conf (in_common, dummy);
489 conf (in_common, allocatable);
490 conf (in_common, codimension);
491 conf (in_common, result);
493 conf (in_equivalence, use_assoc);
494 conf (in_equivalence, codimension);
495 conf (in_equivalence, dummy);
496 conf (in_equivalence, target);
497 conf (in_equivalence, pointer);
498 conf (in_equivalence, function);
499 conf (in_equivalence, result);
500 conf (in_equivalence, entry);
501 conf (in_equivalence, allocatable);
502 conf (in_equivalence, threadprivate);
504 conf (dummy, result);
505 conf (entry, result);
506 conf (generic, result);
508 conf (function, subroutine);
510 if (!function && !subroutine)
511 conf (is_bind_c, dummy);
513 conf (is_bind_c, cray_pointer);
514 conf (is_bind_c, cray_pointee);
515 conf (is_bind_c, codimension);
516 conf (is_bind_c, allocatable);
517 conf (is_bind_c, elemental);
519 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
520 Parameter conflict caught below. Also, value cannot be specified
521 for a dummy procedure. */
523 /* Cray pointer/pointee conflicts. */
524 conf (cray_pointer, cray_pointee);
525 conf (cray_pointer, dimension);
526 conf (cray_pointer, codimension);
527 conf (cray_pointer, contiguous);
528 conf (cray_pointer, pointer);
529 conf (cray_pointer, target);
530 conf (cray_pointer, allocatable);
531 conf (cray_pointer, external);
532 conf (cray_pointer, intrinsic);
533 conf (cray_pointer, in_namelist);
534 conf (cray_pointer, function);
535 conf (cray_pointer, subroutine);
536 conf (cray_pointer, entry);
538 conf (cray_pointee, allocatable);
539 conf (cray_pointer, contiguous);
540 conf (cray_pointer, codimension);
541 conf (cray_pointee, intent);
542 conf (cray_pointee, optional);
543 conf (cray_pointee, dummy);
544 conf (cray_pointee, target);
545 conf (cray_pointee, intrinsic);
546 conf (cray_pointee, pointer);
547 conf (cray_pointee, entry);
548 conf (cray_pointee, in_common);
549 conf (cray_pointee, in_equivalence);
550 conf (cray_pointee, threadprivate);
553 conf (data, function);
555 conf (data, allocatable);
557 conf (value, pointer)
558 conf (value, allocatable)
559 conf (value, subroutine)
560 conf (value, function)
561 conf (value, volatile_)
562 conf (value, dimension)
563 conf (value, codimension)
564 conf (value, external)
566 conf (codimension, result)
569 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
572 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
576 conf (is_protected, intrinsic)
577 conf (is_protected, in_common)
579 conf (asynchronous, intrinsic)
580 conf (asynchronous, external)
582 conf (volatile_, intrinsic)
583 conf (volatile_, external)
585 if (attr->volatile_ && attr->intent == INTENT_IN)
592 conf (procedure, allocatable)
593 conf (procedure, dimension)
594 conf (procedure, codimension)
595 conf (procedure, intrinsic)
596 conf (procedure, target)
597 conf (procedure, value)
598 conf (procedure, volatile_)
599 conf (procedure, asynchronous)
600 conf (procedure, entry)
602 a1 = gfc_code2string (flavors, attr->flavor);
604 if (attr->in_namelist
605 && attr->flavor != FL_VARIABLE
606 && attr->flavor != FL_PROCEDURE
607 && attr->flavor != FL_UNKNOWN)
613 switch (attr->flavor)
623 conf2 (asynchronous);
626 conf2 (is_protected);
636 conf2 (threadprivate);
638 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
640 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
641 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
648 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
662 /* Conflicts with INTENT, SAVE and RESULT will be checked
663 at resolution stage, see "resolve_fl_procedure". */
665 if (attr->subroutine)
671 conf2 (asynchronous);
676 if (!attr->proc_pointer)
677 conf2 (threadprivate);
680 if (!attr->proc_pointer)
685 case PROC_ST_FUNCTION:
695 conf2 (threadprivate);
715 conf2 (threadprivate);
718 if (attr->intent != INTENT_UNKNOWN)
735 conf2 (is_protected);
741 conf2 (asynchronous);
742 conf2 (threadprivate);
757 gfc_error ("%s attribute conflicts with %s attribute at %L",
760 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
761 a1, a2, name, where);
768 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
769 "with %s attribute at %L", a1, a2,
774 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
775 "with %s attribute in '%s' at %L",
776 a1, a2, name, where);
785 /* Mark a symbol as referenced. */
788 gfc_set_sym_referenced (gfc_symbol *sym)
791 if (sym->attr.referenced)
794 sym->attr.referenced = 1;
796 /* Remember which order dummy variables are accessed in. */
798 sym->dummy_order = next_dummy_order++;
802 /* Common subroutine called by attribute changing subroutines in order
803 to prevent them from changing a symbol that has been
804 use-associated. Returns zero if it is OK to change the symbol,
808 check_used (symbol_attribute *attr, const char *name, locus *where)
811 if (attr->use_assoc == 0)
815 where = &gfc_current_locus;
818 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
821 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
828 /* Generate an error because of a duplicate attribute. */
831 duplicate_attr (const char *attr, locus *where)
835 where = &gfc_current_locus;
837 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
842 gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
843 locus *where ATTRIBUTE_UNUSED)
845 attr->ext_attr |= 1 << ext_attr;
850 /* Called from decl.c (attr_decl1) to check attributes, when declared
854 gfc_add_attribute (symbol_attribute *attr, locus *where)
856 if (check_used (attr, NULL, where))
859 return check_conflict (attr, NULL, where);
864 gfc_add_allocatable (symbol_attribute *attr, locus *where)
867 if (check_used (attr, NULL, where))
870 if (attr->allocatable)
872 duplicate_attr ("ALLOCATABLE", where);
876 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
877 && gfc_find_state (COMP_INTERFACE) == FAILURE)
879 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
884 attr->allocatable = 1;
885 return check_conflict (attr, NULL, where);
890 gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
893 if (check_used (attr, name, where))
896 if (attr->codimension)
898 duplicate_attr ("CODIMENSION", where);
902 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
903 && gfc_find_state (COMP_INTERFACE) == FAILURE)
905 gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
906 "at %L", name, where);
910 attr->codimension = 1;
911 return check_conflict (attr, name, where);
916 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
919 if (check_used (attr, name, where))
924 duplicate_attr ("DIMENSION", where);
928 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
929 && gfc_find_state (COMP_INTERFACE) == FAILURE)
931 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
932 "at %L", name, where);
937 return check_conflict (attr, name, where);
942 gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
945 if (check_used (attr, name, where))
948 attr->contiguous = 1;
949 return check_conflict (attr, name, where);
954 gfc_add_external (symbol_attribute *attr, locus *where)
957 if (check_used (attr, NULL, where))
962 duplicate_attr ("EXTERNAL", where);
966 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
969 attr->proc_pointer = 1;
974 return check_conflict (attr, NULL, where);
979 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
982 if (check_used (attr, NULL, where))
987 duplicate_attr ("INTRINSIC", where);
993 return check_conflict (attr, NULL, where);
998 gfc_add_optional (symbol_attribute *attr, locus *where)
1001 if (check_used (attr, NULL, where))
1006 duplicate_attr ("OPTIONAL", where);
1011 return check_conflict (attr, NULL, where);
1016 gfc_add_pointer (symbol_attribute *attr, locus *where)
1019 if (check_used (attr, NULL, where))
1022 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
1023 && gfc_find_state (COMP_INTERFACE) == FAILURE))
1025 duplicate_attr ("POINTER", where);
1029 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
1030 || (attr->if_source == IFSRC_IFBODY
1031 && gfc_find_state (COMP_INTERFACE) == FAILURE))
1032 attr->proc_pointer = 1;
1036 return check_conflict (attr, NULL, where);
1041 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
1044 if (check_used (attr, NULL, where))
1047 attr->cray_pointer = 1;
1048 return check_conflict (attr, NULL, where);
1053 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
1056 if (check_used (attr, NULL, where))
1059 if (attr->cray_pointee)
1061 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1062 " statements", where);
1066 attr->cray_pointee = 1;
1067 return check_conflict (attr, NULL, where);
1072 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1074 if (check_used (attr, name, where))
1077 if (attr->is_protected)
1079 if (gfc_notify_std (GFC_STD_LEGACY,
1080 "Duplicate PROTECTED attribute specified at %L",
1086 attr->is_protected = 1;
1087 return check_conflict (attr, name, where);
1092 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1095 if (check_used (attr, name, where))
1099 return check_conflict (attr, name, where);
1104 gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
1108 if (check_used (attr, name, where))
1111 if (s == SAVE_EXPLICIT && gfc_pure (NULL))
1114 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1119 if (s == SAVE_EXPLICIT && gfc_implicit_pure (NULL))
1120 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1122 if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
1124 if (gfc_notify_std (GFC_STD_LEGACY,
1125 "Duplicate SAVE attribute specified at %L",
1132 return check_conflict (attr, name, where);
1137 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1140 if (check_used (attr, name, where))
1145 if (gfc_notify_std (GFC_STD_LEGACY,
1146 "Duplicate VALUE attribute specified at %L",
1153 return check_conflict (attr, name, where);
1158 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1160 /* No check_used needed as 11.2.1 of the F2003 standard allows
1161 that the local identifier made accessible by a use statement can be
1162 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1164 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1165 if (gfc_notify_std (GFC_STD_LEGACY,
1166 "Duplicate VOLATILE attribute specified at %L", where)
1170 attr->volatile_ = 1;
1171 attr->volatile_ns = gfc_current_ns;
1172 return check_conflict (attr, name, where);
1177 gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1179 /* No check_used needed as 11.2.1 of the F2003 standard allows
1180 that the local identifier made accessible by a use statement can be
1181 given a ASYNCHRONOUS attribute. */
1183 if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
1184 if (gfc_notify_std (GFC_STD_LEGACY,
1185 "Duplicate ASYNCHRONOUS attribute specified at %L",
1189 attr->asynchronous = 1;
1190 attr->asynchronous_ns = gfc_current_ns;
1191 return check_conflict (attr, name, where);
1196 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1199 if (check_used (attr, name, where))
1202 if (attr->threadprivate)
1204 duplicate_attr ("THREADPRIVATE", where);
1208 attr->threadprivate = 1;
1209 return check_conflict (attr, name, where);
1214 gfc_add_target (symbol_attribute *attr, locus *where)
1217 if (check_used (attr, NULL, where))
1222 duplicate_attr ("TARGET", where);
1227 return check_conflict (attr, NULL, where);
1232 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1235 if (check_used (attr, name, where))
1238 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1240 return check_conflict (attr, name, where);
1245 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1248 if (check_used (attr, name, where))
1251 /* Duplicate attribute already checked for. */
1252 attr->in_common = 1;
1253 return check_conflict (attr, name, where);
1258 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1261 /* Duplicate attribute already checked for. */
1262 attr->in_equivalence = 1;
1263 if (check_conflict (attr, name, where) == FAILURE)
1266 if (attr->flavor == FL_VARIABLE)
1269 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1274 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1277 if (check_used (attr, name, where))
1281 return check_conflict (attr, name, where);
1286 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1289 attr->in_namelist = 1;
1290 return check_conflict (attr, name, where);
1295 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1298 if (check_used (attr, name, where))
1302 return check_conflict (attr, name, where);
1307 gfc_add_elemental (symbol_attribute *attr, locus *where)
1310 if (check_used (attr, NULL, where))
1313 if (attr->elemental)
1315 duplicate_attr ("ELEMENTAL", where);
1319 attr->elemental = 1;
1320 return check_conflict (attr, NULL, where);
1325 gfc_add_pure (symbol_attribute *attr, locus *where)
1328 if (check_used (attr, NULL, where))
1333 duplicate_attr ("PURE", where);
1338 return check_conflict (attr, NULL, where);
1343 gfc_add_recursive (symbol_attribute *attr, locus *where)
1346 if (check_used (attr, NULL, where))
1349 if (attr->recursive)
1351 duplicate_attr ("RECURSIVE", where);
1355 attr->recursive = 1;
1356 return check_conflict (attr, NULL, where);
1361 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1364 if (check_used (attr, name, where))
1369 duplicate_attr ("ENTRY", where);
1374 return check_conflict (attr, name, where);
1379 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1382 if (attr->flavor != FL_PROCEDURE
1383 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1387 return check_conflict (attr, name, where);
1392 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1395 if (attr->flavor != FL_PROCEDURE
1396 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1399 attr->subroutine = 1;
1400 return check_conflict (attr, name, where);
1405 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1408 if (attr->flavor != FL_PROCEDURE
1409 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1413 return check_conflict (attr, name, where);
1418 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1421 if (check_used (attr, NULL, where))
1424 if (attr->flavor != FL_PROCEDURE
1425 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1428 if (attr->procedure)
1430 duplicate_attr ("PROCEDURE", where);
1434 attr->procedure = 1;
1436 return check_conflict (attr, NULL, where);
1441 gfc_add_abstract (symbol_attribute* attr, locus* where)
1445 duplicate_attr ("ABSTRACT", where);
1454 /* Flavors are special because some flavors are not what Fortran
1455 considers attributes and can be reaffirmed multiple times. */
1458 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1462 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1463 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1464 || f == FL_NAMELIST) && check_used (attr, name, where))
1467 if (attr->flavor == f && f == FL_VARIABLE)
1470 if (attr->flavor != FL_UNKNOWN)
1473 where = &gfc_current_locus;
1476 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1477 gfc_code2string (flavors, attr->flavor), name,
1478 gfc_code2string (flavors, f), where);
1480 gfc_error ("%s attribute conflicts with %s attribute at %L",
1481 gfc_code2string (flavors, attr->flavor),
1482 gfc_code2string (flavors, f), where);
1489 return check_conflict (attr, name, where);
1494 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1495 const char *name, locus *where)
1498 if (check_used (attr, name, where))
1501 if (attr->flavor != FL_PROCEDURE
1502 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1506 where = &gfc_current_locus;
1508 if (attr->proc != PROC_UNKNOWN)
1510 gfc_error ("%s procedure at %L is already declared as %s procedure",
1511 gfc_code2string (procedures, t), where,
1512 gfc_code2string (procedures, attr->proc));
1519 /* Statement functions are always scalar and functions. */
1520 if (t == PROC_ST_FUNCTION
1521 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1522 || attr->dimension))
1525 return check_conflict (attr, name, where);
1530 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1533 if (check_used (attr, NULL, where))
1536 if (attr->intent == INTENT_UNKNOWN)
1538 attr->intent = intent;
1539 return check_conflict (attr, NULL, where);
1543 where = &gfc_current_locus;
1545 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1546 gfc_intent_string (attr->intent),
1547 gfc_intent_string (intent), where);
1553 /* No checks for use-association in public and private statements. */
1556 gfc_add_access (symbol_attribute *attr, gfc_access access,
1557 const char *name, locus *where)
1560 if (attr->access == ACCESS_UNKNOWN
1561 || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1563 attr->access = access;
1564 return check_conflict (attr, name, where);
1568 where = &gfc_current_locus;
1569 gfc_error ("ACCESS specification at %L was already specified", where);
1575 /* Set the is_bind_c field for the given symbol_attribute. */
1578 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1579 int is_proc_lang_bind_spec)
1582 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1583 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1584 "variables or common blocks", where);
1585 else if (attr->is_bind_c)
1586 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1588 attr->is_bind_c = 1;
1591 where = &gfc_current_locus;
1593 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1597 return check_conflict (attr, name, where);
1601 /* Set the extension field for the given symbol_attribute. */
1604 gfc_add_extension (symbol_attribute *attr, locus *where)
1607 where = &gfc_current_locus;
1609 if (attr->extension)
1610 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1612 attr->extension = 1;
1614 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
1623 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1624 gfc_formal_arglist * formal, locus *where)
1627 if (check_used (&sym->attr, sym->name, where))
1631 where = &gfc_current_locus;
1633 if (sym->attr.if_source != IFSRC_UNKNOWN
1634 && sym->attr.if_source != IFSRC_DECL)
1636 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1641 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1643 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1644 "body", sym->name, where);
1648 sym->formal = formal;
1649 sym->attr.if_source = source;
1655 /* Add a type to a symbol. */
1658 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1664 where = &gfc_current_locus;
1667 type = sym->result->ts.type;
1669 type = sym->ts.type;
1671 if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
1672 type = sym->ns->proc_name->ts.type;
1674 if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
1676 if (sym->attr.use_assoc)
1677 gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
1678 "use-associated at %L", sym->name, where, sym->module,
1681 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1682 where, gfc_basic_typename (type));
1686 if (sym->attr.procedure && sym->ts.interface)
1688 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1689 sym->name, where, gfc_basic_typename (ts->type));
1693 flavor = sym->attr.flavor;
1695 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1696 || flavor == FL_LABEL
1697 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1698 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1700 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1709 /* Clears all attributes. */
1712 gfc_clear_attr (symbol_attribute *attr)
1714 memset (attr, 0, sizeof (symbol_attribute));
1718 /* Check for missing attributes in the new symbol. Currently does
1719 nothing, but it's not clear that it is unnecessary yet. */
1722 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1723 locus *where ATTRIBUTE_UNUSED)
1730 /* Copy an attribute to a symbol attribute, bit by bit. Some
1731 attributes have a lot of side-effects but cannot be present given
1732 where we are called from, so we ignore some bits. */
1735 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1737 int is_proc_lang_bind_spec;
1739 /* In line with the other attributes, we only add bits but do not remove
1740 them; cf. also PR 41034. */
1741 dest->ext_attr |= src->ext_attr;
1743 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1746 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1748 if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE)
1750 if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE)
1752 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1754 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1756 if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1758 if (src->save && gfc_add_save (dest, src->save, NULL, where) == FAILURE)
1760 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1762 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1764 if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
1766 if (src->threadprivate
1767 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1769 if (src->target && gfc_add_target (dest, where) == FAILURE)
1771 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1773 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1778 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1781 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1784 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1786 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1788 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1791 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1793 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1795 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1797 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1800 if (src->flavor != FL_UNKNOWN
1801 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1804 if (src->intent != INTENT_UNKNOWN
1805 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1808 if (src->access != ACCESS_UNKNOWN
1809 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1812 if (gfc_missing_attr (dest, where) == FAILURE)
1815 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1817 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1820 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1822 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1826 if (src->is_c_interop)
1827 dest->is_c_interop = 1;
1831 if (src->external && gfc_add_external (dest, where) == FAILURE)
1833 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1835 if (src->proc_pointer)
1836 dest->proc_pointer = 1;
1845 /************** Component name management ************/
1847 /* Component names of a derived type form their own little namespaces
1848 that are separate from all other spaces. The space is composed of
1849 a singly linked list of gfc_component structures whose head is
1850 located in the parent symbol. */
1853 /* Add a component name to a symbol. The call fails if the name is
1854 already present. On success, the component pointer is modified to
1855 point to the additional component structure. */
1858 gfc_add_component (gfc_symbol *sym, const char *name,
1859 gfc_component **component)
1861 gfc_component *p, *tail;
1865 for (p = sym->components; p; p = p->next)
1867 if (strcmp (p->name, name) == 0)
1869 gfc_error ("Component '%s' at %C already declared at %L",
1877 if (sym->attr.extension
1878 && gfc_find_component (sym->components->ts.u.derived, name, true, true))
1880 gfc_error ("Component '%s' at %C already in the parent type "
1881 "at %L", name, &sym->components->ts.u.derived->declared_at);
1885 /* Allocate a new component. */
1886 p = gfc_get_component ();
1889 sym->components = p;
1893 p->name = gfc_get_string (name);
1894 p->loc = gfc_current_locus;
1895 p->ts.type = BT_UNKNOWN;
1902 /* Recursive function to switch derived types of all symbol in a
1906 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1914 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
1915 sym->ts.u.derived = to;
1917 switch_types (st->left, from, to);
1918 switch_types (st->right, from, to);
1922 /* This subroutine is called when a derived type is used in order to
1923 make the final determination about which version to use. The
1924 standard requires that a type be defined before it is 'used', but
1925 such types can appear in IMPLICIT statements before the actual
1926 definition. 'Using' in this context means declaring a variable to
1927 be that type or using the type constructor.
1929 If a type is used and the components haven't been defined, then we
1930 have to have a derived type in a parent unit. We find the node in
1931 the other namespace and point the symtree node in this namespace to
1932 that node. Further reference to this name point to the correct
1933 node. If we can't find the node in a parent namespace, then we have
1936 This subroutine takes a pointer to a symbol node and returns a
1937 pointer to the translated node or NULL for an error. Usually there
1938 is no translation and we return the node we were passed. */
1941 gfc_use_derived (gfc_symbol *sym)
1948 if (!sym) return NULL;
1950 if (sym->components != NULL || sym->attr.zero_comp)
1951 return sym; /* Already defined. */
1953 if (sym->ns->parent == NULL)
1956 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1958 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1962 if (s == NULL || s->attr.flavor != FL_DERIVED)
1965 /* Get rid of symbol sym, translating all references to s. */
1966 for (i = 0; i < GFC_LETTERS; i++)
1968 t = &sym->ns->default_type[i];
1969 if (t->u.derived == sym)
1973 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1978 /* Unlink from list of modified symbols. */
1979 gfc_commit_symbol (sym);
1981 switch_types (sym->ns->sym_root, sym, s);
1983 /* TODO: Also have to replace sym -> s in other lists like
1984 namelists, common lists and interface lists. */
1985 gfc_free_symbol (sym);
1990 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1996 /* Given a derived type node and a component name, try to locate the
1997 component structure. Returns the NULL pointer if the component is
1998 not found or the components are private. If noaccess is set, no access
2002 gfc_find_component (gfc_symbol *sym, const char *name,
2003 bool noaccess, bool silent)
2007 if (name == NULL || sym == NULL)
2010 sym = gfc_use_derived (sym);
2015 for (p = sym->components; p; p = p->next)
2016 if (strcmp (p->name, name) == 0)
2020 && sym->attr.extension
2021 && sym->components->ts.type == BT_DERIVED)
2023 p = gfc_find_component (sym->components->ts.u.derived, name,
2025 /* Do not overwrite the error. */
2030 if (p == NULL && !silent)
2031 gfc_error ("'%s' at %C is not a member of the '%s' structure",
2034 else if (sym->attr.use_assoc && !noaccess)
2036 bool is_parent_comp = sym->attr.extension && (p == sym->components);
2037 if (p->attr.access == ACCESS_PRIVATE ||
2038 (p->attr.access != ACCESS_PUBLIC
2039 && sym->component_access == ACCESS_PRIVATE
2040 && !is_parent_comp))
2043 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2053 /* Given a symbol, free all of the component structures and everything
2057 free_components (gfc_component *p)
2065 gfc_free_array_spec (p->as);
2066 gfc_free_expr (p->initializer);
2068 gfc_free_formal_arglist (p->formal);
2069 gfc_free_namespace (p->formal_ns);
2076 /******************** Statement label management ********************/
2078 /* Comparison function for statement labels, used for managing the
2082 compare_st_labels (void *a1, void *b1)
2084 int a = ((gfc_st_label *) a1)->value;
2085 int b = ((gfc_st_label *) b1)->value;
2091 /* Free a single gfc_st_label structure, making sure the tree is not
2092 messed up. This function is called only when some parse error
2096 gfc_free_st_label (gfc_st_label *label)
2102 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
2104 if (label->format != NULL)
2105 gfc_free_expr (label->format);
2111 /* Free a whole tree of gfc_st_label structures. */
2114 free_st_labels (gfc_st_label *label)
2120 free_st_labels (label->left);
2121 free_st_labels (label->right);
2123 if (label->format != NULL)
2124 gfc_free_expr (label->format);
2129 /* Given a label number, search for and return a pointer to the label
2130 structure, creating it if it does not exist. */
2133 gfc_get_st_label (int labelno)
2138 if (gfc_current_state () == COMP_DERIVED)
2139 ns = gfc_current_block ()->f2k_derived;
2142 /* Find the namespace of the scoping unit:
2143 If we're in a BLOCK construct, jump to the parent namespace. */
2144 ns = gfc_current_ns;
2145 while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2149 /* First see if the label is already in this namespace. */
2153 if (lp->value == labelno)
2156 if (lp->value < labelno)
2162 lp = XCNEW (gfc_st_label);
2164 lp->value = labelno;
2165 lp->defined = ST_LABEL_UNKNOWN;
2166 lp->referenced = ST_LABEL_UNKNOWN;
2168 gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2174 /* Called when a statement with a statement label is about to be
2175 accepted. We add the label to the list of the current namespace,
2176 making sure it hasn't been defined previously and referenced
2180 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2184 labelno = lp->value;
2186 if (lp->defined != ST_LABEL_UNKNOWN)
2187 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2188 &lp->where, label_locus);
2191 lp->where = *label_locus;
2195 case ST_LABEL_FORMAT:
2196 if (lp->referenced == ST_LABEL_TARGET)
2197 gfc_error ("Label %d at %C already referenced as branch target",
2200 lp->defined = ST_LABEL_FORMAT;
2204 case ST_LABEL_TARGET:
2205 if (lp->referenced == ST_LABEL_FORMAT)
2206 gfc_error ("Label %d at %C already referenced as a format label",
2209 lp->defined = ST_LABEL_TARGET;
2214 lp->defined = ST_LABEL_BAD_TARGET;
2215 lp->referenced = ST_LABEL_BAD_TARGET;
2221 /* Reference a label. Given a label and its type, see if that
2222 reference is consistent with what is known about that label,
2223 updating the unknown state. Returns FAILURE if something goes
2227 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2229 gfc_sl_type label_type;
2236 labelno = lp->value;
2238 if (lp->defined != ST_LABEL_UNKNOWN)
2239 label_type = lp->defined;
2242 label_type = lp->referenced;
2243 lp->where = gfc_current_locus;
2246 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2248 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2253 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2254 && type == ST_LABEL_FORMAT)
2256 gfc_error ("Label %d at %C previously used as branch target", labelno);
2261 lp->referenced = type;
2269 /************** Symbol table management subroutines ****************/
2271 /* Basic details: Fortran 95 requires a potentially unlimited number
2272 of distinct namespaces when compiling a program unit. This case
2273 occurs during a compilation of internal subprograms because all of
2274 the internal subprograms must be read before we can start
2275 generating code for the host.
2277 Given the tricky nature of the Fortran grammar, we must be able to
2278 undo changes made to a symbol table if the current interpretation
2279 of a statement is found to be incorrect. Whenever a symbol is
2280 looked up, we make a copy of it and link to it. All of these
2281 symbols are kept in a singly linked list so that we can commit or
2282 undo the changes at a later time.
2284 A symtree may point to a symbol node outside of its namespace. In
2285 this case, that symbol has been used as a host associated variable
2286 at some previous time. */
2288 /* Allocate a new namespace structure. Copies the implicit types from
2289 PARENT if PARENT_TYPES is set. */
2292 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2299 ns = XCNEW (gfc_namespace);
2300 ns->sym_root = NULL;
2301 ns->uop_root = NULL;
2302 ns->tb_sym_root = NULL;
2303 ns->finalizers = NULL;
2304 ns->default_access = ACCESS_UNKNOWN;
2305 ns->parent = parent;
2307 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2309 ns->operator_access[in] = ACCESS_UNKNOWN;
2310 ns->tb_op[in] = NULL;
2313 /* Initialize default implicit types. */
2314 for (i = 'a'; i <= 'z'; i++)
2316 ns->set_flag[i - 'a'] = 0;
2317 ts = &ns->default_type[i - 'a'];
2319 if (parent_types && ns->parent != NULL)
2321 /* Copy parent settings. */
2322 *ts = ns->parent->default_type[i - 'a'];
2326 if (gfc_option.flag_implicit_none != 0)
2332 if ('i' <= i && i <= 'n')
2334 ts->type = BT_INTEGER;
2335 ts->kind = gfc_default_integer_kind;
2340 ts->kind = gfc_default_real_kind;
2350 /* Comparison function for symtree nodes. */
2353 compare_symtree (void *_st1, void *_st2)
2355 gfc_symtree *st1, *st2;
2357 st1 = (gfc_symtree *) _st1;
2358 st2 = (gfc_symtree *) _st2;
2360 return strcmp (st1->name, st2->name);
2364 /* Allocate a new symtree node and associate it with the new symbol. */
2367 gfc_new_symtree (gfc_symtree **root, const char *name)
2371 st = XCNEW (gfc_symtree);
2372 st->name = gfc_get_string (name);
2374 gfc_insert_bbt (root, st, compare_symtree);
2379 /* Delete a symbol from the tree. Does not free the symbol itself! */
2382 gfc_delete_symtree (gfc_symtree **root, const char *name)
2384 gfc_symtree st, *st0;
2386 st0 = gfc_find_symtree (*root, name);
2388 st.name = gfc_get_string (name);
2389 gfc_delete_bbt (root, &st, compare_symtree);
2395 /* Given a root symtree node and a name, try to find the symbol within
2396 the namespace. Returns NULL if the symbol is not found. */
2399 gfc_find_symtree (gfc_symtree *st, const char *name)
2405 c = strcmp (name, st->name);
2409 st = (c < 0) ? st->left : st->right;
2416 /* Return a symtree node with a name that is guaranteed to be unique
2417 within the namespace and corresponds to an illegal fortran name. */
2420 gfc_get_unique_symtree (gfc_namespace *ns)
2422 char name[GFC_MAX_SYMBOL_LEN + 1];
2423 static int serial = 0;
2425 sprintf (name, "@%d", serial++);
2426 return gfc_new_symtree (&ns->sym_root, name);
2430 /* Given a name find a user operator node, creating it if it doesn't
2431 exist. These are much simpler than symbols because they can't be
2432 ambiguous with one another. */
2435 gfc_get_uop (const char *name)
2440 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2444 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2446 uop = st->n.uop = XCNEW (gfc_user_op);
2447 uop->name = gfc_get_string (name);
2448 uop->access = ACCESS_UNKNOWN;
2449 uop->ns = gfc_current_ns;
2455 /* Given a name find the user operator node. Returns NULL if it does
2459 gfc_find_uop (const char *name, gfc_namespace *ns)
2464 ns = gfc_current_ns;
2466 st = gfc_find_symtree (ns->uop_root, name);
2467 return (st == NULL) ? NULL : st->n.uop;
2471 /* Remove a gfc_symbol structure and everything it points to. */
2474 gfc_free_symbol (gfc_symbol *sym)
2480 gfc_free_array_spec (sym->as);
2482 free_components (sym->components);
2484 gfc_free_expr (sym->value);
2486 gfc_free_namelist (sym->namelist);
2488 gfc_free_namespace (sym->formal_ns);
2490 if (!sym->attr.generic_copy)
2491 gfc_free_interface (sym->generic);
2493 gfc_free_formal_arglist (sym->formal);
2495 gfc_free_namespace (sym->f2k_derived);
2501 /* Decrease the reference counter and free memory when we reach zero. */
2504 gfc_release_symbol (gfc_symbol *sym)
2509 if (sym->formal_ns != NULL && sym->refs == 2)
2511 /* As formal_ns contains a reference to sym, delete formal_ns just
2512 before the deletion of sym. */
2513 gfc_namespace *ns = sym->formal_ns;
2514 sym->formal_ns = NULL;
2515 gfc_free_namespace (ns);
2522 gcc_assert (sym->refs == 0);
2523 gfc_free_symbol (sym);
2527 /* Allocate and initialize a new symbol node. */
2530 gfc_new_symbol (const char *name, gfc_namespace *ns)
2534 p = XCNEW (gfc_symbol);
2536 gfc_clear_ts (&p->ts);
2537 gfc_clear_attr (&p->attr);
2540 p->declared_at = gfc_current_locus;
2542 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2543 gfc_internal_error ("new_symbol(): Symbol name too long");
2545 p->name = gfc_get_string (name);
2547 /* Make sure flags for symbol being C bound are clear initially. */
2548 p->attr.is_bind_c = 0;
2549 p->attr.is_iso_c = 0;
2550 /* Make sure the binding label field has a Nul char to start. */
2551 p->binding_label[0] = '\0';
2553 /* Clear the ptrs we may need. */
2554 p->common_block = NULL;
2555 p->f2k_derived = NULL;
2562 /* Generate an error if a symbol is ambiguous. */
2565 ambiguous_symbol (const char *name, gfc_symtree *st)
2568 if (st->n.sym->module)
2569 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2570 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2572 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2573 "from current program unit", name, st->n.sym->name);
2577 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2578 selector on the stack. If yes, replace it by the corresponding temporary. */
2581 select_type_insert_tmp (gfc_symtree **st)
2583 gfc_select_type_stack *stack = select_type_stack;
2584 for (; stack; stack = stack->prev)
2585 if ((*st)->n.sym == stack->selector && stack->tmp)
2590 /* Look for a symtree in the current procedure -- that is, go up to
2591 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
2594 gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
2598 gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
2602 if (!ns->construct_entities)
2611 /* Search for a symtree starting in the current namespace, resorting to
2612 any parent namespaces if requested by a nonzero parent_flag.
2613 Returns nonzero if the name is ambiguous. */
2616 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2617 gfc_symtree **result)
2622 ns = gfc_current_ns;
2626 st = gfc_find_symtree (ns->sym_root, name);
2629 select_type_insert_tmp (&st);
2632 /* Ambiguous generic interfaces are permitted, as long
2633 as the specific interfaces are different. */
2634 if (st->ambiguous && !st->n.sym->attr.generic)
2636 ambiguous_symbol (name, st);
2655 /* Same, but returns the symbol instead. */
2658 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2659 gfc_symbol **result)
2664 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2669 *result = st->n.sym;
2675 /* Save symbol with the information necessary to back it out. */
2678 save_symbol_data (gfc_symbol *sym)
2681 if (sym->gfc_new || sym->old_symbol != NULL)
2684 sym->old_symbol = XCNEW (gfc_symbol);
2685 *(sym->old_symbol) = *sym;
2687 sym->tlink = changed_syms;
2692 /* Given a name, find a symbol, or create it if it does not exist yet
2693 in the current namespace. If the symbol is found we make sure that
2696 The integer return code indicates
2698 1 The symbol name was ambiguous
2699 2 The name meant to be established was already host associated.
2701 So if the return value is nonzero, then an error was issued. */
2704 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2705 bool allow_subroutine)
2710 /* This doesn't usually happen during resolution. */
2712 ns = gfc_current_ns;
2714 /* Try to find the symbol in ns. */
2715 st = gfc_find_symtree (ns->sym_root, name);
2719 /* If not there, create a new symbol. */
2720 p = gfc_new_symbol (name, ns);
2722 /* Add to the list of tentative symbols. */
2723 p->old_symbol = NULL;
2724 p->tlink = changed_syms;
2729 st = gfc_new_symtree (&ns->sym_root, name);
2736 /* Make sure the existing symbol is OK. Ambiguous
2737 generic interfaces are permitted, as long as the
2738 specific interfaces are different. */
2739 if (st->ambiguous && !st->n.sym->attr.generic)
2741 ambiguous_symbol (name, st);
2746 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2747 && !(allow_subroutine && p->attr.subroutine)
2748 && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2749 && (ns->has_import_set || p->attr.imported)))
2751 /* Symbol is from another namespace. */
2752 gfc_error ("Symbol '%s' at %C has already been host associated",
2759 /* Copy in case this symbol is changed. */
2760 save_symbol_data (p);
2769 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2774 i = gfc_get_sym_tree (name, ns, &st, false);
2779 *result = st->n.sym;
2786 /* Subroutine that searches for a symbol, creating it if it doesn't
2787 exist, but tries to host-associate the symbol if possible. */
2790 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2795 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2799 save_symbol_data (st->n.sym);
2804 if (gfc_current_ns->parent != NULL)
2806 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2817 return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2822 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2827 i = gfc_get_ha_sym_tree (name, &st);
2830 *result = st->n.sym;
2837 /* Undoes all the changes made to symbols in the current statement.
2838 This subroutine is made simpler due to the fact that attributes are
2839 never removed once added. */
2842 gfc_undo_symbols (void)
2844 gfc_symbol *p, *q, *old;
2845 tentative_tbp *tbp, *tbq;
2847 for (p = changed_syms; p; p = q)
2853 /* Symbol was new. */
2854 if (p->attr.in_common && p->common_block && p->common_block->head)
2856 /* If the symbol was added to any common block, it
2857 needs to be removed to stop the resolver looking
2858 for a (possibly) dead symbol. */
2860 if (p->common_block->head == p)
2861 p->common_block->head = p->common_next;
2864 gfc_symbol *cparent, *csym;
2866 cparent = p->common_block->head;
2867 csym = cparent->common_next;
2872 csym = csym->common_next;
2875 gcc_assert(cparent->common_next == p);
2877 cparent->common_next = csym->common_next;
2881 gfc_delete_symtree (&p->ns->sym_root, p->name);
2883 gfc_release_symbol (p);
2887 /* Restore previous state of symbol. Just copy simple stuff. */
2889 old = p->old_symbol;
2891 p->ts.type = old->ts.type;
2892 p->ts.kind = old->ts.kind;
2894 p->attr = old->attr;
2896 if (p->value != old->value)
2898 gfc_free_expr (old->value);
2902 if (p->as != old->as)
2905 gfc_free_array_spec (p->as);
2909 p->generic = old->generic;
2910 p->component_access = old->component_access;
2912 if (p->namelist != NULL && old->namelist == NULL)
2914 gfc_free_namelist (p->namelist);
2919 if (p->namelist_tail != old->namelist_tail)
2921 gfc_free_namelist (old->namelist_tail);
2922 old->namelist_tail->next = NULL;
2926 p->namelist_tail = old->namelist_tail;
2928 if (p->formal != old->formal)
2930 gfc_free_formal_arglist (p->formal);
2931 p->formal = old->formal;
2934 free (p->old_symbol);
2935 p->old_symbol = NULL;
2939 changed_syms = NULL;
2941 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2944 /* Procedure is already marked `error' by default. */
2947 tentative_tbp_list = NULL;
2951 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2952 components of old_symbol that might need deallocation are the "allocatables"
2953 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2954 namelist_tail. In case these differ between old_symbol and sym, it's just
2955 because sym->namelist has gotten a few more items. */
2958 free_old_symbol (gfc_symbol *sym)
2961 if (sym->old_symbol == NULL)
2964 if (sym->old_symbol->as != sym->as)
2965 gfc_free_array_spec (sym->old_symbol->as);
2967 if (sym->old_symbol->value != sym->value)
2968 gfc_free_expr (sym->old_symbol->value);
2970 if (sym->old_symbol->formal != sym->formal)
2971 gfc_free_formal_arglist (sym->old_symbol->formal);
2973 free (sym->old_symbol);
2974 sym->old_symbol = NULL;
2978 /* Makes the changes made in the current statement permanent-- gets
2979 rid of undo information. */
2982 gfc_commit_symbols (void)
2985 tentative_tbp *tbp, *tbq;
2987 for (p = changed_syms; p; p = q)
2993 free_old_symbol (p);
2995 changed_syms = NULL;
2997 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
3000 tbp->proc->error = 0;
3003 tentative_tbp_list = NULL;
3007 /* Makes the changes made in one symbol permanent -- gets rid of undo
3011 gfc_commit_symbol (gfc_symbol *sym)
3015 if (changed_syms == sym)
3016 changed_syms = sym->tlink;
3019 for (p = changed_syms; p; p = p->tlink)
3020 if (p->tlink == sym)
3022 p->tlink = sym->tlink;
3031 free_old_symbol (sym);
3035 /* Recursively free trees containing type-bound procedures. */
3038 free_tb_tree (gfc_symtree *t)
3043 free_tb_tree (t->left);
3044 free_tb_tree (t->right);
3046 /* TODO: Free type-bound procedure structs themselves; probably needs some
3047 sort of ref-counting mechanism. */
3053 /* Recursive function that deletes an entire tree and all the common
3054 head structures it points to. */
3057 free_common_tree (gfc_symtree * common_tree)
3059 if (common_tree == NULL)
3062 free_common_tree (common_tree->left);
3063 free_common_tree (common_tree->right);
3069 /* Recursive function that deletes an entire tree and all the user
3070 operator nodes that it contains. */
3073 free_uop_tree (gfc_symtree *uop_tree)
3075 if (uop_tree == NULL)
3078 free_uop_tree (uop_tree->left);
3079 free_uop_tree (uop_tree->right);
3081 gfc_free_interface (uop_tree->n.uop->op);
3082 free (uop_tree->n.uop);
3087 /* Recursive function that deletes an entire tree and all the symbols
3088 that it contains. */
3091 free_sym_tree (gfc_symtree *sym_tree)
3093 if (sym_tree == NULL)
3096 free_sym_tree (sym_tree->left);
3097 free_sym_tree (sym_tree->right);
3099 gfc_release_symbol (sym_tree->n.sym);
3104 /* Free the derived type list. */
3107 gfc_free_dt_list (void)
3109 gfc_dt_list *dt, *n;
3111 for (dt = gfc_derived_types; dt; dt = n)
3117 gfc_derived_types = NULL;
3121 /* Free the gfc_equiv_info's. */
3124 gfc_free_equiv_infos (gfc_equiv_info *s)
3128 gfc_free_equiv_infos (s->next);
3133 /* Free the gfc_equiv_lists. */
3136 gfc_free_equiv_lists (gfc_equiv_list *l)
3140 gfc_free_equiv_lists (l->next);
3141 gfc_free_equiv_infos (l->equiv);
3146 /* Free a finalizer procedure list. */
3149 gfc_free_finalizer (gfc_finalizer* el)
3153 gfc_release_symbol (el->proc_sym);
3159 gfc_free_finalizer_list (gfc_finalizer* list)
3163 gfc_finalizer* current = list;
3165 gfc_free_finalizer (current);
3170 /* Create a new gfc_charlen structure and add it to a namespace.
3171 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3174 gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3177 cl = gfc_get_charlen ();
3182 /* Put into namespace, but don't allow reject_statement
3183 to free it if old_cl is given. */
3184 gfc_charlen **prev = &ns->cl_list;
3185 cl->next = ns->old_cl_list;
3186 while (*prev != ns->old_cl_list)
3187 prev = &(*prev)->next;
3189 ns->old_cl_list = cl;
3190 cl->length = gfc_copy_expr (old_cl->length);
3191 cl->length_from_typespec = old_cl->length_from_typespec;
3192 cl->backend_decl = old_cl->backend_decl;
3193 cl->passed_length = old_cl->passed_length;
3194 cl->resolved = old_cl->resolved;
3198 /* Put into namespace. */
3199 cl->next = ns->cl_list;
3207 /* Free the charlen list from cl to end (end is not freed).
3208 Free the whole list if end is NULL. */
3210 void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3214 for (; cl != end; cl = cl2)
3219 gfc_free_expr (cl->length);
3225 /* Free entry list structs. */
3228 free_entry_list (gfc_entry_list *el)
3230 gfc_entry_list *next;
3237 free_entry_list (next);
3241 /* Free a namespace structure and everything below it. Interface
3242 lists associated with intrinsic operators are not freed. These are
3243 taken care of when a specific name is freed. */
3246 gfc_free_namespace (gfc_namespace *ns)
3248 gfc_namespace *p, *q;
3257 gcc_assert (ns->refs == 0);
3259 gfc_free_statements (ns->code);
3261 free_sym_tree (ns->sym_root);
3262 free_uop_tree (ns->uop_root);
3263 free_common_tree (ns->common_root);
3264 free_tb_tree (ns->tb_sym_root);
3265 free_tb_tree (ns->tb_uop_root);
3266 gfc_free_finalizer_list (ns->finalizers);
3267 gfc_free_charlen (ns->cl_list, NULL);
3268 free_st_labels (ns->st_labels);
3270 free_entry_list (ns->entries);
3271 gfc_free_equiv (ns->equiv);
3272 gfc_free_equiv_lists (ns->equiv_lists);
3273 gfc_free_use_stmts (ns->use_stmts);
3275 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3276 gfc_free_interface (ns->op[i]);
3278 gfc_free_data (ns->data);
3282 /* Recursively free any contained namespaces. */
3287 gfc_free_namespace (q);
3293 gfc_symbol_init_2 (void)
3296 gfc_current_ns = gfc_get_namespace (NULL, 0);
3301 gfc_symbol_done_2 (void)
3304 gfc_free_namespace (gfc_current_ns);
3305 gfc_current_ns = NULL;
3306 gfc_free_dt_list ();
3310 /* Clear mark bits from symbol nodes associated with a symtree node. */
3313 clear_sym_mark (gfc_symtree *st)
3316 st->n.sym->mark = 0;
3320 /* Recursively traverse the symtree nodes. */
3323 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
3328 gfc_traverse_symtree (st->left, func);
3330 gfc_traverse_symtree (st->right, func);
3334 /* Recursive namespace traversal function. */
3337 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
3343 traverse_ns (st->left, func);
3345 if (st->n.sym->mark == 0)
3346 (*func) (st->n.sym);
3347 st->n.sym->mark = 1;
3349 traverse_ns (st->right, func);
3353 /* Call a given function for all symbols in the namespace. We take
3354 care that each gfc_symbol node is called exactly once. */
3357 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3360 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3362 traverse_ns (ns->sym_root, func);
3366 /* Return TRUE when name is the name of an intrinsic type. */
3369 gfc_is_intrinsic_typename (const char *name)
3371 if (strcmp (name, "integer") == 0
3372 || strcmp (name, "real") == 0
3373 || strcmp (name, "character") == 0
3374 || strcmp (name, "logical") == 0
3375 || strcmp (name, "complex") == 0
3376 || strcmp (name, "doubleprecision") == 0
3377 || strcmp (name, "doublecomplex") == 0)
3384 /* Return TRUE if the symbol is an automatic variable. */
3387 gfc_is_var_automatic (gfc_symbol *sym)
3389 /* Pointer and allocatable variables are never automatic. */
3390 if (sym->attr.pointer || sym->attr.allocatable)
3392 /* Check for arrays with non-constant size. */
3393 if (sym->attr.dimension && sym->as
3394 && !gfc_is_compile_time_shape (sym->as))
3396 /* Check for non-constant length character variables. */
3397 if (sym->ts.type == BT_CHARACTER
3399 && !gfc_is_constant_expr (sym->ts.u.cl->length))
3404 /* Given a symbol, mark it as SAVEd if it is allowed. */
3407 save_symbol (gfc_symbol *sym)
3410 if (sym->attr.use_assoc)
3413 if (sym->attr.in_common
3416 || sym->attr.flavor != FL_VARIABLE)
3418 /* Automatic objects are not saved. */
3419 if (gfc_is_var_automatic (sym))
3421 gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
3425 /* Mark those symbols which can be SAVEd as such. */
3428 gfc_save_all (gfc_namespace *ns)
3430 gfc_traverse_ns (ns, save_symbol);
3434 /* Make sure that no changes to symbols are pending. */
3437 gfc_enforce_clean_symbol_state(void)
3439 gcc_assert (changed_syms == NULL);
3443 /************** Global symbol handling ************/
3446 /* Search a tree for the global symbol. */
3449 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3458 c = strcmp (name, symbol->name);
3462 symbol = (c < 0) ? symbol->left : symbol->right;
3469 /* Compare two global symbols. Used for managing the BB tree. */
3472 gsym_compare (void *_s1, void *_s2)
3474 gfc_gsymbol *s1, *s2;
3476 s1 = (gfc_gsymbol *) _s1;
3477 s2 = (gfc_gsymbol *) _s2;
3478 return strcmp (s1->name, s2->name);
3482 /* Get a global symbol, creating it if it doesn't exist. */
3485 gfc_get_gsymbol (const char *name)
3489 s = gfc_find_gsymbol (gfc_gsym_root, name);
3493 s = XCNEW (gfc_gsymbol);
3494 s->type = GSYM_UNKNOWN;
3495 s->name = gfc_get_string (name);
3497 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3504 get_iso_c_binding_dt (int sym_id)
3506 gfc_dt_list *dt_list;
3508 dt_list = gfc_derived_types;
3510 /* Loop through the derived types in the name list, searching for
3511 the desired symbol from iso_c_binding. Search the parent namespaces
3512 if necessary and requested to (parent_flag). */
3513 while (dt_list != NULL)
3515 if (dt_list->derived->from_intmod != INTMOD_NONE
3516 && dt_list->derived->intmod_sym_id == sym_id)
3517 return dt_list->derived;
3519 dt_list = dt_list->next;
3526 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3527 with C. This is necessary for any derived type that is BIND(C) and for
3528 derived types that are parameters to functions that are BIND(C). All
3529 fields of the derived type are required to be interoperable, and are tested
3530 for such. If an error occurs, the errors are reported here, allowing for
3531 multiple errors to be handled for a single derived type. */
3534 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3536 gfc_component *curr_comp = NULL;
3537 gfc_try is_c_interop = FAILURE;
3538 gfc_try retval = SUCCESS;
3540 if (derived_sym == NULL)
3541 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3542 "unexpectedly NULL");
3544 /* If we've already looked at this derived symbol, do not look at it again
3545 so we don't repeat warnings/errors. */
3546 if (derived_sym->ts.is_c_interop)
3549 /* The derived type must have the BIND attribute to be interoperable
3550 J3/04-007, Section 15.2.3. */
3551 if (derived_sym->attr.is_bind_c != 1)
3553 derived_sym->ts.is_c_interop = 0;
3554 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3555 "attribute to be C interoperable", derived_sym->name,
3556 &(derived_sym->declared_at));
3560 curr_comp = derived_sym->components;
3562 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
3563 empty struct. Section 15.2 in Fortran 2003 states: "The following
3564 subclauses define the conditions under which a Fortran entity is
3565 interoperable. If a Fortran entity is interoperable, an equivalent
3566 entity may be defined by means of C and the Fortran entity is said
3567 to be interoperable with the C entity. There does not have to be such
3568 an interoperating C entity."
3570 if (curr_comp == NULL)
3572 gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
3573 "and may be inaccessible by the C companion processor",
3574 derived_sym->name, &(derived_sym->declared_at));
3575 derived_sym->ts.is_c_interop = 1;
3576 derived_sym->attr.is_bind_c = 1;
3581 /* Initialize the derived type as being C interoperable.
3582 If we find an error in the components, this will be set false. */
3583 derived_sym->ts.is_c_interop = 1;
3585 /* Loop through the list of components to verify that the kind of
3586 each is a C interoperable type. */
3589 /* The components cannot be pointers (fortran sense).
3590 J3/04-007, Section 15.2.3, C1505. */
3591 if (curr_comp->attr.pointer != 0)
3593 gfc_error ("Component '%s' at %L cannot have the "
3594 "POINTER attribute because it is a member "
3595 "of the BIND(C) derived type '%s' at %L",
3596 curr_comp->name, &(curr_comp->loc),
3597 derived_sym->name, &(derived_sym->declared_at));
3601 if (curr_comp->attr.proc_pointer != 0)
3603 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3604 " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3605 &curr_comp->loc, derived_sym->name,
3606 &derived_sym->declared_at);
3610 /* The components cannot be allocatable.
3611 J3/04-007, Section 15.2.3, C1505. */
3612 if (curr_comp->attr.allocatable != 0)
3614 gfc_error ("Component '%s' at %L cannot have the "
3615 "ALLOCATABLE attribute because it is a member "
3616 "of the BIND(C) derived type '%s' at %L",
3617 curr_comp->name, &(curr_comp->loc),
3618 derived_sym->name, &(derived_sym->declared_at));
3622 /* BIND(C) derived types must have interoperable components. */
3623 if (curr_comp->ts.type == BT_DERIVED
3624 && curr_comp->ts.u.derived->ts.is_iso_c != 1
3625 && curr_comp->ts.u.derived != derived_sym)
3627 /* This should be allowed; the draft says a derived-type can not
3628 have type parameters if it is has the BIND attribute. Type
3629 parameters seem to be for making parameterized derived types.
3630 There's no need to verify the type if it is c_ptr/c_funptr. */
3631 retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3635 /* Grab the typespec for the given component and test the kind. */
3636 is_c_interop = verify_c_interop (&(curr_comp->ts));
3638 if (is_c_interop != SUCCESS)
3640 /* Report warning and continue since not fatal. The
3641 draft does specify a constraint that requires all fields
3642 to interoperate, but if the user says real(4), etc., it
3643 may interoperate with *something* in C, but the compiler
3644 most likely won't know exactly what. Further, it may not
3645 interoperate with the same data type(s) in C if the user
3646 recompiles with different flags (e.g., -m32 and -m64 on
3647 x86_64 and using integer(4) to claim interop with a
3649 if (derived_sym->attr.is_bind_c == 1)
3650 /* If the derived type is bind(c), all fields must be
3652 gfc_warning ("Component '%s' in derived type '%s' at %L "
3653 "may not be C interoperable, even though "
3654 "derived type '%s' is BIND(C)",
3655 curr_comp->name, derived_sym->name,
3656 &(curr_comp->loc), derived_sym->name);
3658 /* If derived type is param to bind(c) routine, or to one
3659 of the iso_c_binding procs, it must be interoperable, so
3660 all fields must interop too. */
3661 gfc_warning ("Component '%s' in derived type '%s' at %L "
3662 "may not be C interoperable",
3663 curr_comp->name, derived_sym->name,
3668 curr_comp = curr_comp->next;
3669 } while (curr_comp != NULL);
3672 /* Make sure we don't have conflicts with the attributes. */
3673 if (derived_sym->attr.access == ACCESS_PRIVATE)
3675 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3676 "PRIVATE and BIND(C) attributes", derived_sym->name,
3677 &(derived_sym->declared_at));
3681 if (derived_sym->attr.sequence != 0)
3683 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3684 "attribute because it is BIND(C)", derived_sym->name,
3685 &(derived_sym->declared_at));
3689 /* Mark the derived type as not being C interoperable if we found an
3690 error. If there were only warnings, proceed with the assumption
3691 it's interoperable. */
3692 if (retval == FAILURE)
3693 derived_sym->ts.is_c_interop = 0;
3699 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3702 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3703 const char *module_name)
3705 gfc_symtree *tmp_symtree;
3706 gfc_symbol *tmp_sym;
3709 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3711 if (tmp_symtree != NULL)
3712 tmp_sym = tmp_symtree->n.sym;
3716 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3717 "create symbol for %s", ptr_name);
3720 /* Set up the symbol's important fields. Save attr required so we can
3721 initialize the ptr to NULL. */
3722 tmp_sym->attr.save = SAVE_EXPLICIT;
3723 tmp_sym->ts.is_c_interop = 1;
3724 tmp_sym->attr.is_c_interop = 1;
3725 tmp_sym->ts.is_iso_c = 1;
3726 tmp_sym->ts.type = BT_DERIVED;
3728 /* The c_ptr and c_funptr derived types will provide the
3729 definition for c_null_ptr and c_null_funptr, respectively. */
3730 if (ptr_id == ISOCBINDING_NULL_PTR)
3731 tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3733 tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3734 if (tmp_sym->ts.u.derived == NULL)
3736 /* This can occur if the user forgot to declare c_ptr or
3737 c_funptr and they're trying to use one of the procedures
3738 that has arg(s) of the missing type. In this case, a
3739 regular version of the thing should have been put in the
3741 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3742 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3743 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3744 ? "_gfortran_iso_c_binding_c_ptr"
3745 : "_gfortran_iso_c_binding_c_funptr"));
3747 tmp_sym->ts.u.derived =
3748 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3749 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3752 /* Module name is some mangled version of iso_c_binding. */
3753 tmp_sym->module = gfc_get_string (module_name);
3755 /* Say it's from the iso_c_binding module. */
3756 tmp_sym->attr.is_iso_c = 1;
3758 tmp_sym->attr.use_assoc = 1;
3759 tmp_sym->attr.is_bind_c = 1;
3760 /* Set the binding_label. */
3761 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3763 /* Set the c_address field of c_null_ptr and c_null_funptr to
3764 the value of NULL. */
3765 tmp_sym->value = gfc_get_expr ();
3766 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3767 tmp_sym->value->ts.type = BT_DERIVED;
3768 tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
3769 gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
3770 c = gfc_constructor_first (tmp_sym->value->value.constructor);
3771 c->expr = gfc_get_expr ();
3772 c->expr->expr_type = EXPR_NULL;
3773 c->expr->ts.is_iso_c = 1;
3774 /* Must declare c_null_ptr and c_null_funptr as having the
3775 PARAMETER attribute so they can be used in init expressions. */
3776 tmp_sym->attr.flavor = FL_PARAMETER;
3782 /* Add a formal argument, gfc_formal_arglist, to the
3783 end of the given list of arguments. Set the reference to the
3784 provided symbol, param_sym, in the argument. */
3787 add_formal_arg (gfc_formal_arglist **head,
3788 gfc_formal_arglist **tail,
3789 gfc_formal_arglist *formal_arg,
3790 gfc_symbol *param_sym)
3792 /* Put in list, either as first arg or at the tail (curr arg). */
3794 *head = *tail = formal_arg;
3797 (*tail)->next = formal_arg;
3798 (*tail) = formal_arg;
3801 (*tail)->sym = param_sym;
3802 (*tail)->next = NULL;
3808 /* Generates a symbol representing the CPTR argument to an
3809 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3810 CPTR and add it to the provided argument list. */
3813 gen_cptr_param (gfc_formal_arglist **head,
3814 gfc_formal_arglist **tail,
3815 const char *module_name,
3816 gfc_namespace *ns, const char *c_ptr_name,
3819 gfc_symbol *param_sym = NULL;
3820 gfc_symbol *c_ptr_sym = NULL;
3821 gfc_symtree *param_symtree = NULL;
3822 gfc_formal_arglist *formal_arg = NULL;
3823 const char *c_ptr_in;
3824 const char *c_ptr_type = NULL;
3826 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3827 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3829 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3831 if(c_ptr_name == NULL)
3832 c_ptr_in = "gfc_cptr__";
3834 c_ptr_in = c_ptr_name;
3835 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree, false);
3836 if (param_symtree != NULL)
3837 param_sym = param_symtree->n.sym;
3839 gfc_internal_error ("gen_cptr_param(): Unable to "
3840 "create symbol for %s", c_ptr_in);
3842 /* Set up the appropriate fields for the new c_ptr param sym. */
3844 param_sym->attr.flavor = FL_DERIVED;
3845 param_sym->ts.type = BT_DERIVED;
3846 param_sym->attr.intent = INTENT_IN;
3847 param_sym->attr.dummy = 1;
3849 /* This will pass the ptr to the iso_c routines as a (void *). */
3850 param_sym->attr.value = 1;
3851 param_sym->attr.use_assoc = 1;
3853 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3855 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3856 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3858 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3859 if (c_ptr_sym == NULL)
3861 /* This can happen if the user did not define c_ptr but they are
3862 trying to use one of the iso_c_binding functions that need it. */
3863 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3864 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3865 (const char *)c_ptr_type);
3867 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3868 (const char *)c_ptr_type);
3870 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3873 param_sym->ts.u.derived = c_ptr_sym;
3874 param_sym->module = gfc_get_string (module_name);
3876 /* Make new formal arg. */
3877 formal_arg = gfc_get_formal_arglist ();
3878 /* Add arg to list of formal args (the CPTR arg). */
3879 add_formal_arg (head, tail, formal_arg, param_sym);
3881 /* Validate changes. */
3882 gfc_commit_symbol (param_sym);
3886 /* Generates a symbol representing the FPTR argument to an
3887 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3888 FPTR and add it to the provided argument list. */
3891 gen_fptr_param (gfc_formal_arglist **head,
3892 gfc_formal_arglist **tail,
3893 const char *module_name,
3894 gfc_namespace *ns, const char *f_ptr_name, int proc)
3896 gfc_symbol *param_sym = NULL;
3897 gfc_symtree *param_symtree = NULL;
3898 gfc_formal_arglist *formal_arg = NULL;
3899 const char *f_ptr_out = "gfc_fptr__";
3901 if (f_ptr_name != NULL)
3902 f_ptr_out = f_ptr_name;
3904 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree, false);
3905 if (param_symtree != NULL)
3906 param_sym = param_symtree->n.sym;
3908 gfc_internal_error ("generateFPtrParam(): Unable to "
3909 "create symbol for %s", f_ptr_out);
3911 /* Set up the necessary fields for the fptr output param sym. */
3914 param_sym->attr.proc_pointer = 1;
3916 param_sym->attr.pointer = 1;
3917 param_sym->attr.dummy = 1;
3918 param_sym->attr.use_assoc = 1;
3920 /* ISO C Binding type to allow any pointer type as actual param. */
3921 param_sym->ts.type = BT_VOID;
3922 param_sym->module = gfc_get_string (module_name);
3925 formal_arg = gfc_get_formal_arglist ();
3926 /* Add arg to list of formal args. */
3927 add_formal_arg (head, tail, formal_arg, param_sym);
3929 /* Validate changes. */
3930 gfc_commit_symbol (param_sym);
3934 /* Generates a symbol representing the optional SHAPE argument for the
3935 iso_c_binding c_f_pointer() procedure. Also, create a
3936 gfc_formal_arglist for the SHAPE and add it to the provided
3940 gen_shape_param (gfc_formal_arglist **head,
3941 gfc_formal_arglist **tail,
3942 const char *module_name,
3943 gfc_namespace *ns, const char *shape_param_name)
3945 gfc_symbol *param_sym = NULL;
3946 gfc_symtree *param_symtree = NULL;
3947 gfc_formal_arglist *formal_arg = NULL;
3948 const char *shape_param = "gfc_shape_array__";
3950 if (shape_param_name != NULL)
3951 shape_param = shape_param_name;
3953 gfc_get_sym_tree (shape_param, ns, ¶m_symtree, false);
3954 if (param_symtree != NULL)
3955 param_sym = param_symtree->n.sym;
3957 gfc_internal_error ("generateShapeParam(): Unable to "
3958 "create symbol for %s", shape_param);
3960 /* Set up the necessary fields for the shape input param sym. */
3962 param_sym->attr.dummy = 1;
3963 param_sym->attr.use_assoc = 1;
3965 /* Integer array, rank 1, describing the shape of the object. Make it's
3966 type BT_VOID initially so we can accept any type/kind combination of
3967 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3968 of BT_INTEGER type. */
3969 param_sym->ts.type = BT_VOID;
3971 /* Initialize the kind to default integer. However, it will be overridden
3972 during resolution to match the kind of the SHAPE parameter given as
3973 the actual argument (to allow for any valid integer kind). */
3974 param_sym->ts.kind = gfc_default_integer_kind;
3975 param_sym->as = gfc_get_array_spec ();
3977 param_sym->as->rank = 1;
3978 param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
3981 /* The extent is unknown until we get it. The length give us
3982 the rank the incoming pointer. */
3983 param_sym->as->type = AS_ASSUMED_SHAPE;
3985 /* The arg is also optional; it is required iff the second arg
3986 (fptr) is to an array, otherwise, it's ignored. */
3987 param_sym->attr.optional = 1;
3988 param_sym->attr.intent = INTENT_IN;
3989 param_sym->attr.dimension = 1;
3990 param_sym->module = gfc_get_string (module_name);
3993 formal_arg = gfc_get_formal_arglist ();
3994 /* Add arg to list of formal args. */
3995 add_formal_arg (head, tail, formal_arg, param_sym);
3997 /* Validate changes. */
3998 gfc_commit_symbol (param_sym);
4002 /* Add a procedure interface to the given symbol (i.e., store a
4003 reference to the list of formal arguments). */
4006 add_proc_interface (gfc_symbol *sym, ifsrc source,
4007 gfc_formal_arglist *formal)
4010 sym->formal = formal;
4011 sym->attr.if_source = source;
4015 /* Copy the formal args from an existing symbol, src, into a new
4016 symbol, dest. New formal args are created, and the description of
4017 each arg is set according to the existing ones. This function is
4018 used when creating procedure declaration variables from a procedure
4019 declaration statement (see match_proc_decl()) to create the formal
4020 args based on the args of a given named interface. */
4023 gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
4025 gfc_formal_arglist *head = NULL;
4026 gfc_formal_arglist *tail = NULL;
4027 gfc_formal_arglist *formal_arg = NULL;
4028 gfc_formal_arglist *curr_arg = NULL;
4029 gfc_formal_arglist *formal_prev = NULL;
4030 /* Save current namespace so we can change it for formal args. */
4031 gfc_namespace *parent_ns = gfc_current_ns;
4033 /* Create a new namespace, which will be the formal ns (namespace
4034 of the formal args). */
4035 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4036 gfc_current_ns->proc_name = dest;
4038 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4040 formal_arg = gfc_get_formal_arglist ();
4041 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
4043 /* May need to copy more info for the symbol. */
4044 formal_arg->sym->attr = curr_arg->sym->attr;
4045 formal_arg->sym->ts = curr_arg->sym->ts;
4046 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
4047 gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
4049 /* If this isn't the first arg, set up the next ptr. For the
4050 last arg built, the formal_arg->next will never get set to
4051 anything other than NULL. */
4052 if (formal_prev != NULL)
4053 formal_prev->next = formal_arg;
4055 formal_arg->next = NULL;
4057 formal_prev = formal_arg;
4059 /* Add arg to list of formal args. */
4060 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4062 /* Validate changes. */
4063 gfc_commit_symbol (formal_arg->sym);
4066 /* Add the interface to the symbol. */
4067 add_proc_interface (dest, IFSRC_DECL, head);
4069 /* Store the formal namespace information. */
4070 if (dest->formal != NULL)
4071 /* The current ns should be that for the dest proc. */
4072 dest->formal_ns = gfc_current_ns;
4073 /* Restore the current namespace to what it was on entry. */
4074 gfc_current_ns = parent_ns;
4079 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
4081 gfc_formal_arglist *head = NULL;
4082 gfc_formal_arglist *tail = NULL;
4083 gfc_formal_arglist *formal_arg = NULL;
4084 gfc_intrinsic_arg *curr_arg = NULL;
4085 gfc_formal_arglist *formal_prev = NULL;
4086 /* Save current namespace so we can change it for formal args. */
4087 gfc_namespace *parent_ns = gfc_current_ns;
4089 /* Create a new namespace, which will be the formal ns (namespace
4090 of the formal args). */
4091 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4092 gfc_current_ns->proc_name = dest;
4094 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4096 formal_arg = gfc_get_formal_arglist ();
4097 gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4099 /* May need to copy more info for the symbol. */
4100 formal_arg->sym->ts = curr_arg->ts;
4101 formal_arg->sym->attr.optional = curr_arg->optional;
4102 formal_arg->sym->attr.value = curr_arg->value;
4103 formal_arg->sym->attr.intent = curr_arg->intent;
4104 formal_arg->sym->attr.flavor = FL_VARIABLE;
4105 formal_arg->sym->attr.dummy = 1;
4107 if (formal_arg->sym->ts.type == BT_CHARACTER)
4108 formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4110 /* If this isn't the first arg, set up the next ptr. For the
4111 last arg built, the formal_arg->next will never get set to
4112 anything other than NULL. */
4113 if (formal_prev != NULL)
4114 formal_prev->next = formal_arg;
4116 formal_arg->next = NULL;
4118 formal_prev = formal_arg;
4120 /* Add arg to list of formal args. */
4121 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4123 /* Validate changes. */
4124 gfc_commit_symbol (formal_arg->sym);
4127 /* Add the interface to the symbol. */
4128 add_proc_interface (dest, IFSRC_DECL, head);
4130 /* Store the formal namespace information. */
4131 if (dest->formal != NULL)
4132 /* The current ns should be that for the dest proc. */
4133 dest->formal_ns = gfc_current_ns;
4134 /* Restore the current namespace to what it was on entry. */
4135 gfc_current_ns = parent_ns;
4140 gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
4142 gfc_formal_arglist *head = NULL;
4143 gfc_formal_arglist *tail = NULL;
4144 gfc_formal_arglist *formal_arg = NULL;
4145 gfc_formal_arglist *curr_arg = NULL;
4146 gfc_formal_arglist *formal_prev = NULL;
4147 /* Save current namespace so we can change it for formal args. */
4148 gfc_namespace *parent_ns = gfc_current_ns;
4150 /* Create a new namespace, which will be the formal ns (namespace
4151 of the formal args). */
4152 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4153 /* TODO: gfc_current_ns->proc_name = dest;*/
4155 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4157 formal_arg = gfc_get_formal_arglist ();
4158 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
4160 /* May need to copy more info for the symbol. */
4161 formal_arg->sym->attr = curr_arg->sym->attr;
4162 formal_arg->sym->ts = curr_arg->sym->ts;
4163 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
4164 gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
4166 /* If this isn't the first arg, set up the next ptr. For the
4167 last arg built, the formal_arg->next will never get set to
4168 anything other than NULL. */
4169 if (formal_prev != NULL)
4170 formal_prev->next = formal_arg;
4172 formal_arg->next = NULL;
4174 formal_prev = formal_arg;
4176 /* Add arg to list of formal args. */
4177 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4179 /* Validate changes. */
4180 gfc_commit_symbol (formal_arg->sym);
4183 /* Add the interface to the symbol. */
4184 gfc_free_formal_arglist (dest->formal);
4185 dest->formal = head;
4186 dest->attr.if_source = IFSRC_DECL;
4188 /* Store the formal namespace information. */
4189 if (dest->formal != NULL)
4190 /* The current ns should be that for the dest proc. */
4191 dest->formal_ns = gfc_current_ns;
4192 /* Restore the current namespace to what it was on entry. */
4193 gfc_current_ns = parent_ns;
4197 /* Builds the parameter list for the iso_c_binding procedure
4198 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
4199 generic version of either the c_f_pointer or c_f_procpointer
4200 functions. The new_proc_sym represents a "resolved" version of the
4201 symbol. The functions are resolved to match the types of their
4202 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4203 something similar to c_f_pointer_i4 if the type of data object fptr
4204 pointed to was a default integer. The actual name of the resolved
4205 procedure symbol is further mangled with the module name, etc., but
4206 the idea holds true. */
4209 build_formal_args (gfc_symbol *new_proc_sym,
4210 gfc_symbol *old_sym, int add_optional_arg)
4212 gfc_formal_arglist *head = NULL, *tail = NULL;
4213 gfc_namespace *parent_ns = NULL;
4215 parent_ns = gfc_current_ns;
4216 /* Create a new namespace, which will be the formal ns (namespace
4217 of the formal args). */
4218 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
4219 gfc_current_ns->proc_name = new_proc_sym;
4221 /* Generate the params. */
4222 if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
4224 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4225 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4226 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4227 gfc_current_ns, "fptr", 1);
4229 else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
4231 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4232 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4233 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4234 gfc_current_ns, "fptr", 0);
4235 /* If we're dealing with c_f_pointer, it has an optional third arg. */
4236 gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
4237 gfc_current_ns, "shape");
4240 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
4242 /* c_associated has one required arg and one optional; both
4244 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4245 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
4246 if (add_optional_arg)
4248 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4249 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
4250 /* The last param is optional so mark it as such. */
4251 tail->sym->attr.optional = 1;
4255 /* Add the interface (store formal args to new_proc_sym). */
4256 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
4258 /* Set up the formal_ns pointer to the one created for the
4259 new procedure so it'll get cleaned up during gfc_free_symbol(). */
4260 new_proc_sym->formal_ns = gfc_current_ns;
4262 gfc_current_ns = parent_ns;
4266 std_for_isocbinding_symbol (int id)
4270 #define NAMED_INTCST(a,b,c,d) \
4273 #include "iso-c-binding.def"
4276 #define NAMED_FUNCTION(a,b,c,d) \
4279 #include "iso-c-binding.def"
4280 #undef NAMED_FUNCTION
4283 return GFC_STD_F2003;
4287 /* Generate the given set of C interoperable kind objects, or all
4288 interoperable kinds. This function will only be given kind objects
4289 for valid iso_c_binding defined types because this is verified when
4290 the 'use' statement is parsed. If the user gives an 'only' clause,
4291 the specific kinds are looked up; if they don't exist, an error is
4292 reported. If the user does not give an 'only' clause, all
4293 iso_c_binding symbols are generated. If a list of specific kinds
4294 is given, it must have a NULL in the first empty spot to mark the
4299 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4300 const char *local_name)
4302 const char *const name = (local_name && local_name[0]) ? local_name
4303 : c_interop_kinds_table[s].name;
4304 gfc_symtree *tmp_symtree = NULL;
4305 gfc_symbol *tmp_sym = NULL;
4306 gfc_dt_list **dt_list_ptr = NULL;
4307 gfc_component *tmp_comp = NULL;
4308 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
4311 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4313 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4315 /* Already exists in this scope so don't re-add it.
4316 TODO: we should probably check that it's really the same symbol. */
4317 if (tmp_symtree != NULL)
4320 /* Create the sym tree in the current ns. */
4321 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4323 tmp_sym = tmp_symtree->n.sym;
4325 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4328 /* Say what module this symbol belongs to. */
4329 tmp_sym->module = gfc_get_string (mod_name);
4330 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4331 tmp_sym->intmod_sym_id = s;
4336 #define NAMED_INTCST(a,b,c,d) case a :
4337 #define NAMED_REALCST(a,b,c) case a :
4338 #define NAMED_CMPXCST(a,b,c) case a :
4339 #define NAMED_LOGCST(a,b,c) case a :
4340 #define NAMED_CHARKNDCST(a,b,c) case a :
4341 #include "iso-c-binding.def"
4343 tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4344 c_interop_kinds_table[s].value);
4346 /* Initialize an integer constant expression node. */
4347 tmp_sym->attr.flavor = FL_PARAMETER;
4348 tmp_sym->ts.type = BT_INTEGER;
4349 tmp_sym->ts.kind = gfc_default_integer_kind;
4351 /* Mark this type as a C interoperable one. */
4352 tmp_sym->ts.is_c_interop = 1;
4353 tmp_sym->ts.is_iso_c = 1;
4354 tmp_sym->value->ts.is_c_interop = 1;
4355 tmp_sym->value->ts.is_iso_c = 1;
4356 tmp_sym->attr.is_c_interop = 1;
4358 /* Tell what f90 type this c interop kind is valid. */
4359 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4361 /* Say it's from the iso_c_binding module. */
4362 tmp_sym->attr.is_iso_c = 1;
4364 /* Make it use associated. */
4365 tmp_sym->attr.use_assoc = 1;
4369 #define NAMED_CHARCST(a,b,c) case a :
4370 #include "iso-c-binding.def"
4372 /* Initialize an integer constant expression node for the
4373 length of the character. */
4374 tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
4375 &gfc_current_locus, NULL, 1);
4376 tmp_sym->value->ts.is_c_interop = 1;
4377 tmp_sym->value->ts.is_iso_c = 1;
4378 tmp_sym->value->value.character.length = 1;
4379 tmp_sym->value->value.character.string[0]
4380 = (gfc_char_t) c_interop_kinds_table[s].value;
4381 tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4382 tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
4385 /* May not need this in both attr and ts, but do need in
4386 attr for writing module file. */
4387 tmp_sym->attr.is_c_interop = 1;
4389 tmp_sym->attr.flavor = FL_PARAMETER;
4390 tmp_sym->ts.type = BT_CHARACTER;
4392 /* Need to set it to the C_CHAR kind. */
4393 tmp_sym->ts.kind = gfc_default_character_kind;
4395 /* Mark this type as a C interoperable one. */
4396 tmp_sym->ts.is_c_interop = 1;
4397 tmp_sym->ts.is_iso_c = 1;
4399 /* Tell what f90 type this c interop kind is valid. */
4400 tmp_sym->ts.f90_type = BT_CHARACTER;
4402 /* Say it's from the iso_c_binding module. */
4403 tmp_sym->attr.is_iso_c = 1;
4405 /* Make it use associated. */
4406 tmp_sym->attr.use_assoc = 1;
4409 case ISOCBINDING_PTR:
4410 case ISOCBINDING_FUNPTR:
4412 /* Initialize an integer constant expression node. */
4413 tmp_sym->attr.flavor = FL_DERIVED;
4414 tmp_sym->ts.is_c_interop = 1;
4415 tmp_sym->attr.is_c_interop = 1;
4416 tmp_sym->attr.is_iso_c = 1;
4417 tmp_sym->ts.is_iso_c = 1;
4418 tmp_sym->ts.type = BT_DERIVED;
4420 /* A derived type must have the bind attribute to be
4421 interoperable (J3/04-007, Section 15.2.3), even though
4422 the binding label is not used. */
4423 tmp_sym->attr.is_bind_c = 1;
4425 tmp_sym->attr.referenced = 1;
4427 tmp_sym->ts.u.derived = tmp_sym;
4429 /* Add the symbol created for the derived type to the current ns. */
4430 dt_list_ptr = &(gfc_derived_types);
4431 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4432 dt_list_ptr = &((*dt_list_ptr)->next);
4434 /* There is already at least one derived type in the list, so append
4435 the one we're currently building for c_ptr or c_funptr. */
4436 if (*dt_list_ptr != NULL)
4437 dt_list_ptr = &((*dt_list_ptr)->next);
4438 (*dt_list_ptr) = gfc_get_dt_list ();
4439 (*dt_list_ptr)->derived = tmp_sym;
4440 (*dt_list_ptr)->next = NULL;
4442 /* Set up the component of the derived type, which will be
4443 an integer with kind equal to c_ptr_size. Mangle the name of
4444 the field for the c_address to prevent the curious user from
4445 trying to access it from Fortran. */
4446 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
4447 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
4448 if (tmp_comp == NULL)
4449 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4450 "create component for c_address");
4452 tmp_comp->ts.type = BT_INTEGER;
4454 /* Set this because the module will need to read/write this field. */
4455 tmp_comp->ts.f90_type = BT_INTEGER;
4457 /* The kinds for c_ptr and c_funptr are the same. */
4458 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4459 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4461 tmp_comp->attr.pointer = 0;
4462 tmp_comp->attr.dimension = 0;
4464 /* Mark the component as C interoperable. */
4465 tmp_comp->ts.is_c_interop = 1;
4467 /* Make it use associated (iso_c_binding module). */
4468 tmp_sym->attr.use_assoc = 1;
4471 case ISOCBINDING_NULL_PTR:
4472 case ISOCBINDING_NULL_FUNPTR:
4473 gen_special_c_interop_ptr (s, name, mod_name);
4476 case ISOCBINDING_F_POINTER:
4477 case ISOCBINDING_ASSOCIATED:
4478 case ISOCBINDING_LOC:
4479 case ISOCBINDING_FUNLOC:
4480 case ISOCBINDING_F_PROCPOINTER:
4482 tmp_sym->attr.proc = PROC_MODULE;
4484 /* Use the procedure's name as it is in the iso_c_binding module for
4485 setting the binding label in case the user renamed the symbol. */
4486 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
4487 c_interop_kinds_table[s].name);
4488 tmp_sym->attr.is_iso_c = 1;
4489 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4490 tmp_sym->attr.subroutine = 1;
4493 /* TODO! This needs to be finished more for the expr of the
4494 function or something!
4495 This may not need to be here, because trying to do c_loc
4497 if (s == ISOCBINDING_ASSOCIATED)
4499 tmp_sym->attr.function = 1;
4500 tmp_sym->ts.type = BT_LOGICAL;
4501 tmp_sym->ts.kind = gfc_default_logical_kind;
4502 tmp_sym->result = tmp_sym;
4506 /* Here, we're taking the simple approach. We're defining
4507 c_loc as an external identifier so the compiler will put
4508 what we expect on the stack for the address we want the
4510 tmp_sym->ts.type = BT_DERIVED;
4511 if (s == ISOCBINDING_LOC)
4512 tmp_sym->ts.u.derived =
4513 get_iso_c_binding_dt (ISOCBINDING_PTR);
4515 tmp_sym->ts.u.derived =
4516 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4518 if (tmp_sym->ts.u.derived == NULL)
4520 /* Create the necessary derived type so we can continue
4521 processing the file. */
4522 generate_isocbinding_symbol
4523 (mod_name, s == ISOCBINDING_FUNLOC
4524 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4525 (const char *)(s == ISOCBINDING_FUNLOC
4526 ? "_gfortran_iso_c_binding_c_funptr"
4527 : "_gfortran_iso_c_binding_c_ptr"));
4528 tmp_sym->ts.u.derived =
4529 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4530 ? ISOCBINDING_FUNPTR
4534 /* The function result is itself (no result clause). */
4535 tmp_sym->result = tmp_sym;
4536 tmp_sym->attr.external = 1;
4537 tmp_sym->attr.use_assoc = 0;
4538 tmp_sym->attr.pure = 1;
4539 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4540 tmp_sym->attr.proc = PROC_UNKNOWN;
4544 tmp_sym->attr.flavor = FL_PROCEDURE;
4545 tmp_sym->attr.contained = 0;
4547 /* Try using this builder routine, with the new and old symbols
4548 both being the generic iso_c proc sym being created. This
4549 will create the formal args (and the new namespace for them).
4550 Don't build an arg list for c_loc because we're going to treat
4551 c_loc as an external procedure. */
4552 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4553 /* The 1 says to add any optional args, if applicable. */
4554 build_formal_args (tmp_sym, tmp_sym, 1);
4556 /* Set this after setting up the symbol, to prevent error messages. */
4557 tmp_sym->attr.use_assoc = 1;
4559 /* This symbol will not be referenced directly. It will be
4560 resolved to the implementation for the given f90 kind. */
4561 tmp_sym->attr.referenced = 0;
4568 gfc_commit_symbol (tmp_sym);
4572 /* Creates a new symbol based off of an old iso_c symbol, with a new
4573 binding label. This function can be used to create a new,
4574 resolved, version of a procedure symbol for c_f_pointer or
4575 c_f_procpointer that is based on the generic symbols. A new
4576 parameter list is created for the new symbol using
4577 build_formal_args(). The add_optional_flag specifies whether the
4578 to add the optional SHAPE argument. The new symbol is
4582 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4583 char *new_binding_label, int add_optional_arg)
4585 gfc_symtree *new_symtree = NULL;
4587 /* See if we have a symbol by that name already available, looking
4588 through any parent namespaces. */
4589 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4590 if (new_symtree != NULL)
4591 /* Return the existing symbol. */
4592 return new_symtree->n.sym;
4594 /* Create the symtree/symbol, with attempted host association. */
4595 gfc_get_ha_sym_tree (new_name, &new_symtree);
4596 if (new_symtree == NULL)
4597 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4598 "symtree for '%s'", new_name);
4600 /* Now fill in the fields of the resolved symbol with the old sym. */
4601 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4602 new_symtree->n.sym->attr = old_sym->attr;
4603 new_symtree->n.sym->ts = old_sym->ts;
4604 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4605 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4606 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4607 if (old_sym->attr.function)
4608 new_symtree->n.sym->result = new_symtree->n.sym;
4609 /* Build the formal arg list. */
4610 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4612 gfc_commit_symbol (new_symtree->n.sym);
4614 return new_symtree->n.sym;
4618 /* Check that a symbol is already typed. If strict is not set, an untyped
4619 symbol is acceptable for non-standard-conforming mode. */
4622 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4623 bool strict, locus where)
4627 if (gfc_matching_prefix)
4630 /* Check for the type and try to give it an implicit one. */
4631 if (sym->ts.type == BT_UNKNOWN
4632 && gfc_set_default_type (sym, 0, ns) == FAILURE)
4636 gfc_error ("Symbol '%s' is used before it is typed at %L",
4641 if (gfc_notify_std (GFC_STD_GNU,
4642 "Extension: Symbol '%s' is used before"
4643 " it is typed at %L", sym->name, &where) == FAILURE)
4647 /* Everything is ok. */
4652 /* Construct a typebound-procedure structure. Those are stored in a tentative
4653 list and marked `error' until symbols are committed. */
4656 gfc_get_typebound_proc (gfc_typebound_proc *tb0)
4658 gfc_typebound_proc *result;
4659 tentative_tbp *list_node;
4661 result = XCNEW (gfc_typebound_proc);
4666 list_node = XCNEW (tentative_tbp);
4667 list_node->next = tentative_tbp_list;
4668 list_node->proc = result;
4669 tentative_tbp_list = list_node;
4675 /* Get the super-type of a given derived type. */
4678 gfc_get_derived_super_type (gfc_symbol* derived)
4680 if (!derived->attr.extension)
4683 gcc_assert (derived->components);
4684 gcc_assert (derived->components->ts.type == BT_DERIVED);
4685 gcc_assert (derived->components->ts.u.derived);
4687 return derived->components->ts.u.derived;
4691 /* Get the ultimate super-type of a given derived type. */
4694 gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
4696 if (!derived->attr.extension)
4699 derived = gfc_get_derived_super_type (derived);
4701 if (derived->attr.extension)
4702 return gfc_get_ultimate_derived_super_type (derived);
4708 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4711 gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
4713 while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
4714 t2 = gfc_get_derived_super_type (t2);
4715 return gfc_compare_derived_types (t1, t2);
4719 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4720 If ts1 is nonpolymorphic, ts2 must be the same type.
4721 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4724 gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
4726 bool is_class1 = (ts1->type == BT_CLASS);
4727 bool is_class2 = (ts2->type == BT_CLASS);
4728 bool is_derived1 = (ts1->type == BT_DERIVED);
4729 bool is_derived2 = (ts2->type == BT_DERIVED);
4731 if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
4732 return (ts1->type == ts2->type);
4734 if (is_derived1 && is_derived2)
4735 return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
4737 if (is_class1 && is_derived2)
4738 return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4740 else if (is_class1 && is_class2)
4741 return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4742 ts2->u.derived->components->ts.u.derived);
4748 /* Find the parent-namespace of the current function. If we're inside
4749 BLOCK constructs, it may not be the current one. */
4752 gfc_find_proc_namespace (gfc_namespace* ns)
4754 while (ns->construct_entities)
4764 /* Check if an associate-variable should be translated as an `implicit' pointer
4765 internally (if it is associated to a variable and not an array with
4769 gfc_is_associate_pointer (gfc_symbol* sym)
4774 if (!sym->assoc->variable)
4777 if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)