1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
31 /* Strings for all symbol attributes. We use these for dumping the
32 parse tree, in error messages, and also when reading and writing
35 const mstring flavors[] =
37 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
38 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
39 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
40 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
41 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
45 const mstring procedures[] =
47 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
48 minit ("MODULE-PROC", PROC_MODULE),
49 minit ("INTERNAL-PROC", PROC_INTERNAL),
50 minit ("DUMMY-PROC", PROC_DUMMY),
51 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
52 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
53 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
57 const mstring intents[] =
59 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
60 minit ("IN", INTENT_IN),
61 minit ("OUT", INTENT_OUT),
62 minit ("INOUT", INTENT_INOUT),
66 const mstring access_types[] =
68 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
69 minit ("PUBLIC", ACCESS_PUBLIC),
70 minit ("PRIVATE", ACCESS_PRIVATE),
74 const mstring ifsrc_types[] =
76 minit ("UNKNOWN", IFSRC_UNKNOWN),
77 minit ("DECL", IFSRC_DECL),
78 minit ("BODY", IFSRC_IFBODY)
81 const mstring save_status[] =
83 minit ("UNKNOWN", SAVE_NONE),
84 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
85 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
88 /* This is to make sure the backend generates setup code in the correct
91 static int next_dummy_order = 1;
94 gfc_namespace *gfc_current_ns;
95 gfc_namespace *gfc_global_ns_list;
97 gfc_gsymbol *gfc_gsym_root = NULL;
99 static gfc_symbol *changed_syms = NULL;
101 gfc_dt_list *gfc_derived_types;
104 /* List of tentative typebound-procedures. */
106 typedef struct tentative_tbp
108 gfc_typebound_proc *proc;
109 struct tentative_tbp *next;
113 static tentative_tbp *tentative_tbp_list = NULL;
116 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
118 /* The following static variable indicates whether a particular element has
119 been explicitly set or not. */
121 static int new_flag[GFC_LETTERS];
124 /* Handle a correctly parsed IMPLICIT NONE. */
127 gfc_set_implicit_none (void)
131 if (gfc_current_ns->seen_implicit_none)
133 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
137 gfc_current_ns->seen_implicit_none = 1;
139 for (i = 0; i < GFC_LETTERS; i++)
141 gfc_clear_ts (&gfc_current_ns->default_type[i]);
142 gfc_current_ns->set_flag[i] = 1;
147 /* Reset the implicit range flags. */
150 gfc_clear_new_implicit (void)
154 for (i = 0; i < GFC_LETTERS; i++)
159 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
162 gfc_add_new_implicit_range (int c1, int c2)
169 for (i = c1; i <= c2; i++)
173 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
185 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
186 the new implicit types back into the existing types will work. */
189 gfc_merge_new_implicit (gfc_typespec *ts)
193 if (gfc_current_ns->seen_implicit_none)
195 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
199 for (i = 0; i < GFC_LETTERS; i++)
203 if (gfc_current_ns->set_flag[i])
205 gfc_error ("Letter %c already has an IMPLICIT type at %C",
210 gfc_current_ns->default_type[i] = *ts;
211 gfc_current_ns->implicit_loc[i] = gfc_current_locus;
212 gfc_current_ns->set_flag[i] = 1;
219 /* Given a symbol, return a pointer to the typespec for its default type. */
222 gfc_get_default_type (const char *name, gfc_namespace *ns)
228 if (gfc_option.flag_allow_leading_underscore && letter == '_')
229 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
230 "gfortran developers, and should not be used for "
231 "implicitly typed variables");
233 if (letter < 'a' || letter > 'z')
234 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
239 return &ns->default_type[letter - 'a'];
243 /* Given a pointer to a symbol, set its type according to the first
244 letter of its name. Fails if the letter in question has no default
248 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
252 if (sym->ts.type != BT_UNKNOWN)
253 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
255 ts = gfc_get_default_type (sym->name, ns);
257 if (ts->type == BT_UNKNOWN)
259 if (error_flag && !sym->attr.untyped)
261 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
262 sym->name, &sym->declared_at);
263 sym->attr.untyped = 1; /* Ensure we only give an error once. */
270 sym->attr.implicit_type = 1;
272 if (ts->type == BT_CHARACTER && ts->u.cl)
274 sym->ts.u.cl = gfc_get_charlen ();
275 *sym->ts.u.cl = *ts->u.cl;
278 if (sym->attr.is_bind_c == 1)
280 /* BIND(C) variables should not be implicitly declared. */
281 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
282 "not be C interoperable", sym->name, &sym->declared_at);
283 sym->ts.f90_type = sym->ts.type;
286 if (sym->attr.dummy != 0)
288 if (sym->ns->proc_name != NULL
289 && (sym->ns->proc_name->attr.subroutine != 0
290 || sym->ns->proc_name->attr.function != 0)
291 && sym->ns->proc_name->attr.is_bind_c != 0)
293 /* Dummy args to a BIND(C) routine may not be interoperable if
294 they are implicitly typed. */
295 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
296 "be C interoperable but it is a dummy argument to "
297 "the BIND(C) procedure '%s' at %L", sym->name,
298 &(sym->declared_at), sym->ns->proc_name->name,
299 &(sym->ns->proc_name->declared_at));
300 sym->ts.f90_type = sym->ts.type;
308 /* This function is called from parse.c(parse_progunit) to check the
309 type of the function is not implicitly typed in the host namespace
310 and to implicitly type the function result, if necessary. */
313 gfc_check_function_type (gfc_namespace *ns)
315 gfc_symbol *proc = ns->proc_name;
317 if (!proc->attr.contained || proc->result->attr.implicit_type)
320 if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
322 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
325 if (proc->result != proc)
327 proc->ts = proc->result->ts;
328 proc->as = gfc_copy_array_spec (proc->result->as);
329 proc->attr.dimension = proc->result->attr.dimension;
330 proc->attr.pointer = proc->result->attr.pointer;
331 proc->attr.allocatable = proc->result->attr.allocatable;
334 else if (!proc->result->attr.proc_pointer)
336 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
337 proc->result->name, &proc->result->declared_at);
338 proc->result->attr.untyped = 1;
344 /******************** Symbol attribute stuff *********************/
346 /* This is a generic conflict-checker. We do this to avoid having a
347 single conflict in two places. */
349 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
350 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
351 #define conf_std(a, b, std) if (attr->a && attr->b)\
360 check_conflict (symbol_attribute *attr, const char *name, locus *where)
362 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
363 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
364 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
365 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
366 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
367 *privat = "PRIVATE", *recursive = "RECURSIVE",
368 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
369 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
370 *function = "FUNCTION", *subroutine = "SUBROUTINE",
371 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
372 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
373 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
374 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
375 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
376 static const char *threadprivate = "THREADPRIVATE";
382 where = &gfc_current_locus;
384 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
388 standard = GFC_STD_F2003;
392 /* Check for attributes not allowed in a BLOCK DATA. */
393 if (gfc_current_state () == COMP_BLOCK_DATA)
397 if (attr->in_namelist)
399 if (attr->allocatable)
405 if (attr->access == ACCESS_PRIVATE)
407 if (attr->access == ACCESS_PUBLIC)
409 if (attr->intent != INTENT_UNKNOWN)
415 ("%s attribute not allowed in BLOCK DATA program unit at %L",
421 if (attr->save == SAVE_EXPLICIT)
424 conf (in_common, save);
427 switch (attr->flavor)
435 a1 = gfc_code2string (flavors, attr->flavor);
440 /* Conflicts between SAVE and PROCEDURE will be checked at
441 resolution stage, see "resolve_fl_procedure". */
450 conf (dummy, intrinsic);
451 conf (dummy, threadprivate);
452 conf (pointer, target);
453 conf (pointer, intrinsic);
454 conf (pointer, elemental);
455 conf (allocatable, elemental);
457 conf (target, external);
458 conf (target, intrinsic);
460 if (!attr->if_source)
461 conf (external, dimension); /* See Fortran 95's R504. */
463 conf (external, intrinsic);
464 conf (entry, intrinsic);
466 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
467 conf (external, subroutine);
469 if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
470 "Fortran 2003: Procedure pointer at %C") == FAILURE)
473 conf (allocatable, pointer);
474 conf_std (allocatable, dummy, GFC_STD_F2003);
475 conf_std (allocatable, function, GFC_STD_F2003);
476 conf_std (allocatable, result, GFC_STD_F2003);
477 conf (elemental, recursive);
479 conf (in_common, dummy);
480 conf (in_common, allocatable);
481 conf (in_common, result);
483 conf (dummy, result);
485 conf (in_equivalence, use_assoc);
486 conf (in_equivalence, dummy);
487 conf (in_equivalence, target);
488 conf (in_equivalence, pointer);
489 conf (in_equivalence, function);
490 conf (in_equivalence, result);
491 conf (in_equivalence, entry);
492 conf (in_equivalence, allocatable);
493 conf (in_equivalence, threadprivate);
495 conf (in_namelist, pointer);
496 conf (in_namelist, allocatable);
498 conf (entry, result);
500 conf (function, subroutine);
502 if (!function && !subroutine)
503 conf (is_bind_c, dummy);
505 conf (is_bind_c, cray_pointer);
506 conf (is_bind_c, cray_pointee);
507 conf (is_bind_c, allocatable);
508 conf (is_bind_c, elemental);
510 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
511 Parameter conflict caught below. Also, value cannot be specified
512 for a dummy procedure. */
514 /* Cray pointer/pointee conflicts. */
515 conf (cray_pointer, cray_pointee);
516 conf (cray_pointer, dimension);
517 conf (cray_pointer, pointer);
518 conf (cray_pointer, target);
519 conf (cray_pointer, allocatable);
520 conf (cray_pointer, external);
521 conf (cray_pointer, intrinsic);
522 conf (cray_pointer, in_namelist);
523 conf (cray_pointer, function);
524 conf (cray_pointer, subroutine);
525 conf (cray_pointer, entry);
527 conf (cray_pointee, allocatable);
528 conf (cray_pointee, intent);
529 conf (cray_pointee, optional);
530 conf (cray_pointee, dummy);
531 conf (cray_pointee, target);
532 conf (cray_pointee, intrinsic);
533 conf (cray_pointee, pointer);
534 conf (cray_pointee, entry);
535 conf (cray_pointee, in_common);
536 conf (cray_pointee, in_equivalence);
537 conf (cray_pointee, threadprivate);
540 conf (data, function);
542 conf (data, allocatable);
543 conf (data, use_assoc);
545 conf (value, pointer)
546 conf (value, allocatable)
547 conf (value, subroutine)
548 conf (value, function)
549 conf (value, volatile_)
550 conf (value, dimension)
551 conf (value, external)
554 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
557 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
561 conf (is_protected, intrinsic)
562 conf (is_protected, external)
563 conf (is_protected, in_common)
565 conf (volatile_, intrinsic)
566 conf (volatile_, external)
568 if (attr->volatile_ && attr->intent == INTENT_IN)
575 conf (procedure, allocatable)
576 conf (procedure, dimension)
577 conf (procedure, intrinsic)
578 conf (procedure, is_protected)
579 conf (procedure, target)
580 conf (procedure, value)
581 conf (procedure, volatile_)
582 conf (procedure, entry)
584 a1 = gfc_code2string (flavors, attr->flavor);
586 if (attr->in_namelist
587 && attr->flavor != FL_VARIABLE
588 && attr->flavor != FL_PROCEDURE
589 && attr->flavor != FL_UNKNOWN)
595 switch (attr->flavor)
605 conf2 (is_protected);
615 conf2 (threadprivate);
617 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
619 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
620 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
627 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
641 /* Conflicts with INTENT, SAVE and RESULT will be checked
642 at resolution stage, see "resolve_fl_procedure". */
644 if (attr->subroutine)
651 conf2 (threadprivate);
654 if (!attr->proc_pointer)
659 case PROC_ST_FUNCTION:
669 conf2 (threadprivate);
689 conf2 (threadprivate);
692 if (attr->intent != INTENT_UNKNOWN)
708 conf2 (is_protected);
714 conf2 (threadprivate);
728 gfc_error ("%s attribute conflicts with %s attribute at %L",
731 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
732 a1, a2, name, where);
739 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
740 "with %s attribute at %L", a1, a2,
745 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
746 "with %s attribute in '%s' at %L",
747 a1, a2, name, where);
756 /* Mark a symbol as referenced. */
759 gfc_set_sym_referenced (gfc_symbol *sym)
762 if (sym->attr.referenced)
765 sym->attr.referenced = 1;
767 /* Remember which order dummy variables are accessed in. */
769 sym->dummy_order = next_dummy_order++;
773 /* Common subroutine called by attribute changing subroutines in order
774 to prevent them from changing a symbol that has been
775 use-associated. Returns zero if it is OK to change the symbol,
779 check_used (symbol_attribute *attr, const char *name, locus *where)
782 if (attr->use_assoc == 0)
786 where = &gfc_current_locus;
789 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
792 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
799 /* Generate an error because of a duplicate attribute. */
802 duplicate_attr (const char *attr, locus *where)
806 where = &gfc_current_locus;
808 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
813 gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
814 locus *where ATTRIBUTE_UNUSED)
816 attr->ext_attr |= 1 << ext_attr;
821 /* Called from decl.c (attr_decl1) to check attributes, when declared
825 gfc_add_attribute (symbol_attribute *attr, locus *where)
827 if (check_used (attr, NULL, where))
830 return check_conflict (attr, NULL, where);
835 gfc_add_allocatable (symbol_attribute *attr, locus *where)
838 if (check_used (attr, NULL, where))
841 if (attr->allocatable)
843 duplicate_attr ("ALLOCATABLE", where);
847 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
848 && gfc_find_state (COMP_INTERFACE) == FAILURE)
850 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
855 attr->allocatable = 1;
856 return check_conflict (attr, NULL, where);
861 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
864 if (check_used (attr, name, where))
869 duplicate_attr ("DIMENSION", where);
873 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
874 && gfc_find_state (COMP_INTERFACE) == FAILURE)
876 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
877 "at %L", name, where);
882 return check_conflict (attr, name, where);
887 gfc_add_external (symbol_attribute *attr, locus *where)
890 if (check_used (attr, NULL, where))
895 duplicate_attr ("EXTERNAL", where);
899 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
902 attr->proc_pointer = 1;
907 return check_conflict (attr, NULL, where);
912 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
915 if (check_used (attr, NULL, where))
920 duplicate_attr ("INTRINSIC", where);
926 return check_conflict (attr, NULL, where);
931 gfc_add_optional (symbol_attribute *attr, locus *where)
934 if (check_used (attr, NULL, where))
939 duplicate_attr ("OPTIONAL", where);
944 return check_conflict (attr, NULL, where);
949 gfc_add_pointer (symbol_attribute *attr, locus *where)
952 if (check_used (attr, NULL, where))
955 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
956 && gfc_find_state (COMP_INTERFACE) == FAILURE))
958 duplicate_attr ("POINTER", where);
962 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
963 || (attr->if_source == IFSRC_IFBODY
964 && gfc_find_state (COMP_INTERFACE) == FAILURE))
965 attr->proc_pointer = 1;
969 return check_conflict (attr, NULL, where);
974 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
977 if (check_used (attr, NULL, where))
980 attr->cray_pointer = 1;
981 return check_conflict (attr, NULL, where);
986 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
989 if (check_used (attr, NULL, where))
992 if (attr->cray_pointee)
994 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
995 " statements", where);
999 attr->cray_pointee = 1;
1000 return check_conflict (attr, NULL, where);
1005 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1007 if (check_used (attr, name, where))
1010 if (attr->is_protected)
1012 if (gfc_notify_std (GFC_STD_LEGACY,
1013 "Duplicate PROTECTED attribute specified at %L",
1019 attr->is_protected = 1;
1020 return check_conflict (attr, name, where);
1025 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1028 if (check_used (attr, name, where))
1032 return check_conflict (attr, name, where);
1037 gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
1040 if (check_used (attr, name, where))
1043 if (gfc_pure (NULL))
1046 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1051 if (attr->save == SAVE_EXPLICIT)
1053 if (gfc_notify_std (GFC_STD_LEGACY,
1054 "Duplicate SAVE attribute specified at %L",
1060 attr->save = SAVE_EXPLICIT;
1061 return check_conflict (attr, name, where);
1066 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1069 if (check_used (attr, name, where))
1074 if (gfc_notify_std (GFC_STD_LEGACY,
1075 "Duplicate VALUE attribute specified at %L",
1082 return check_conflict (attr, name, where);
1087 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1089 /* No check_used needed as 11.2.1 of the F2003 standard allows
1090 that the local identifier made accessible by a use statement can be
1091 given a VOLATILE attribute. */
1093 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1094 if (gfc_notify_std (GFC_STD_LEGACY,
1095 "Duplicate VOLATILE attribute specified at %L", where)
1099 attr->volatile_ = 1;
1100 attr->volatile_ns = gfc_current_ns;
1101 return check_conflict (attr, name, where);
1106 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1109 if (check_used (attr, name, where))
1112 if (attr->threadprivate)
1114 duplicate_attr ("THREADPRIVATE", where);
1118 attr->threadprivate = 1;
1119 return check_conflict (attr, name, where);
1124 gfc_add_target (symbol_attribute *attr, locus *where)
1127 if (check_used (attr, NULL, where))
1132 duplicate_attr ("TARGET", where);
1137 return check_conflict (attr, NULL, where);
1142 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1145 if (check_used (attr, name, where))
1148 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1150 return check_conflict (attr, name, where);
1155 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1158 if (check_used (attr, name, where))
1161 /* Duplicate attribute already checked for. */
1162 attr->in_common = 1;
1163 return check_conflict (attr, name, where);
1168 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1171 /* Duplicate attribute already checked for. */
1172 attr->in_equivalence = 1;
1173 if (check_conflict (attr, name, where) == FAILURE)
1176 if (attr->flavor == FL_VARIABLE)
1179 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1184 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1187 if (check_used (attr, name, where))
1191 return check_conflict (attr, name, where);
1196 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1199 attr->in_namelist = 1;
1200 return check_conflict (attr, name, where);
1205 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1208 if (check_used (attr, name, where))
1212 return check_conflict (attr, name, where);
1217 gfc_add_elemental (symbol_attribute *attr, locus *where)
1220 if (check_used (attr, NULL, where))
1223 if (attr->elemental)
1225 duplicate_attr ("ELEMENTAL", where);
1229 attr->elemental = 1;
1230 return check_conflict (attr, NULL, where);
1235 gfc_add_pure (symbol_attribute *attr, locus *where)
1238 if (check_used (attr, NULL, where))
1243 duplicate_attr ("PURE", where);
1248 return check_conflict (attr, NULL, where);
1253 gfc_add_recursive (symbol_attribute *attr, locus *where)
1256 if (check_used (attr, NULL, where))
1259 if (attr->recursive)
1261 duplicate_attr ("RECURSIVE", where);
1265 attr->recursive = 1;
1266 return check_conflict (attr, NULL, where);
1271 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1274 if (check_used (attr, name, where))
1279 duplicate_attr ("ENTRY", where);
1284 return check_conflict (attr, name, where);
1289 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1292 if (attr->flavor != FL_PROCEDURE
1293 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1297 return check_conflict (attr, name, where);
1302 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1305 if (attr->flavor != FL_PROCEDURE
1306 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1309 attr->subroutine = 1;
1310 return check_conflict (attr, name, where);
1315 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1318 if (attr->flavor != FL_PROCEDURE
1319 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1323 return check_conflict (attr, name, where);
1328 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1331 if (check_used (attr, NULL, where))
1334 if (attr->flavor != FL_PROCEDURE
1335 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1338 if (attr->procedure)
1340 duplicate_attr ("PROCEDURE", where);
1344 attr->procedure = 1;
1346 return check_conflict (attr, NULL, where);
1351 gfc_add_abstract (symbol_attribute* attr, locus* where)
1355 duplicate_attr ("ABSTRACT", where);
1364 /* Flavors are special because some flavors are not what Fortran
1365 considers attributes and can be reaffirmed multiple times. */
1368 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1372 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1373 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1374 || f == FL_NAMELIST) && check_used (attr, name, where))
1377 if (attr->flavor == f && f == FL_VARIABLE)
1380 if (attr->flavor != FL_UNKNOWN)
1383 where = &gfc_current_locus;
1386 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1387 gfc_code2string (flavors, attr->flavor), name,
1388 gfc_code2string (flavors, f), where);
1390 gfc_error ("%s attribute conflicts with %s attribute at %L",
1391 gfc_code2string (flavors, attr->flavor),
1392 gfc_code2string (flavors, f), where);
1399 return check_conflict (attr, name, where);
1404 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1405 const char *name, locus *where)
1408 if (check_used (attr, name, where))
1411 if (attr->flavor != FL_PROCEDURE
1412 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1416 where = &gfc_current_locus;
1418 if (attr->proc != PROC_UNKNOWN)
1420 gfc_error ("%s procedure at %L is already declared as %s procedure",
1421 gfc_code2string (procedures, t), where,
1422 gfc_code2string (procedures, attr->proc));
1429 /* Statement functions are always scalar and functions. */
1430 if (t == PROC_ST_FUNCTION
1431 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1432 || attr->dimension))
1435 return check_conflict (attr, name, where);
1440 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1443 if (check_used (attr, NULL, where))
1446 if (attr->intent == INTENT_UNKNOWN)
1448 attr->intent = intent;
1449 return check_conflict (attr, NULL, where);
1453 where = &gfc_current_locus;
1455 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1456 gfc_intent_string (attr->intent),
1457 gfc_intent_string (intent), where);
1463 /* No checks for use-association in public and private statements. */
1466 gfc_add_access (symbol_attribute *attr, gfc_access access,
1467 const char *name, locus *where)
1470 if (attr->access == ACCESS_UNKNOWN
1471 || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1473 attr->access = access;
1474 return check_conflict (attr, name, where);
1478 where = &gfc_current_locus;
1479 gfc_error ("ACCESS specification at %L was already specified", where);
1485 /* Set the is_bind_c field for the given symbol_attribute. */
1488 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1489 int is_proc_lang_bind_spec)
1492 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1493 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1494 "variables or common blocks", where);
1495 else if (attr->is_bind_c)
1496 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1498 attr->is_bind_c = 1;
1501 where = &gfc_current_locus;
1503 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1507 return check_conflict (attr, name, where);
1511 /* Set the extension field for the given symbol_attribute. */
1514 gfc_add_extension (symbol_attribute *attr, locus *where)
1517 where = &gfc_current_locus;
1519 if (attr->extension)
1520 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1522 attr->extension = 1;
1524 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
1533 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1534 gfc_formal_arglist * formal, locus *where)
1537 if (check_used (&sym->attr, sym->name, where))
1541 where = &gfc_current_locus;
1543 if (sym->attr.if_source != IFSRC_UNKNOWN
1544 && sym->attr.if_source != IFSRC_DECL)
1546 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1551 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1553 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1554 "body", sym->name, where);
1558 sym->formal = formal;
1559 sym->attr.if_source = source;
1565 /* Add a type to a symbol. */
1568 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1574 where = &gfc_current_locus;
1577 type = sym->result->ts.type;
1579 type = sym->ts.type;
1581 if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
1582 type = sym->ns->proc_name->ts.type;
1584 if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
1586 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1587 where, gfc_basic_typename (type));
1591 if (sym->attr.procedure && sym->ts.interface)
1593 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1594 sym->name, where, gfc_basic_typename (ts->type));
1598 flavor = sym->attr.flavor;
1600 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1601 || flavor == FL_LABEL
1602 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1603 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1605 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1614 /* Clears all attributes. */
1617 gfc_clear_attr (symbol_attribute *attr)
1619 memset (attr, 0, sizeof (symbol_attribute));
1623 /* Check for missing attributes in the new symbol. Currently does
1624 nothing, but it's not clear that it is unnecessary yet. */
1627 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1628 locus *where ATTRIBUTE_UNUSED)
1635 /* Copy an attribute to a symbol attribute, bit by bit. Some
1636 attributes have a lot of side-effects but cannot be present given
1637 where we are called from, so we ignore some bits. */
1640 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1642 int is_proc_lang_bind_spec;
1644 /* In line with the other attributes, we only add bits but do not remove
1645 them; cf. also PR 41034. */
1646 dest->ext_attr |= src->ext_attr;
1648 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1651 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1653 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1655 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1657 if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1659 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1661 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1663 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1665 if (src->threadprivate
1666 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1668 if (src->target && gfc_add_target (dest, where) == FAILURE)
1670 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1672 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1677 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1680 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1683 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1685 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1687 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1690 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1692 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1694 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1696 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1699 if (src->flavor != FL_UNKNOWN
1700 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1703 if (src->intent != INTENT_UNKNOWN
1704 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1707 if (src->access != ACCESS_UNKNOWN
1708 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1711 if (gfc_missing_attr (dest, where) == FAILURE)
1714 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1716 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1719 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1721 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1725 if (src->is_c_interop)
1726 dest->is_c_interop = 1;
1730 if (src->external && gfc_add_external (dest, where) == FAILURE)
1732 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1734 if (src->proc_pointer)
1735 dest->proc_pointer = 1;
1744 /************** Component name management ************/
1746 /* Component names of a derived type form their own little namespaces
1747 that are separate from all other spaces. The space is composed of
1748 a singly linked list of gfc_component structures whose head is
1749 located in the parent symbol. */
1752 /* Add a component name to a symbol. The call fails if the name is
1753 already present. On success, the component pointer is modified to
1754 point to the additional component structure. */
1757 gfc_add_component (gfc_symbol *sym, const char *name,
1758 gfc_component **component)
1760 gfc_component *p, *tail;
1764 for (p = sym->components; p; p = p->next)
1766 if (strcmp (p->name, name) == 0)
1768 gfc_error ("Component '%s' at %C already declared at %L",
1776 if (sym->attr.extension
1777 && gfc_find_component (sym->components->ts.u.derived, name, true, true))
1779 gfc_error ("Component '%s' at %C already in the parent type "
1780 "at %L", name, &sym->components->ts.u.derived->declared_at);
1784 /* Allocate a new component. */
1785 p = gfc_get_component ();
1788 sym->components = p;
1792 p->name = gfc_get_string (name);
1793 p->loc = gfc_current_locus;
1794 p->ts.type = BT_UNKNOWN;
1801 /* Recursive function to switch derived types of all symbol in a
1805 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1813 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
1814 sym->ts.u.derived = to;
1816 switch_types (st->left, from, to);
1817 switch_types (st->right, from, to);
1821 /* This subroutine is called when a derived type is used in order to
1822 make the final determination about which version to use. The
1823 standard requires that a type be defined before it is 'used', but
1824 such types can appear in IMPLICIT statements before the actual
1825 definition. 'Using' in this context means declaring a variable to
1826 be that type or using the type constructor.
1828 If a type is used and the components haven't been defined, then we
1829 have to have a derived type in a parent unit. We find the node in
1830 the other namespace and point the symtree node in this namespace to
1831 that node. Further reference to this name point to the correct
1832 node. If we can't find the node in a parent namespace, then we have
1835 This subroutine takes a pointer to a symbol node and returns a
1836 pointer to the translated node or NULL for an error. Usually there
1837 is no translation and we return the node we were passed. */
1840 gfc_use_derived (gfc_symbol *sym)
1847 if (sym->components != NULL || sym->attr.zero_comp)
1848 return sym; /* Already defined. */
1850 if (sym->ns->parent == NULL)
1853 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1855 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1859 if (s == NULL || s->attr.flavor != FL_DERIVED)
1862 /* Get rid of symbol sym, translating all references to s. */
1863 for (i = 0; i < GFC_LETTERS; i++)
1865 t = &sym->ns->default_type[i];
1866 if (t->u.derived == sym)
1870 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1875 /* Unlink from list of modified symbols. */
1876 gfc_commit_symbol (sym);
1878 switch_types (sym->ns->sym_root, sym, s);
1880 /* TODO: Also have to replace sym -> s in other lists like
1881 namelists, common lists and interface lists. */
1882 gfc_free_symbol (sym);
1887 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1893 /* Given a derived type node and a component name, try to locate the
1894 component structure. Returns the NULL pointer if the component is
1895 not found or the components are private. If noaccess is set, no access
1899 gfc_find_component (gfc_symbol *sym, const char *name,
1900 bool noaccess, bool silent)
1907 sym = gfc_use_derived (sym);
1912 for (p = sym->components; p; p = p->next)
1913 if (strcmp (p->name, name) == 0)
1917 && sym->attr.extension
1918 && sym->components->ts.type == BT_DERIVED)
1920 p = gfc_find_component (sym->components->ts.u.derived, name,
1922 /* Do not overwrite the error. */
1927 if (p == NULL && !silent)
1928 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1931 else if (sym->attr.use_assoc && !noaccess)
1933 if (p->attr.access == ACCESS_PRIVATE)
1936 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1941 /* If there were components given and all components are private, error
1942 out at this place. */
1943 if (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
1946 gfc_error ("All components of '%s' are PRIVATE in structure"
1947 " constructor at %C", sym->name);
1956 /* Given a symbol, free all of the component structures and everything
1960 free_components (gfc_component *p)
1968 gfc_free_array_spec (p->as);
1969 gfc_free_expr (p->initializer);
1976 /******************** Statement label management ********************/
1978 /* Comparison function for statement labels, used for managing the
1982 compare_st_labels (void *a1, void *b1)
1984 int a = ((gfc_st_label *) a1)->value;
1985 int b = ((gfc_st_label *) b1)->value;
1991 /* Free a single gfc_st_label structure, making sure the tree is not
1992 messed up. This function is called only when some parse error
1996 gfc_free_st_label (gfc_st_label *label)
2002 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
2004 if (label->format != NULL)
2005 gfc_free_expr (label->format);
2011 /* Free a whole tree of gfc_st_label structures. */
2014 free_st_labels (gfc_st_label *label)
2020 free_st_labels (label->left);
2021 free_st_labels (label->right);
2023 if (label->format != NULL)
2024 gfc_free_expr (label->format);
2029 /* Given a label number, search for and return a pointer to the label
2030 structure, creating it if it does not exist. */
2033 gfc_get_st_label (int labelno)
2037 /* First see if the label is already in this namespace. */
2038 lp = gfc_current_ns->st_labels;
2041 if (lp->value == labelno)
2044 if (lp->value < labelno)
2050 lp = XCNEW (gfc_st_label);
2052 lp->value = labelno;
2053 lp->defined = ST_LABEL_UNKNOWN;
2054 lp->referenced = ST_LABEL_UNKNOWN;
2056 gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
2062 /* Called when a statement with a statement label is about to be
2063 accepted. We add the label to the list of the current namespace,
2064 making sure it hasn't been defined previously and referenced
2068 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2072 labelno = lp->value;
2074 if (lp->defined != ST_LABEL_UNKNOWN)
2075 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2076 &lp->where, label_locus);
2079 lp->where = *label_locus;
2083 case ST_LABEL_FORMAT:
2084 if (lp->referenced == ST_LABEL_TARGET)
2085 gfc_error ("Label %d at %C already referenced as branch target",
2088 lp->defined = ST_LABEL_FORMAT;
2092 case ST_LABEL_TARGET:
2093 if (lp->referenced == ST_LABEL_FORMAT)
2094 gfc_error ("Label %d at %C already referenced as a format label",
2097 lp->defined = ST_LABEL_TARGET;
2102 lp->defined = ST_LABEL_BAD_TARGET;
2103 lp->referenced = ST_LABEL_BAD_TARGET;
2109 /* Reference a label. Given a label and its type, see if that
2110 reference is consistent with what is known about that label,
2111 updating the unknown state. Returns FAILURE if something goes
2115 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2117 gfc_sl_type label_type;
2124 labelno = lp->value;
2126 if (lp->defined != ST_LABEL_UNKNOWN)
2127 label_type = lp->defined;
2130 label_type = lp->referenced;
2131 lp->where = gfc_current_locus;
2134 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2136 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2141 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2142 && type == ST_LABEL_FORMAT)
2144 gfc_error ("Label %d at %C previously used as branch target", labelno);
2149 lp->referenced = type;
2157 /*******A helper function for creating new expressions*************/
2161 gfc_lval_expr_from_sym (gfc_symbol *sym)
2164 lval = gfc_get_expr ();
2165 lval->expr_type = EXPR_VARIABLE;
2166 lval->where = sym->declared_at;
2168 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2170 /* It will always be a full array. */
2171 lval->rank = sym->as ? sym->as->rank : 0;
2174 lval->ref = gfc_get_ref ();
2175 lval->ref->type = REF_ARRAY;
2176 lval->ref->u.ar.type = AR_FULL;
2177 lval->ref->u.ar.dimen = lval->rank;
2178 lval->ref->u.ar.where = sym->declared_at;
2179 lval->ref->u.ar.as = sym->as;
2186 /************** Symbol table management subroutines ****************/
2188 /* Basic details: Fortran 95 requires a potentially unlimited number
2189 of distinct namespaces when compiling a program unit. This case
2190 occurs during a compilation of internal subprograms because all of
2191 the internal subprograms must be read before we can start
2192 generating code for the host.
2194 Given the tricky nature of the Fortran grammar, we must be able to
2195 undo changes made to a symbol table if the current interpretation
2196 of a statement is found to be incorrect. Whenever a symbol is
2197 looked up, we make a copy of it and link to it. All of these
2198 symbols are kept in a singly linked list so that we can commit or
2199 undo the changes at a later time.
2201 A symtree may point to a symbol node outside of its namespace. In
2202 this case, that symbol has been used as a host associated variable
2203 at some previous time. */
2205 /* Allocate a new namespace structure. Copies the implicit types from
2206 PARENT if PARENT_TYPES is set. */
2209 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2216 ns = XCNEW (gfc_namespace);
2217 ns->sym_root = NULL;
2218 ns->uop_root = NULL;
2219 ns->tb_sym_root = NULL;
2220 ns->finalizers = NULL;
2221 ns->default_access = ACCESS_UNKNOWN;
2222 ns->parent = parent;
2224 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2226 ns->operator_access[in] = ACCESS_UNKNOWN;
2227 ns->tb_op[in] = NULL;
2230 /* Initialize default implicit types. */
2231 for (i = 'a'; i <= 'z'; i++)
2233 ns->set_flag[i - 'a'] = 0;
2234 ts = &ns->default_type[i - 'a'];
2236 if (parent_types && ns->parent != NULL)
2238 /* Copy parent settings. */
2239 *ts = ns->parent->default_type[i - 'a'];
2243 if (gfc_option.flag_implicit_none != 0)
2249 if ('i' <= i && i <= 'n')
2251 ts->type = BT_INTEGER;
2252 ts->kind = gfc_default_integer_kind;
2257 ts->kind = gfc_default_real_kind;
2267 /* Comparison function for symtree nodes. */
2270 compare_symtree (void *_st1, void *_st2)
2272 gfc_symtree *st1, *st2;
2274 st1 = (gfc_symtree *) _st1;
2275 st2 = (gfc_symtree *) _st2;
2277 return strcmp (st1->name, st2->name);
2281 /* Allocate a new symtree node and associate it with the new symbol. */
2284 gfc_new_symtree (gfc_symtree **root, const char *name)
2288 st = XCNEW (gfc_symtree);
2289 st->name = gfc_get_string (name);
2291 gfc_insert_bbt (root, st, compare_symtree);
2296 /* Delete a symbol from the tree. Does not free the symbol itself! */
2299 gfc_delete_symtree (gfc_symtree **root, const char *name)
2301 gfc_symtree st, *st0;
2303 st0 = gfc_find_symtree (*root, name);
2305 st.name = gfc_get_string (name);
2306 gfc_delete_bbt (root, &st, compare_symtree);
2312 /* Given a root symtree node and a name, try to find the symbol within
2313 the namespace. Returns NULL if the symbol is not found. */
2316 gfc_find_symtree (gfc_symtree *st, const char *name)
2322 c = strcmp (name, st->name);
2326 st = (c < 0) ? st->left : st->right;
2333 /* Return a symtree node with a name that is guaranteed to be unique
2334 within the namespace and corresponds to an illegal fortran name. */
2337 gfc_get_unique_symtree (gfc_namespace *ns)
2339 char name[GFC_MAX_SYMBOL_LEN + 1];
2340 static int serial = 0;
2342 sprintf (name, "@%d", serial++);
2343 return gfc_new_symtree (&ns->sym_root, name);
2347 /* Given a name find a user operator node, creating it if it doesn't
2348 exist. These are much simpler than symbols because they can't be
2349 ambiguous with one another. */
2352 gfc_get_uop (const char *name)
2357 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2361 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2363 uop = st->n.uop = XCNEW (gfc_user_op);
2364 uop->name = gfc_get_string (name);
2365 uop->access = ACCESS_UNKNOWN;
2366 uop->ns = gfc_current_ns;
2372 /* Given a name find the user operator node. Returns NULL if it does
2376 gfc_find_uop (const char *name, gfc_namespace *ns)
2381 ns = gfc_current_ns;
2383 st = gfc_find_symtree (ns->uop_root, name);
2384 return (st == NULL) ? NULL : st->n.uop;
2388 /* Remove a gfc_symbol structure and everything it points to. */
2391 gfc_free_symbol (gfc_symbol *sym)
2397 gfc_free_array_spec (sym->as);
2399 free_components (sym->components);
2401 gfc_free_expr (sym->value);
2403 gfc_free_namelist (sym->namelist);
2405 gfc_free_namespace (sym->formal_ns);
2407 if (!sym->attr.generic_copy)
2408 gfc_free_interface (sym->generic);
2410 gfc_free_formal_arglist (sym->formal);
2412 gfc_free_namespace (sym->f2k_derived);
2418 /* Allocate and initialize a new symbol node. */
2421 gfc_new_symbol (const char *name, gfc_namespace *ns)
2425 p = XCNEW (gfc_symbol);
2427 gfc_clear_ts (&p->ts);
2428 gfc_clear_attr (&p->attr);
2431 p->declared_at = gfc_current_locus;
2433 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2434 gfc_internal_error ("new_symbol(): Symbol name too long");
2436 p->name = gfc_get_string (name);
2438 /* Make sure flags for symbol being C bound are clear initially. */
2439 p->attr.is_bind_c = 0;
2440 p->attr.is_iso_c = 0;
2441 /* Make sure the binding label field has a Nul char to start. */
2442 p->binding_label[0] = '\0';
2444 /* Clear the ptrs we may need. */
2445 p->common_block = NULL;
2446 p->f2k_derived = NULL;
2452 /* Generate an error if a symbol is ambiguous. */
2455 ambiguous_symbol (const char *name, gfc_symtree *st)
2458 if (st->n.sym->module)
2459 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2460 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2462 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2463 "from current program unit", name, st->n.sym->name);
2467 /* Search for a symtree starting in the current namespace, resorting to
2468 any parent namespaces if requested by a nonzero parent_flag.
2469 Returns nonzero if the name is ambiguous. */
2472 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2473 gfc_symtree **result)
2478 ns = gfc_current_ns;
2482 st = gfc_find_symtree (ns->sym_root, name);
2486 /* Ambiguous generic interfaces are permitted, as long
2487 as the specific interfaces are different. */
2488 if (st->ambiguous && !st->n.sym->attr.generic)
2490 ambiguous_symbol (name, st);
2509 /* Same, but returns the symbol instead. */
2512 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2513 gfc_symbol **result)
2518 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2523 *result = st->n.sym;
2529 /* Save symbol with the information necessary to back it out. */
2532 save_symbol_data (gfc_symbol *sym)
2535 if (sym->gfc_new || sym->old_symbol != NULL)
2538 sym->old_symbol = XCNEW (gfc_symbol);
2539 *(sym->old_symbol) = *sym;
2541 sym->tlink = changed_syms;
2546 /* Given a name, find a symbol, or create it if it does not exist yet
2547 in the current namespace. If the symbol is found we make sure that
2550 The integer return code indicates
2552 1 The symbol name was ambiguous
2553 2 The name meant to be established was already host associated.
2555 So if the return value is nonzero, then an error was issued. */
2558 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2559 bool allow_subroutine)
2564 /* This doesn't usually happen during resolution. */
2566 ns = gfc_current_ns;
2568 /* Try to find the symbol in ns. */
2569 st = gfc_find_symtree (ns->sym_root, name);
2573 /* If not there, create a new symbol. */
2574 p = gfc_new_symbol (name, ns);
2576 /* Add to the list of tentative symbols. */
2577 p->old_symbol = NULL;
2578 p->tlink = changed_syms;
2583 st = gfc_new_symtree (&ns->sym_root, name);
2590 /* Make sure the existing symbol is OK. Ambiguous
2591 generic interfaces are permitted, as long as the
2592 specific interfaces are different. */
2593 if (st->ambiguous && !st->n.sym->attr.generic)
2595 ambiguous_symbol (name, st);
2600 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2601 && !(allow_subroutine && p->attr.subroutine)
2602 && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2603 && (ns->has_import_set || p->attr.imported)))
2605 /* Symbol is from another namespace. */
2606 gfc_error ("Symbol '%s' at %C has already been host associated",
2613 /* Copy in case this symbol is changed. */
2614 save_symbol_data (p);
2623 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2628 i = gfc_get_sym_tree (name, ns, &st, false);
2633 *result = st->n.sym;
2640 /* Subroutine that searches for a symbol, creating it if it doesn't
2641 exist, but tries to host-associate the symbol if possible. */
2644 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2649 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2652 save_symbol_data (st->n.sym);
2657 if (gfc_current_ns->parent != NULL)
2659 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2670 return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2675 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2680 i = gfc_get_ha_sym_tree (name, &st);
2683 *result = st->n.sym;
2690 /* Return true if both symbols could refer to the same data object. Does
2691 not take account of aliasing due to equivalence statements. */
2694 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2696 /* Aliasing isn't possible if the symbols have different base types. */
2697 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2700 /* Pointers can point to other pointers, target objects and allocatable
2701 objects. Two allocatable objects cannot share the same storage. */
2702 if (lsym->attr.pointer
2703 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2705 if (lsym->attr.target && rsym->attr.pointer)
2707 if (lsym->attr.allocatable && rsym->attr.pointer)
2714 /* Undoes all the changes made to symbols in the current statement.
2715 This subroutine is made simpler due to the fact that attributes are
2716 never removed once added. */
2719 gfc_undo_symbols (void)
2721 gfc_symbol *p, *q, *old;
2722 tentative_tbp *tbp, *tbq;
2724 for (p = changed_syms; p; p = q)
2730 /* Symbol was new. */
2731 if (p->attr.in_common && p->common_block->head)
2733 /* If the symbol was added to any common block, it
2734 needs to be removed to stop the resolver looking
2735 for a (possibly) dead symbol. */
2737 if (p->common_block->head == p)
2738 p->common_block->head = p->common_next;
2741 gfc_symbol *cparent, *csym;
2743 cparent = p->common_block->head;
2744 csym = cparent->common_next;
2749 csym = csym->common_next;
2752 gcc_assert(cparent->common_next == p);
2754 cparent->common_next = csym->common_next;
2758 gfc_delete_symtree (&p->ns->sym_root, p->name);
2762 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2764 gfc_free_symbol (p);
2768 /* Restore previous state of symbol. Just copy simple stuff. */
2770 old = p->old_symbol;
2772 p->ts.type = old->ts.type;
2773 p->ts.kind = old->ts.kind;
2775 p->attr = old->attr;
2777 if (p->value != old->value)
2779 gfc_free_expr (old->value);
2783 if (p->as != old->as)
2786 gfc_free_array_spec (p->as);
2790 p->generic = old->generic;
2791 p->component_access = old->component_access;
2793 if (p->namelist != NULL && old->namelist == NULL)
2795 gfc_free_namelist (p->namelist);
2800 if (p->namelist_tail != old->namelist_tail)
2802 gfc_free_namelist (old->namelist_tail);
2803 old->namelist_tail->next = NULL;
2807 p->namelist_tail = old->namelist_tail;
2809 if (p->formal != old->formal)
2811 gfc_free_formal_arglist (p->formal);
2812 p->formal = old->formal;
2815 gfc_free (p->old_symbol);
2816 p->old_symbol = NULL;
2820 changed_syms = NULL;
2822 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2825 /* Procedure is already marked `error' by default. */
2828 tentative_tbp_list = NULL;
2832 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2833 components of old_symbol that might need deallocation are the "allocatables"
2834 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2835 namelist_tail. In case these differ between old_symbol and sym, it's just
2836 because sym->namelist has gotten a few more items. */
2839 free_old_symbol (gfc_symbol *sym)
2842 if (sym->old_symbol == NULL)
2845 if (sym->old_symbol->as != sym->as)
2846 gfc_free_array_spec (sym->old_symbol->as);
2848 if (sym->old_symbol->value != sym->value)
2849 gfc_free_expr (sym->old_symbol->value);
2851 if (sym->old_symbol->formal != sym->formal)
2852 gfc_free_formal_arglist (sym->old_symbol->formal);
2854 gfc_free (sym->old_symbol);
2855 sym->old_symbol = NULL;
2859 /* Makes the changes made in the current statement permanent-- gets
2860 rid of undo information. */
2863 gfc_commit_symbols (void)
2866 tentative_tbp *tbp, *tbq;
2868 for (p = changed_syms; p; p = q)
2874 free_old_symbol (p);
2876 changed_syms = NULL;
2878 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2881 tbp->proc->error = 0;
2884 tentative_tbp_list = NULL;
2888 /* Makes the changes made in one symbol permanent -- gets rid of undo
2892 gfc_commit_symbol (gfc_symbol *sym)
2896 if (changed_syms == sym)
2897 changed_syms = sym->tlink;
2900 for (p = changed_syms; p; p = p->tlink)
2901 if (p->tlink == sym)
2903 p->tlink = sym->tlink;
2912 free_old_symbol (sym);
2916 /* Recursively free trees containing type-bound procedures. */
2919 free_tb_tree (gfc_symtree *t)
2924 free_tb_tree (t->left);
2925 free_tb_tree (t->right);
2927 /* TODO: Free type-bound procedure structs themselves; probably needs some
2928 sort of ref-counting mechanism. */
2934 /* Recursive function that deletes an entire tree and all the common
2935 head structures it points to. */
2938 free_common_tree (gfc_symtree * common_tree)
2940 if (common_tree == NULL)
2943 free_common_tree (common_tree->left);
2944 free_common_tree (common_tree->right);
2946 gfc_free (common_tree);
2950 /* Recursive function that deletes an entire tree and all the user
2951 operator nodes that it contains. */
2954 free_uop_tree (gfc_symtree *uop_tree)
2956 if (uop_tree == NULL)
2959 free_uop_tree (uop_tree->left);
2960 free_uop_tree (uop_tree->right);
2962 gfc_free_interface (uop_tree->n.uop->op);
2963 gfc_free (uop_tree->n.uop);
2964 gfc_free (uop_tree);
2968 /* Recursive function that deletes an entire tree and all the symbols
2969 that it contains. */
2972 free_sym_tree (gfc_symtree *sym_tree)
2977 if (sym_tree == NULL)
2980 free_sym_tree (sym_tree->left);
2981 free_sym_tree (sym_tree->right);
2983 sym = sym_tree->n.sym;
2987 gfc_internal_error ("free_sym_tree(): Negative refs");
2989 if (sym->formal_ns != NULL && sym->refs == 1)
2991 /* As formal_ns contains a reference to sym, delete formal_ns just
2992 before the deletion of sym. */
2993 ns = sym->formal_ns;
2994 sym->formal_ns = NULL;
2995 gfc_free_namespace (ns);
2997 else if (sym->refs == 0)
2999 /* Go ahead and delete the symbol. */
3000 gfc_free_symbol (sym);
3003 gfc_free (sym_tree);
3007 /* Free the derived type list. */
3010 gfc_free_dt_list (void)
3012 gfc_dt_list *dt, *n;
3014 for (dt = gfc_derived_types; dt; dt = n)
3020 gfc_derived_types = NULL;
3024 /* Free the gfc_equiv_info's. */
3027 gfc_free_equiv_infos (gfc_equiv_info *s)
3031 gfc_free_equiv_infos (s->next);
3036 /* Free the gfc_equiv_lists. */
3039 gfc_free_equiv_lists (gfc_equiv_list *l)
3043 gfc_free_equiv_lists (l->next);
3044 gfc_free_equiv_infos (l->equiv);
3049 /* Free a finalizer procedure list. */
3052 gfc_free_finalizer (gfc_finalizer* el)
3058 --el->proc_sym->refs;
3059 if (!el->proc_sym->refs)
3060 gfc_free_symbol (el->proc_sym);
3068 gfc_free_finalizer_list (gfc_finalizer* list)
3072 gfc_finalizer* current = list;
3074 gfc_free_finalizer (current);
3079 /* Create a new gfc_charlen structure and add it to a namespace. */
3082 gfc_new_charlen (gfc_namespace *ns)
3085 cl = gfc_get_charlen ();
3086 cl->next = ns->cl_list;
3092 /* Free the charlen list from cl to end (end is not freed).
3093 Free the whole list if end is NULL. */
3095 void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3099 for (; cl != end; cl = cl2)
3104 gfc_free_expr (cl->length);
3110 /* Free a namespace structure and everything below it. Interface
3111 lists associated with intrinsic operators are not freed. These are
3112 taken care of when a specific name is freed. */
3115 gfc_free_namespace (gfc_namespace *ns)
3117 gfc_namespace *p, *q;
3126 gcc_assert (ns->refs == 0);
3128 gfc_free_statements (ns->code);
3130 free_sym_tree (ns->sym_root);
3131 free_uop_tree (ns->uop_root);
3132 free_common_tree (ns->common_root);
3133 free_tb_tree (ns->tb_sym_root);
3134 free_tb_tree (ns->tb_uop_root);
3135 gfc_free_finalizer_list (ns->finalizers);
3136 gfc_free_charlen (ns->cl_list, NULL);
3137 free_st_labels (ns->st_labels);
3139 gfc_free_equiv (ns->equiv);
3140 gfc_free_equiv_lists (ns->equiv_lists);
3141 gfc_free_use_stmts (ns->use_stmts);
3143 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3144 gfc_free_interface (ns->op[i]);
3146 gfc_free_data (ns->data);
3150 /* Recursively free any contained namespaces. */
3155 gfc_free_namespace (q);
3161 gfc_symbol_init_2 (void)
3164 gfc_current_ns = gfc_get_namespace (NULL, 0);
3169 gfc_symbol_done_2 (void)
3172 gfc_free_namespace (gfc_current_ns);
3173 gfc_current_ns = NULL;
3174 gfc_free_dt_list ();
3178 /* Clear mark bits from symbol nodes associated with a symtree node. */
3181 clear_sym_mark (gfc_symtree *st)
3184 st->n.sym->mark = 0;
3188 /* Recursively traverse the symtree nodes. */
3191 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
3196 gfc_traverse_symtree (st->left, func);
3198 gfc_traverse_symtree (st->right, func);
3202 /* Recursive namespace traversal function. */
3205 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
3211 traverse_ns (st->left, func);
3213 if (st->n.sym->mark == 0)
3214 (*func) (st->n.sym);
3215 st->n.sym->mark = 1;
3217 traverse_ns (st->right, func);
3221 /* Call a given function for all symbols in the namespace. We take
3222 care that each gfc_symbol node is called exactly once. */
3225 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3228 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3230 traverse_ns (ns->sym_root, func);
3234 /* Return TRUE when name is the name of an intrinsic type. */
3237 gfc_is_intrinsic_typename (const char *name)
3239 if (strcmp (name, "integer") == 0
3240 || strcmp (name, "real") == 0
3241 || strcmp (name, "character") == 0
3242 || strcmp (name, "logical") == 0
3243 || strcmp (name, "complex") == 0
3244 || strcmp (name, "doubleprecision") == 0
3245 || strcmp (name, "doublecomplex") == 0)
3252 /* Return TRUE if the symbol is an automatic variable. */
3255 gfc_is_var_automatic (gfc_symbol *sym)
3257 /* Pointer and allocatable variables are never automatic. */
3258 if (sym->attr.pointer || sym->attr.allocatable)
3260 /* Check for arrays with non-constant size. */
3261 if (sym->attr.dimension && sym->as
3262 && !gfc_is_compile_time_shape (sym->as))
3264 /* Check for non-constant length character variables. */
3265 if (sym->ts.type == BT_CHARACTER
3267 && !gfc_is_constant_expr (sym->ts.u.cl->length))
3272 /* Given a symbol, mark it as SAVEd if it is allowed. */
3275 save_symbol (gfc_symbol *sym)
3278 if (sym->attr.use_assoc)
3281 if (sym->attr.in_common
3284 || sym->attr.flavor != FL_VARIABLE)
3286 /* Automatic objects are not saved. */
3287 if (gfc_is_var_automatic (sym))
3289 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3293 /* Mark those symbols which can be SAVEd as such. */
3296 gfc_save_all (gfc_namespace *ns)
3298 gfc_traverse_ns (ns, save_symbol);
3303 /* Make sure that no changes to symbols are pending. */
3306 gfc_symbol_state(void) {
3308 if (changed_syms != NULL)
3309 gfc_internal_error("Symbol changes still pending!");
3314 /************** Global symbol handling ************/
3317 /* Search a tree for the global symbol. */
3320 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3329 c = strcmp (name, symbol->name);
3333 symbol = (c < 0) ? symbol->left : symbol->right;
3340 /* Compare two global symbols. Used for managing the BB tree. */
3343 gsym_compare (void *_s1, void *_s2)
3345 gfc_gsymbol *s1, *s2;
3347 s1 = (gfc_gsymbol *) _s1;
3348 s2 = (gfc_gsymbol *) _s2;
3349 return strcmp (s1->name, s2->name);
3353 /* Get a global symbol, creating it if it doesn't exist. */
3356 gfc_get_gsymbol (const char *name)
3360 s = gfc_find_gsymbol (gfc_gsym_root, name);
3364 s = XCNEW (gfc_gsymbol);
3365 s->type = GSYM_UNKNOWN;
3366 s->name = gfc_get_string (name);
3368 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3375 get_iso_c_binding_dt (int sym_id)
3377 gfc_dt_list *dt_list;
3379 dt_list = gfc_derived_types;
3381 /* Loop through the derived types in the name list, searching for
3382 the desired symbol from iso_c_binding. Search the parent namespaces
3383 if necessary and requested to (parent_flag). */
3384 while (dt_list != NULL)
3386 if (dt_list->derived->from_intmod != INTMOD_NONE
3387 && dt_list->derived->intmod_sym_id == sym_id)
3388 return dt_list->derived;
3390 dt_list = dt_list->next;
3397 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3398 with C. This is necessary for any derived type that is BIND(C) and for
3399 derived types that are parameters to functions that are BIND(C). All
3400 fields of the derived type are required to be interoperable, and are tested
3401 for such. If an error occurs, the errors are reported here, allowing for
3402 multiple errors to be handled for a single derived type. */
3405 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3407 gfc_component *curr_comp = NULL;
3408 gfc_try is_c_interop = FAILURE;
3409 gfc_try retval = SUCCESS;
3411 if (derived_sym == NULL)
3412 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3413 "unexpectedly NULL");
3415 /* If we've already looked at this derived symbol, do not look at it again
3416 so we don't repeat warnings/errors. */
3417 if (derived_sym->ts.is_c_interop)
3420 /* The derived type must have the BIND attribute to be interoperable
3421 J3/04-007, Section 15.2.3. */
3422 if (derived_sym->attr.is_bind_c != 1)
3424 derived_sym->ts.is_c_interop = 0;
3425 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3426 "attribute to be C interoperable", derived_sym->name,
3427 &(derived_sym->declared_at));
3431 curr_comp = derived_sym->components;
3433 /* TODO: is this really an error? */
3434 if (curr_comp == NULL)
3436 gfc_error ("Derived type '%s' at %L is empty",
3437 derived_sym->name, &(derived_sym->declared_at));
3441 /* Initialize the derived type as being C interoperable.
3442 If we find an error in the components, this will be set false. */
3443 derived_sym->ts.is_c_interop = 1;
3445 /* Loop through the list of components to verify that the kind of
3446 each is a C interoperable type. */
3449 /* The components cannot be pointers (fortran sense).
3450 J3/04-007, Section 15.2.3, C1505. */
3451 if (curr_comp->attr.pointer != 0)
3453 gfc_error ("Component '%s' at %L cannot have the "
3454 "POINTER attribute because it is a member "
3455 "of the BIND(C) derived type '%s' at %L",
3456 curr_comp->name, &(curr_comp->loc),
3457 derived_sym->name, &(derived_sym->declared_at));
3461 if (curr_comp->attr.proc_pointer != 0)
3463 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3464 " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3465 &curr_comp->loc, derived_sym->name,
3466 &derived_sym->declared_at);
3470 /* The components cannot be allocatable.
3471 J3/04-007, Section 15.2.3, C1505. */
3472 if (curr_comp->attr.allocatable != 0)
3474 gfc_error ("Component '%s' at %L cannot have the "
3475 "ALLOCATABLE attribute because it is a member "
3476 "of the BIND(C) derived type '%s' at %L",
3477 curr_comp->name, &(curr_comp->loc),
3478 derived_sym->name, &(derived_sym->declared_at));
3482 /* BIND(C) derived types must have interoperable components. */
3483 if (curr_comp->ts.type == BT_DERIVED
3484 && curr_comp->ts.u.derived->ts.is_iso_c != 1
3485 && curr_comp->ts.u.derived != derived_sym)
3487 /* This should be allowed; the draft says a derived-type can not
3488 have type parameters if it is has the BIND attribute. Type
3489 parameters seem to be for making parameterized derived types.
3490 There's no need to verify the type if it is c_ptr/c_funptr. */
3491 retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3495 /* Grab the typespec for the given component and test the kind. */
3496 is_c_interop = verify_c_interop (&(curr_comp->ts));
3498 if (is_c_interop != SUCCESS)
3500 /* Report warning and continue since not fatal. The
3501 draft does specify a constraint that requires all fields
3502 to interoperate, but if the user says real(4), etc., it
3503 may interoperate with *something* in C, but the compiler
3504 most likely won't know exactly what. Further, it may not
3505 interoperate with the same data type(s) in C if the user
3506 recompiles with different flags (e.g., -m32 and -m64 on
3507 x86_64 and using integer(4) to claim interop with a
3509 if (derived_sym->attr.is_bind_c == 1)
3510 /* If the derived type is bind(c), all fields must be
3512 gfc_warning ("Component '%s' in derived type '%s' at %L "
3513 "may not be C interoperable, even though "
3514 "derived type '%s' is BIND(C)",
3515 curr_comp->name, derived_sym->name,
3516 &(curr_comp->loc), derived_sym->name);
3518 /* If derived type is param to bind(c) routine, or to one
3519 of the iso_c_binding procs, it must be interoperable, so
3520 all fields must interop too. */
3521 gfc_warning ("Component '%s' in derived type '%s' at %L "
3522 "may not be C interoperable",
3523 curr_comp->name, derived_sym->name,
3528 curr_comp = curr_comp->next;
3529 } while (curr_comp != NULL);
3532 /* Make sure we don't have conflicts with the attributes. */
3533 if (derived_sym->attr.access == ACCESS_PRIVATE)
3535 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3536 "PRIVATE and BIND(C) attributes", derived_sym->name,
3537 &(derived_sym->declared_at));
3541 if (derived_sym->attr.sequence != 0)
3543 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3544 "attribute because it is BIND(C)", derived_sym->name,
3545 &(derived_sym->declared_at));
3549 /* Mark the derived type as not being C interoperable if we found an
3550 error. If there were only warnings, proceed with the assumption
3551 it's interoperable. */
3552 if (retval == FAILURE)
3553 derived_sym->ts.is_c_interop = 0;
3559 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3562 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3563 const char *module_name)
3565 gfc_symtree *tmp_symtree;
3566 gfc_symbol *tmp_sym;
3568 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3570 if (tmp_symtree != NULL)
3571 tmp_sym = tmp_symtree->n.sym;
3575 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3576 "create symbol for %s", ptr_name);
3579 /* Set up the symbol's important fields. Save attr required so we can
3580 initialize the ptr to NULL. */
3581 tmp_sym->attr.save = SAVE_EXPLICIT;
3582 tmp_sym->ts.is_c_interop = 1;
3583 tmp_sym->attr.is_c_interop = 1;
3584 tmp_sym->ts.is_iso_c = 1;
3585 tmp_sym->ts.type = BT_DERIVED;
3587 /* The c_ptr and c_funptr derived types will provide the
3588 definition for c_null_ptr and c_null_funptr, respectively. */
3589 if (ptr_id == ISOCBINDING_NULL_PTR)
3590 tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3592 tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3593 if (tmp_sym->ts.u.derived == NULL)
3595 /* This can occur if the user forgot to declare c_ptr or
3596 c_funptr and they're trying to use one of the procedures
3597 that has arg(s) of the missing type. In this case, a
3598 regular version of the thing should have been put in the
3600 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3601 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3602 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3603 ? "_gfortran_iso_c_binding_c_ptr"
3604 : "_gfortran_iso_c_binding_c_funptr"));
3606 tmp_sym->ts.u.derived =
3607 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3608 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3611 /* Module name is some mangled version of iso_c_binding. */
3612 tmp_sym->module = gfc_get_string (module_name);
3614 /* Say it's from the iso_c_binding module. */
3615 tmp_sym->attr.is_iso_c = 1;
3617 tmp_sym->attr.use_assoc = 1;
3618 tmp_sym->attr.is_bind_c = 1;
3619 /* Set the binding_label. */
3620 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3622 /* Set the c_address field of c_null_ptr and c_null_funptr to
3623 the value of NULL. */
3624 tmp_sym->value = gfc_get_expr ();
3625 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3626 tmp_sym->value->ts.type = BT_DERIVED;
3627 tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
3628 /* Create a constructor with no expr, that way we can recognize if the user
3629 tries to call the structure constructor for one of the iso_c_binding
3630 derived types during resolution (resolve_structure_cons). */
3631 tmp_sym->value->value.constructor = gfc_get_constructor ();
3632 /* Must declare c_null_ptr and c_null_funptr as having the
3633 PARAMETER attribute so they can be used in init expressions. */
3634 tmp_sym->attr.flavor = FL_PARAMETER;
3640 /* Add a formal argument, gfc_formal_arglist, to the
3641 end of the given list of arguments. Set the reference to the
3642 provided symbol, param_sym, in the argument. */
3645 add_formal_arg (gfc_formal_arglist **head,
3646 gfc_formal_arglist **tail,
3647 gfc_formal_arglist *formal_arg,
3648 gfc_symbol *param_sym)
3650 /* Put in list, either as first arg or at the tail (curr arg). */
3652 *head = *tail = formal_arg;
3655 (*tail)->next = formal_arg;
3656 (*tail) = formal_arg;
3659 (*tail)->sym = param_sym;
3660 (*tail)->next = NULL;
3666 /* Generates a symbol representing the CPTR argument to an
3667 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3668 CPTR and add it to the provided argument list. */
3671 gen_cptr_param (gfc_formal_arglist **head,
3672 gfc_formal_arglist **tail,
3673 const char *module_name,
3674 gfc_namespace *ns, const char *c_ptr_name,
3677 gfc_symbol *param_sym = NULL;
3678 gfc_symbol *c_ptr_sym = NULL;
3679 gfc_symtree *param_symtree = NULL;
3680 gfc_formal_arglist *formal_arg = NULL;
3681 const char *c_ptr_in;
3682 const char *c_ptr_type = NULL;
3684 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3685 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3687 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3689 if(c_ptr_name == NULL)
3690 c_ptr_in = "gfc_cptr__";
3692 c_ptr_in = c_ptr_name;
3693 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree, false);
3694 if (param_symtree != NULL)
3695 param_sym = param_symtree->n.sym;
3697 gfc_internal_error ("gen_cptr_param(): Unable to "
3698 "create symbol for %s", c_ptr_in);
3700 /* Set up the appropriate fields for the new c_ptr param sym. */
3702 param_sym->attr.flavor = FL_DERIVED;
3703 param_sym->ts.type = BT_DERIVED;
3704 param_sym->attr.intent = INTENT_IN;
3705 param_sym->attr.dummy = 1;
3707 /* This will pass the ptr to the iso_c routines as a (void *). */
3708 param_sym->attr.value = 1;
3709 param_sym->attr.use_assoc = 1;
3711 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3713 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3714 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3716 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3717 if (c_ptr_sym == NULL)
3719 /* This can happen if the user did not define c_ptr but they are
3720 trying to use one of the iso_c_binding functions that need it. */
3721 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3722 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3723 (const char *)c_ptr_type);
3725 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3726 (const char *)c_ptr_type);
3728 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3731 param_sym->ts.u.derived = c_ptr_sym;
3732 param_sym->module = gfc_get_string (module_name);
3734 /* Make new formal arg. */
3735 formal_arg = gfc_get_formal_arglist ();
3736 /* Add arg to list of formal args (the CPTR arg). */
3737 add_formal_arg (head, tail, formal_arg, param_sym);
3741 /* Generates a symbol representing the FPTR argument to an
3742 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3743 FPTR and add it to the provided argument list. */
3746 gen_fptr_param (gfc_formal_arglist **head,
3747 gfc_formal_arglist **tail,
3748 const char *module_name,
3749 gfc_namespace *ns, const char *f_ptr_name, int proc)
3751 gfc_symbol *param_sym = NULL;
3752 gfc_symtree *param_symtree = NULL;
3753 gfc_formal_arglist *formal_arg = NULL;
3754 const char *f_ptr_out = "gfc_fptr__";
3756 if (f_ptr_name != NULL)
3757 f_ptr_out = f_ptr_name;
3759 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree, false);
3760 if (param_symtree != NULL)
3761 param_sym = param_symtree->n.sym;
3763 gfc_internal_error ("generateFPtrParam(): Unable to "
3764 "create symbol for %s", f_ptr_out);
3766 /* Set up the necessary fields for the fptr output param sym. */
3769 param_sym->attr.proc_pointer = 1;
3771 param_sym->attr.pointer = 1;
3772 param_sym->attr.dummy = 1;
3773 param_sym->attr.use_assoc = 1;
3775 /* ISO C Binding type to allow any pointer type as actual param. */
3776 param_sym->ts.type = BT_VOID;
3777 param_sym->module = gfc_get_string (module_name);
3780 formal_arg = gfc_get_formal_arglist ();
3781 /* Add arg to list of formal args. */
3782 add_formal_arg (head, tail, formal_arg, param_sym);
3786 /* Generates a symbol representing the optional SHAPE argument for the
3787 iso_c_binding c_f_pointer() procedure. Also, create a
3788 gfc_formal_arglist for the SHAPE and add it to the provided
3792 gen_shape_param (gfc_formal_arglist **head,
3793 gfc_formal_arglist **tail,
3794 const char *module_name,
3795 gfc_namespace *ns, const char *shape_param_name)
3797 gfc_symbol *param_sym = NULL;
3798 gfc_symtree *param_symtree = NULL;
3799 gfc_formal_arglist *formal_arg = NULL;
3800 const char *shape_param = "gfc_shape_array__";
3803 if (shape_param_name != NULL)
3804 shape_param = shape_param_name;
3806 gfc_get_sym_tree (shape_param, ns, ¶m_symtree, false);
3807 if (param_symtree != NULL)
3808 param_sym = param_symtree->n.sym;
3810 gfc_internal_error ("generateShapeParam(): Unable to "
3811 "create symbol for %s", shape_param);
3813 /* Set up the necessary fields for the shape input param sym. */
3815 param_sym->attr.dummy = 1;
3816 param_sym->attr.use_assoc = 1;
3818 /* Integer array, rank 1, describing the shape of the object. Make it's
3819 type BT_VOID initially so we can accept any type/kind combination of
3820 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3821 of BT_INTEGER type. */
3822 param_sym->ts.type = BT_VOID;
3824 /* Initialize the kind to default integer. However, it will be overridden
3825 during resolution to match the kind of the SHAPE parameter given as
3826 the actual argument (to allow for any valid integer kind). */
3827 param_sym->ts.kind = gfc_default_integer_kind;
3828 param_sym->as = gfc_get_array_spec ();
3830 /* Clear out the dimension info for the array. */
3831 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3833 param_sym->as->lower[i] = NULL;
3834 param_sym->as->upper[i] = NULL;
3836 param_sym->as->rank = 1;
3837 param_sym->as->lower[0] = gfc_int_expr (1);
3839 /* The extent is unknown until we get it. The length give us
3840 the rank the incoming pointer. */
3841 param_sym->as->type = AS_ASSUMED_SHAPE;
3843 /* The arg is also optional; it is required iff the second arg
3844 (fptr) is to an array, otherwise, it's ignored. */
3845 param_sym->attr.optional = 1;
3846 param_sym->attr.intent = INTENT_IN;
3847 param_sym->attr.dimension = 1;
3848 param_sym->module = gfc_get_string (module_name);
3851 formal_arg = gfc_get_formal_arglist ();
3852 /* Add arg to list of formal args. */
3853 add_formal_arg (head, tail, formal_arg, param_sym);
3857 /* Add a procedure interface to the given symbol (i.e., store a
3858 reference to the list of formal arguments). */
3861 add_proc_interface (gfc_symbol *sym, ifsrc source,
3862 gfc_formal_arglist *formal)
3865 sym->formal = formal;
3866 sym->attr.if_source = source;
3870 /* Copy the formal args from an existing symbol, src, into a new
3871 symbol, dest. New formal args are created, and the description of
3872 each arg is set according to the existing ones. This function is
3873 used when creating procedure declaration variables from a procedure
3874 declaration statement (see match_proc_decl()) to create the formal
3875 args based on the args of a given named interface. */
3878 gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
3880 gfc_formal_arglist *head = NULL;
3881 gfc_formal_arglist *tail = NULL;
3882 gfc_formal_arglist *formal_arg = NULL;
3883 gfc_formal_arglist *curr_arg = NULL;
3884 gfc_formal_arglist *formal_prev = NULL;
3885 /* Save current namespace so we can change it for formal args. */
3886 gfc_namespace *parent_ns = gfc_current_ns;
3888 /* Create a new namespace, which will be the formal ns (namespace
3889 of the formal args). */
3890 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3891 gfc_current_ns->proc_name = dest;
3893 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3895 formal_arg = gfc_get_formal_arglist ();
3896 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
3898 /* May need to copy more info for the symbol. */
3899 formal_arg->sym->attr = curr_arg->sym->attr;
3900 formal_arg->sym->ts = curr_arg->sym->ts;
3901 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
3902 gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
3904 /* If this isn't the first arg, set up the next ptr. For the
3905 last arg built, the formal_arg->next will never get set to
3906 anything other than NULL. */
3907 if (formal_prev != NULL)
3908 formal_prev->next = formal_arg;
3910 formal_arg->next = NULL;
3912 formal_prev = formal_arg;
3914 /* Add arg to list of formal args. */
3915 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3918 /* Add the interface to the symbol. */
3919 add_proc_interface (dest, IFSRC_DECL, head);
3921 /* Store the formal namespace information. */
3922 if (dest->formal != NULL)
3923 /* The current ns should be that for the dest proc. */
3924 dest->formal_ns = gfc_current_ns;
3925 /* Restore the current namespace to what it was on entry. */
3926 gfc_current_ns = parent_ns;
3931 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
3933 gfc_formal_arglist *head = NULL;
3934 gfc_formal_arglist *tail = NULL;
3935 gfc_formal_arglist *formal_arg = NULL;
3936 gfc_intrinsic_arg *curr_arg = NULL;
3937 gfc_formal_arglist *formal_prev = NULL;
3938 /* Save current namespace so we can change it for formal args. */
3939 gfc_namespace *parent_ns = gfc_current_ns;
3941 /* Create a new namespace, which will be the formal ns (namespace
3942 of the formal args). */
3943 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3944 gfc_current_ns->proc_name = dest;
3946 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3948 formal_arg = gfc_get_formal_arglist ();
3949 gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
3951 /* May need to copy more info for the symbol. */
3952 formal_arg->sym->ts = curr_arg->ts;
3953 formal_arg->sym->attr.optional = curr_arg->optional;
3954 formal_arg->sym->attr.intent = curr_arg->intent;
3955 formal_arg->sym->attr.flavor = FL_VARIABLE;
3956 formal_arg->sym->attr.dummy = 1;
3958 if (formal_arg->sym->ts.type == BT_CHARACTER)
3959 formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns);
3961 /* If this isn't the first arg, set up the next ptr. For the
3962 last arg built, the formal_arg->next will never get set to
3963 anything other than NULL. */
3964 if (formal_prev != NULL)
3965 formal_prev->next = formal_arg;
3967 formal_arg->next = NULL;
3969 formal_prev = formal_arg;
3971 /* Add arg to list of formal args. */
3972 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3975 /* Add the interface to the symbol. */
3976 add_proc_interface (dest, IFSRC_DECL, head);
3978 /* Store the formal namespace information. */
3979 if (dest->formal != NULL)
3980 /* The current ns should be that for the dest proc. */
3981 dest->formal_ns = gfc_current_ns;
3982 /* Restore the current namespace to what it was on entry. */
3983 gfc_current_ns = parent_ns;
3988 gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
3990 gfc_formal_arglist *head = NULL;
3991 gfc_formal_arglist *tail = NULL;
3992 gfc_formal_arglist *formal_arg = NULL;
3993 gfc_formal_arglist *curr_arg = NULL;
3994 gfc_formal_arglist *formal_prev = NULL;
3995 /* Save current namespace so we can change it for formal args. */
3996 gfc_namespace *parent_ns = gfc_current_ns;
3998 /* Create a new namespace, which will be the formal ns (namespace
3999 of the formal args). */
4000 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4001 /* TODO: gfc_current_ns->proc_name = dest;*/
4003 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4005 formal_arg = gfc_get_formal_arglist ();
4006 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
4008 /* May need to copy more info for the symbol. */
4009 formal_arg->sym->attr = curr_arg->sym->attr;
4010 formal_arg->sym->ts = curr_arg->sym->ts;
4011 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
4012 gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
4014 /* If this isn't the first arg, set up the next ptr. For the
4015 last arg built, the formal_arg->next will never get set to
4016 anything other than NULL. */
4017 if (formal_prev != NULL)
4018 formal_prev->next = formal_arg;
4020 formal_arg->next = NULL;
4022 formal_prev = formal_arg;
4024 /* Add arg to list of formal args. */
4025 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4028 /* Add the interface to the symbol. */
4029 dest->formal = head;
4030 dest->attr.if_source = IFSRC_DECL;
4032 /* Store the formal namespace information. */
4033 if (dest->formal != NULL)
4034 /* The current ns should be that for the dest proc. */
4035 dest->formal_ns = gfc_current_ns;
4036 /* Restore the current namespace to what it was on entry. */
4037 gfc_current_ns = parent_ns;
4041 /* Builds the parameter list for the iso_c_binding procedure
4042 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
4043 generic version of either the c_f_pointer or c_f_procpointer
4044 functions. The new_proc_sym represents a "resolved" version of the
4045 symbol. The functions are resolved to match the types of their
4046 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4047 something similar to c_f_pointer_i4 if the type of data object fptr
4048 pointed to was a default integer. The actual name of the resolved
4049 procedure symbol is further mangled with the module name, etc., but
4050 the idea holds true. */
4053 build_formal_args (gfc_symbol *new_proc_sym,
4054 gfc_symbol *old_sym, int add_optional_arg)
4056 gfc_formal_arglist *head = NULL, *tail = NULL;
4057 gfc_namespace *parent_ns = NULL;
4059 parent_ns = gfc_current_ns;
4060 /* Create a new namespace, which will be the formal ns (namespace
4061 of the formal args). */
4062 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
4063 gfc_current_ns->proc_name = new_proc_sym;
4065 /* Generate the params. */
4066 if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
4068 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4069 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4070 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4071 gfc_current_ns, "fptr", 1);
4073 else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
4075 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4076 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4077 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4078 gfc_current_ns, "fptr", 0);
4079 /* If we're dealing with c_f_pointer, it has an optional third arg. */
4080 gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
4081 gfc_current_ns, "shape");
4084 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
4086 /* c_associated has one required arg and one optional; both
4088 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4089 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
4090 if (add_optional_arg)
4092 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4093 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
4094 /* The last param is optional so mark it as such. */
4095 tail->sym->attr.optional = 1;
4099 /* Add the interface (store formal args to new_proc_sym). */
4100 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
4102 /* Set up the formal_ns pointer to the one created for the
4103 new procedure so it'll get cleaned up during gfc_free_symbol(). */
4104 new_proc_sym->formal_ns = gfc_current_ns;
4106 gfc_current_ns = parent_ns;
4110 std_for_isocbinding_symbol (int id)
4114 #define NAMED_INTCST(a,b,c,d) \
4117 #include "iso-c-binding.def"
4120 return GFC_STD_F2003;
4124 /* Generate the given set of C interoperable kind objects, or all
4125 interoperable kinds. This function will only be given kind objects
4126 for valid iso_c_binding defined types because this is verified when
4127 the 'use' statement is parsed. If the user gives an 'only' clause,
4128 the specific kinds are looked up; if they don't exist, an error is
4129 reported. If the user does not give an 'only' clause, all
4130 iso_c_binding symbols are generated. If a list of specific kinds
4131 is given, it must have a NULL in the first empty spot to mark the
4136 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4137 const char *local_name)
4139 const char *const name = (local_name && local_name[0]) ? local_name
4140 : c_interop_kinds_table[s].name;
4141 gfc_symtree *tmp_symtree = NULL;
4142 gfc_symbol *tmp_sym = NULL;
4143 gfc_dt_list **dt_list_ptr = NULL;
4144 gfc_component *tmp_comp = NULL;
4145 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
4148 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4150 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4152 /* Already exists in this scope so don't re-add it.
4153 TODO: we should probably check that it's really the same symbol. */
4154 if (tmp_symtree != NULL)
4157 /* Create the sym tree in the current ns. */
4158 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4160 tmp_sym = tmp_symtree->n.sym;
4162 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4165 /* Say what module this symbol belongs to. */
4166 tmp_sym->module = gfc_get_string (mod_name);
4167 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4168 tmp_sym->intmod_sym_id = s;
4173 #define NAMED_INTCST(a,b,c,d) case a :
4174 #define NAMED_REALCST(a,b,c) case a :
4175 #define NAMED_CMPXCST(a,b,c) case a :
4176 #define NAMED_LOGCST(a,b,c) case a :
4177 #define NAMED_CHARKNDCST(a,b,c) case a :
4178 #include "iso-c-binding.def"
4180 tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
4182 /* Initialize an integer constant expression node. */
4183 tmp_sym->attr.flavor = FL_PARAMETER;
4184 tmp_sym->ts.type = BT_INTEGER;
4185 tmp_sym->ts.kind = gfc_default_integer_kind;
4187 /* Mark this type as a C interoperable one. */
4188 tmp_sym->ts.is_c_interop = 1;
4189 tmp_sym->ts.is_iso_c = 1;
4190 tmp_sym->value->ts.is_c_interop = 1;
4191 tmp_sym->value->ts.is_iso_c = 1;
4192 tmp_sym->attr.is_c_interop = 1;
4194 /* Tell what f90 type this c interop kind is valid. */
4195 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4197 /* Say it's from the iso_c_binding module. */
4198 tmp_sym->attr.is_iso_c = 1;
4200 /* Make it use associated. */
4201 tmp_sym->attr.use_assoc = 1;
4205 #define NAMED_CHARCST(a,b,c) case a :
4206 #include "iso-c-binding.def"
4208 /* Initialize an integer constant expression node for the
4209 length of the character. */
4210 tmp_sym->value = gfc_get_expr ();
4211 tmp_sym->value->expr_type = EXPR_CONSTANT;
4212 tmp_sym->value->ts.type = BT_CHARACTER;
4213 tmp_sym->value->ts.kind = gfc_default_character_kind;
4214 tmp_sym->value->where = gfc_current_locus;
4215 tmp_sym->value->ts.is_c_interop = 1;
4216 tmp_sym->value->ts.is_iso_c = 1;
4217 tmp_sym->value->value.character.length = 1;
4218 tmp_sym->value->value.character.string = gfc_get_wide_string (2);
4219 tmp_sym->value->value.character.string[0]
4220 = (gfc_char_t) c_interop_kinds_table[s].value;
4221 tmp_sym->value->value.character.string[1] = '\0';
4222 tmp_sym->ts.u.cl = gfc_get_charlen ();
4223 tmp_sym->ts.u.cl->length = gfc_int_expr (1);
4225 /* May not need this in both attr and ts, but do need in
4226 attr for writing module file. */
4227 tmp_sym->attr.is_c_interop = 1;
4229 tmp_sym->attr.flavor = FL_PARAMETER;
4230 tmp_sym->ts.type = BT_CHARACTER;
4232 /* Need to set it to the C_CHAR kind. */
4233 tmp_sym->ts.kind = gfc_default_character_kind;
4235 /* Mark this type as a C interoperable one. */
4236 tmp_sym->ts.is_c_interop = 1;
4237 tmp_sym->ts.is_iso_c = 1;
4239 /* Tell what f90 type this c interop kind is valid. */
4240 tmp_sym->ts.f90_type = BT_CHARACTER;
4242 /* Say it's from the iso_c_binding module. */
4243 tmp_sym->attr.is_iso_c = 1;
4245 /* Make it use associated. */
4246 tmp_sym->attr.use_assoc = 1;
4249 case ISOCBINDING_PTR:
4250 case ISOCBINDING_FUNPTR:
4252 /* Initialize an integer constant expression node. */
4253 tmp_sym->attr.flavor = FL_DERIVED;
4254 tmp_sym->ts.is_c_interop = 1;
4255 tmp_sym->attr.is_c_interop = 1;
4256 tmp_sym->attr.is_iso_c = 1;
4257 tmp_sym->ts.is_iso_c = 1;
4258 tmp_sym->ts.type = BT_DERIVED;
4260 /* A derived type must have the bind attribute to be
4261 interoperable (J3/04-007, Section 15.2.3), even though
4262 the binding label is not used. */
4263 tmp_sym->attr.is_bind_c = 1;
4265 tmp_sym->attr.referenced = 1;
4267 tmp_sym->ts.u.derived = tmp_sym;
4269 /* Add the symbol created for the derived type to the current ns. */
4270 dt_list_ptr = &(gfc_derived_types);
4271 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4272 dt_list_ptr = &((*dt_list_ptr)->next);
4274 /* There is already at least one derived type in the list, so append
4275 the one we're currently building for c_ptr or c_funptr. */
4276 if (*dt_list_ptr != NULL)
4277 dt_list_ptr = &((*dt_list_ptr)->next);
4278 (*dt_list_ptr) = gfc_get_dt_list ();
4279 (*dt_list_ptr)->derived = tmp_sym;
4280 (*dt_list_ptr)->next = NULL;
4282 /* Set up the component of the derived type, which will be
4283 an integer with kind equal to c_ptr_size. Mangle the name of
4284 the field for the c_address to prevent the curious user from
4285 trying to access it from Fortran. */
4286 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
4287 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
4288 if (tmp_comp == NULL)
4289 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4290 "create component for c_address");
4292 tmp_comp->ts.type = BT_INTEGER;
4294 /* Set this because the module will need to read/write this field. */
4295 tmp_comp->ts.f90_type = BT_INTEGER;
4297 /* The kinds for c_ptr and c_funptr are the same. */
4298 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4299 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4301 tmp_comp->attr.pointer = 0;
4302 tmp_comp->attr.dimension = 0;
4304 /* Mark the component as C interoperable. */
4305 tmp_comp->ts.is_c_interop = 1;
4307 /* Make it use associated (iso_c_binding module). */
4308 tmp_sym->attr.use_assoc = 1;
4311 case ISOCBINDING_NULL_PTR:
4312 case ISOCBINDING_NULL_FUNPTR:
4313 gen_special_c_interop_ptr (s, name, mod_name);
4316 case ISOCBINDING_F_POINTER:
4317 case ISOCBINDING_ASSOCIATED:
4318 case ISOCBINDING_LOC:
4319 case ISOCBINDING_FUNLOC:
4320 case ISOCBINDING_F_PROCPOINTER:
4322 tmp_sym->attr.proc = PROC_MODULE;
4324 /* Use the procedure's name as it is in the iso_c_binding module for
4325 setting the binding label in case the user renamed the symbol. */
4326 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
4327 c_interop_kinds_table[s].name);
4328 tmp_sym->attr.is_iso_c = 1;
4329 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4330 tmp_sym->attr.subroutine = 1;
4333 /* TODO! This needs to be finished more for the expr of the
4334 function or something!
4335 This may not need to be here, because trying to do c_loc
4337 if (s == ISOCBINDING_ASSOCIATED)
4339 tmp_sym->attr.function = 1;
4340 tmp_sym->ts.type = BT_LOGICAL;
4341 tmp_sym->ts.kind = gfc_default_logical_kind;
4342 tmp_sym->result = tmp_sym;
4346 /* Here, we're taking the simple approach. We're defining
4347 c_loc as an external identifier so the compiler will put
4348 what we expect on the stack for the address we want the
4350 tmp_sym->ts.type = BT_DERIVED;
4351 if (s == ISOCBINDING_LOC)
4352 tmp_sym->ts.u.derived =
4353 get_iso_c_binding_dt (ISOCBINDING_PTR);
4355 tmp_sym->ts.u.derived =
4356 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4358 if (tmp_sym->ts.u.derived == NULL)
4360 /* Create the necessary derived type so we can continue
4361 processing the file. */
4362 generate_isocbinding_symbol
4363 (mod_name, s == ISOCBINDING_FUNLOC
4364 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4365 (const char *)(s == ISOCBINDING_FUNLOC
4366 ? "_gfortran_iso_c_binding_c_funptr"
4367 : "_gfortran_iso_c_binding_c_ptr"));
4368 tmp_sym->ts.u.derived =
4369 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4370 ? ISOCBINDING_FUNPTR
4374 /* The function result is itself (no result clause). */
4375 tmp_sym->result = tmp_sym;
4376 tmp_sym->attr.external = 1;
4377 tmp_sym->attr.use_assoc = 0;
4378 tmp_sym->attr.pure = 1;
4379 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4380 tmp_sym->attr.proc = PROC_UNKNOWN;
4384 tmp_sym->attr.flavor = FL_PROCEDURE;
4385 tmp_sym->attr.contained = 0;
4387 /* Try using this builder routine, with the new and old symbols
4388 both being the generic iso_c proc sym being created. This
4389 will create the formal args (and the new namespace for them).
4390 Don't build an arg list for c_loc because we're going to treat
4391 c_loc as an external procedure. */
4392 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4393 /* The 1 says to add any optional args, if applicable. */
4394 build_formal_args (tmp_sym, tmp_sym, 1);
4396 /* Set this after setting up the symbol, to prevent error messages. */
4397 tmp_sym->attr.use_assoc = 1;
4399 /* This symbol will not be referenced directly. It will be
4400 resolved to the implementation for the given f90 kind. */
4401 tmp_sym->attr.referenced = 0;
4411 /* Creates a new symbol based off of an old iso_c symbol, with a new
4412 binding label. This function can be used to create a new,
4413 resolved, version of a procedure symbol for c_f_pointer or
4414 c_f_procpointer that is based on the generic symbols. A new
4415 parameter list is created for the new symbol using
4416 build_formal_args(). The add_optional_flag specifies whether the
4417 to add the optional SHAPE argument. The new symbol is
4421 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4422 char *new_binding_label, int add_optional_arg)
4424 gfc_symtree *new_symtree = NULL;
4426 /* See if we have a symbol by that name already available, looking
4427 through any parent namespaces. */
4428 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4429 if (new_symtree != NULL)
4430 /* Return the existing symbol. */
4431 return new_symtree->n.sym;
4433 /* Create the symtree/symbol, with attempted host association. */
4434 gfc_get_ha_sym_tree (new_name, &new_symtree);
4435 if (new_symtree == NULL)
4436 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4437 "symtree for '%s'", new_name);
4439 /* Now fill in the fields of the resolved symbol with the old sym. */
4440 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4441 new_symtree->n.sym->attr = old_sym->attr;
4442 new_symtree->n.sym->ts = old_sym->ts;
4443 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4444 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4445 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4446 /* Build the formal arg list. */
4447 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4449 gfc_commit_symbol (new_symtree->n.sym);
4451 return new_symtree->n.sym;
4455 /* Check that a symbol is already typed. If strict is not set, an untyped
4456 symbol is acceptable for non-standard-conforming mode. */
4459 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4460 bool strict, locus where)
4464 if (gfc_matching_prefix)
4467 /* Check for the type and try to give it an implicit one. */
4468 if (sym->ts.type == BT_UNKNOWN
4469 && gfc_set_default_type (sym, 0, ns) == FAILURE)
4473 gfc_error ("Symbol '%s' is used before it is typed at %L",
4478 if (gfc_notify_std (GFC_STD_GNU,
4479 "Extension: Symbol '%s' is used before"
4480 " it is typed at %L", sym->name, &where) == FAILURE)
4484 /* Everything is ok. */
4489 /* Construct a typebound-procedure structure. Those are stored in a tentative
4490 list and marked `error' until symbols are committed. */
4493 gfc_get_typebound_proc (void)
4495 gfc_typebound_proc *result;
4496 tentative_tbp *list_node;
4498 result = XCNEW (gfc_typebound_proc);
4501 list_node = XCNEW (tentative_tbp);
4502 list_node->next = tentative_tbp_list;
4503 list_node->proc = result;
4504 tentative_tbp_list = list_node;
4510 /* Get the super-type of a given derived type. */
4513 gfc_get_derived_super_type (gfc_symbol* derived)
4515 if (!derived->attr.extension)
4518 gcc_assert (derived->components);
4519 gcc_assert (derived->components->ts.type == BT_DERIVED);
4520 gcc_assert (derived->components->ts.u.derived);
4522 return derived->components->ts.u.derived;
4526 /* General worker function to find either a type-bound procedure or a
4527 type-bound user operator. */
4530 find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
4531 const char* name, bool noaccess, bool uop)
4536 /* Set correct symbol-root. */
4537 gcc_assert (derived->f2k_derived);
4538 root = (uop ? derived->f2k_derived->tb_uop_root
4539 : derived->f2k_derived->tb_sym_root);
4541 /* Set default to failure. */
4545 /* Try to find it in the current type's namespace. */
4546 res = gfc_find_symtree (root, name);
4547 if (res && res->n.tb)
4553 if (!noaccess && derived->attr.use_assoc
4554 && res->n.tb->access == ACCESS_PRIVATE)
4556 gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
4564 /* Otherwise, recurse on parent type if derived is an extension. */
4565 if (derived->attr.extension)
4567 gfc_symbol* super_type;
4568 super_type = gfc_get_derived_super_type (derived);
4569 gcc_assert (super_type);
4571 return find_typebound_proc_uop (super_type, t, name, noaccess, uop);
4574 /* Nothing found. */
4579 /* Find a type-bound procedure or user operator by name for a derived-type
4580 (looking recursively through the super-types). */
4583 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
4584 const char* name, bool noaccess)
4586 return find_typebound_proc_uop (derived, t, name, noaccess, false);
4590 gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
4591 const char* name, bool noaccess)
4593 return find_typebound_proc_uop (derived, t, name, noaccess, true);
4597 /* Find a type-bound intrinsic operator looking recursively through the
4598 super-type hierarchy. */
4601 gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
4602 gfc_intrinsic_op op, bool noaccess)
4604 gfc_typebound_proc* res;
4606 /* Set default to failure. */
4610 /* Try to find it in the current type's namespace. */
4611 if (derived->f2k_derived)
4612 res = derived->f2k_derived->tb_op[op];
4623 if (!noaccess && derived->attr.use_assoc
4624 && res->access == ACCESS_PRIVATE)
4626 gfc_error ("'%s' of '%s' is PRIVATE at %C",
4627 gfc_op2string (op), derived->name);
4635 /* Otherwise, recurse on parent type if derived is an extension. */
4636 if (derived->attr.extension)
4638 gfc_symbol* super_type;
4639 super_type = gfc_get_derived_super_type (derived);
4640 gcc_assert (super_type);
4642 return gfc_find_typebound_intrinsic_op (super_type, t, op, noaccess);
4645 /* Nothing found. */
4650 /* Get a typebound-procedure symtree or create and insert it if not yet
4651 present. This is like a very simplified version of gfc_get_sym_tree for
4652 tbp-symtrees rather than regular ones. */
4655 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
4657 gfc_symtree *result;
4659 result = gfc_find_symtree (*root, name);
4662 result = gfc_new_symtree (root, name);
4663 gcc_assert (result);
4664 result->n.tb = NULL;