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),
79 minit ("USAGE", IFSRC_USAGE)
82 const mstring save_status[] =
84 minit ("UNKNOWN", SAVE_NONE),
85 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
86 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
89 /* This is to make sure the backend generates setup code in the correct
92 static int next_dummy_order = 1;
95 gfc_namespace *gfc_current_ns;
96 gfc_namespace *gfc_global_ns_list;
98 gfc_gsymbol *gfc_gsym_root = NULL;
100 static gfc_symbol *changed_syms = NULL;
102 gfc_dt_list *gfc_derived_types;
105 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
107 /* The following static variable indicates whether a particular element has
108 been explicitly set or not. */
110 static int new_flag[GFC_LETTERS];
113 /* Handle a correctly parsed IMPLICIT NONE. */
116 gfc_set_implicit_none (void)
120 if (gfc_current_ns->seen_implicit_none)
122 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
126 gfc_current_ns->seen_implicit_none = 1;
128 for (i = 0; i < GFC_LETTERS; i++)
130 gfc_clear_ts (&gfc_current_ns->default_type[i]);
131 gfc_current_ns->set_flag[i] = 1;
136 /* Reset the implicit range flags. */
139 gfc_clear_new_implicit (void)
143 for (i = 0; i < GFC_LETTERS; i++)
148 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
151 gfc_add_new_implicit_range (int c1, int c2)
158 for (i = c1; i <= c2; i++)
162 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
174 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
175 the new implicit types back into the existing types will work. */
178 gfc_merge_new_implicit (gfc_typespec *ts)
182 if (gfc_current_ns->seen_implicit_none)
184 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
188 for (i = 0; i < GFC_LETTERS; i++)
192 if (gfc_current_ns->set_flag[i])
194 gfc_error ("Letter %c already has an IMPLICIT type at %C",
199 gfc_current_ns->default_type[i] = *ts;
200 gfc_current_ns->implicit_loc[i] = gfc_current_locus;
201 gfc_current_ns->set_flag[i] = 1;
208 /* Given a symbol, return a pointer to the typespec for its default type. */
211 gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
215 letter = sym->name[0];
217 if (gfc_option.flag_allow_leading_underscore && letter == '_')
218 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
219 "gfortran developers, and should not be used for "
220 "implicitly typed variables");
222 if (letter < 'a' || letter > 'z')
223 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'",sym->name);
228 return &ns->default_type[letter - 'a'];
232 /* Given a pointer to a symbol, set its type according to the first
233 letter of its name. Fails if the letter in question has no default
237 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
241 if (sym->ts.type != BT_UNKNOWN)
242 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
244 ts = gfc_get_default_type (sym, ns);
246 if (ts->type == BT_UNKNOWN)
248 if (error_flag && !sym->attr.untyped)
250 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
251 sym->name, &sym->declared_at);
252 sym->attr.untyped = 1; /* Ensure we only give an error once. */
259 sym->attr.implicit_type = 1;
263 sym->ts.cl = gfc_get_charlen ();
264 *sym->ts.cl = *ts->cl;
267 if (sym->attr.is_bind_c == 1)
269 /* BIND(C) variables should not be implicitly declared. */
270 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
271 "not be C interoperable", sym->name, &sym->declared_at);
272 sym->ts.f90_type = sym->ts.type;
275 if (sym->attr.dummy != 0)
277 if (sym->ns->proc_name != NULL
278 && (sym->ns->proc_name->attr.subroutine != 0
279 || sym->ns->proc_name->attr.function != 0)
280 && sym->ns->proc_name->attr.is_bind_c != 0)
282 /* Dummy args to a BIND(C) routine may not be interoperable if
283 they are implicitly typed. */
284 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
285 "be C interoperable but it is a dummy argument to "
286 "the BIND(C) procedure '%s' at %L", sym->name,
287 &(sym->declared_at), sym->ns->proc_name->name,
288 &(sym->ns->proc_name->declared_at));
289 sym->ts.f90_type = sym->ts.type;
297 /* This function is called from parse.c(parse_progunit) to check the
298 type of the function is not implicitly typed in the host namespace
299 and to implicitly type the function result, if necessary. */
302 gfc_check_function_type (gfc_namespace *ns)
304 gfc_symbol *proc = ns->proc_name;
306 if (!proc->attr.contained || proc->result->attr.implicit_type)
309 if (proc->result->ts.type == BT_UNKNOWN)
311 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
314 if (proc->result != proc)
316 proc->ts = proc->result->ts;
317 proc->as = gfc_copy_array_spec (proc->result->as);
318 proc->attr.dimension = proc->result->attr.dimension;
319 proc->attr.pointer = proc->result->attr.pointer;
320 proc->attr.allocatable = proc->result->attr.allocatable;
325 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
326 proc->result->name, &proc->result->declared_at);
327 proc->result->attr.untyped = 1;
333 /******************** Symbol attribute stuff *********************/
335 /* This is a generic conflict-checker. We do this to avoid having a
336 single conflict in two places. */
338 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
339 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
340 #define conf_std(a, b, std) if (attr->a && attr->b)\
349 check_conflict (symbol_attribute *attr, const char *name, locus *where)
351 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
352 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
353 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
354 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
355 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
356 *privat = "PRIVATE", *recursive = "RECURSIVE",
357 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
358 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
359 *function = "FUNCTION", *subroutine = "SUBROUTINE",
360 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
361 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
362 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
363 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
364 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
365 static const char *threadprivate = "THREADPRIVATE";
371 where = &gfc_current_locus;
373 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
377 standard = GFC_STD_F2003;
381 /* Check for attributes not allowed in a BLOCK DATA. */
382 if (gfc_current_state () == COMP_BLOCK_DATA)
386 if (attr->in_namelist)
388 if (attr->allocatable)
394 if (attr->access == ACCESS_PRIVATE)
396 if (attr->access == ACCESS_PUBLIC)
398 if (attr->intent != INTENT_UNKNOWN)
404 ("%s attribute not allowed in BLOCK DATA program unit at %L",
410 if (attr->save == SAVE_EXPLICIT)
413 conf (in_common, save);
416 switch (attr->flavor)
424 a1 = gfc_code2string (flavors, attr->flavor);
429 /* Conflicts between SAVE and PROCEDURE will be checked at
430 resolution stage, see "resolve_fl_procedure". */
439 conf (dummy, intrinsic);
440 conf (dummy, threadprivate);
441 conf (pointer, target);
442 conf (pointer, intrinsic);
443 conf (pointer, elemental);
444 conf (allocatable, elemental);
446 conf (target, external);
447 conf (target, intrinsic);
449 if (!attr->if_source)
450 conf (external, dimension); /* See Fortran 95's R504. */
452 conf (external, intrinsic);
453 conf (entry, intrinsic);
455 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
457 conf (external, subroutine);
458 conf (external, function);
461 conf (allocatable, pointer);
462 conf_std (allocatable, dummy, GFC_STD_F2003);
463 conf_std (allocatable, function, GFC_STD_F2003);
464 conf_std (allocatable, result, GFC_STD_F2003);
465 conf (elemental, recursive);
467 conf (in_common, dummy);
468 conf (in_common, allocatable);
469 conf (in_common, result);
471 conf (dummy, result);
473 conf (in_equivalence, use_assoc);
474 conf (in_equivalence, dummy);
475 conf (in_equivalence, target);
476 conf (in_equivalence, pointer);
477 conf (in_equivalence, function);
478 conf (in_equivalence, result);
479 conf (in_equivalence, entry);
480 conf (in_equivalence, allocatable);
481 conf (in_equivalence, threadprivate);
483 conf (in_namelist, pointer);
484 conf (in_namelist, allocatable);
486 conf (entry, result);
488 conf (function, subroutine);
490 if (!function && !subroutine)
491 conf (is_bind_c, dummy);
493 conf (is_bind_c, cray_pointer);
494 conf (is_bind_c, cray_pointee);
495 conf (is_bind_c, allocatable);
496 conf (is_bind_c, elemental);
498 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
499 Parameter conflict caught below. Also, value cannot be specified
500 for a dummy procedure. */
502 /* Cray pointer/pointee conflicts. */
503 conf (cray_pointer, cray_pointee);
504 conf (cray_pointer, dimension);
505 conf (cray_pointer, pointer);
506 conf (cray_pointer, target);
507 conf (cray_pointer, allocatable);
508 conf (cray_pointer, external);
509 conf (cray_pointer, intrinsic);
510 conf (cray_pointer, in_namelist);
511 conf (cray_pointer, function);
512 conf (cray_pointer, subroutine);
513 conf (cray_pointer, entry);
515 conf (cray_pointee, allocatable);
516 conf (cray_pointee, intent);
517 conf (cray_pointee, optional);
518 conf (cray_pointee, dummy);
519 conf (cray_pointee, target);
520 conf (cray_pointee, intrinsic);
521 conf (cray_pointee, pointer);
522 conf (cray_pointee, entry);
523 conf (cray_pointee, in_common);
524 conf (cray_pointee, in_equivalence);
525 conf (cray_pointee, threadprivate);
528 conf (data, function);
530 conf (data, allocatable);
531 conf (data, use_assoc);
533 conf (value, pointer)
534 conf (value, allocatable)
535 conf (value, subroutine)
536 conf (value, function)
537 conf (value, volatile_)
538 conf (value, dimension)
539 conf (value, external)
542 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
545 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
549 conf (is_protected, intrinsic)
550 conf (is_protected, external)
551 conf (is_protected, in_common)
553 conf (volatile_, intrinsic)
554 conf (volatile_, external)
556 if (attr->volatile_ && attr->intent == INTENT_IN)
563 conf (procedure, allocatable)
564 conf (procedure, dimension)
565 conf (procedure, intrinsic)
566 conf (procedure, is_protected)
567 conf (procedure, target)
568 conf (procedure, value)
569 conf (procedure, volatile_)
570 conf (procedure, entry)
572 a1 = gfc_code2string (flavors, attr->flavor);
574 if (attr->in_namelist
575 && attr->flavor != FL_VARIABLE
576 && attr->flavor != FL_PROCEDURE
577 && attr->flavor != FL_UNKNOWN)
583 switch (attr->flavor)
593 conf2 (is_protected);
603 conf2 (threadprivate);
605 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
607 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
608 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
615 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
629 /* Conflicts with INTENT will be checked at resolution stage,
630 see "resolve_fl_procedure". */
632 if (attr->subroutine)
640 conf2 (threadprivate);
643 if (!attr->proc_pointer)
648 case PROC_ST_FUNCTION:
658 conf2 (threadprivate);
678 conf2 (threadprivate);
681 if (attr->intent != INTENT_UNKNOWN)
697 conf2 (is_protected);
703 conf2 (threadprivate);
717 gfc_error ("%s attribute conflicts with %s attribute at %L",
720 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
721 a1, a2, name, where);
728 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
729 "with %s attribute at %L", a1, a2,
734 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
735 "with %s attribute in '%s' at %L",
736 a1, a2, name, where);
745 /* Mark a symbol as referenced. */
748 gfc_set_sym_referenced (gfc_symbol *sym)
751 if (sym->attr.referenced)
754 sym->attr.referenced = 1;
756 /* Remember which order dummy variables are accessed in. */
758 sym->dummy_order = next_dummy_order++;
762 /* Common subroutine called by attribute changing subroutines in order
763 to prevent them from changing a symbol that has been
764 use-associated. Returns zero if it is OK to change the symbol,
768 check_used (symbol_attribute *attr, const char *name, locus *where)
771 if (attr->use_assoc == 0)
775 where = &gfc_current_locus;
778 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
781 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
788 /* Generate an error because of a duplicate attribute. */
791 duplicate_attr (const char *attr, locus *where)
795 where = &gfc_current_locus;
797 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
801 /* Called from decl.c (attr_decl1) to check attributes, when declared
805 gfc_add_attribute (symbol_attribute *attr, locus *where)
808 if (check_used (attr, NULL, where))
811 return check_conflict (attr, NULL, where);
815 gfc_add_allocatable (symbol_attribute *attr, locus *where)
818 if (check_used (attr, NULL, where))
821 if (attr->allocatable)
823 duplicate_attr ("ALLOCATABLE", where);
827 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
828 && gfc_find_state (COMP_INTERFACE) == FAILURE)
830 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
835 attr->allocatable = 1;
836 return check_conflict (attr, NULL, where);
841 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
844 if (check_used (attr, name, where))
849 duplicate_attr ("DIMENSION", where);
853 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
854 && gfc_find_state (COMP_INTERFACE) == FAILURE)
856 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
857 "at %L", name, where);
862 return check_conflict (attr, name, where);
867 gfc_add_external (symbol_attribute *attr, locus *where)
870 if (check_used (attr, NULL, where))
875 duplicate_attr ("EXTERNAL", where);
879 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
882 attr->proc_pointer = 1;
887 return check_conflict (attr, NULL, where);
892 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
895 if (check_used (attr, NULL, where))
900 duplicate_attr ("INTRINSIC", where);
906 return check_conflict (attr, NULL, where);
911 gfc_add_optional (symbol_attribute *attr, locus *where)
914 if (check_used (attr, NULL, where))
919 duplicate_attr ("OPTIONAL", where);
924 return check_conflict (attr, NULL, where);
929 gfc_add_pointer (symbol_attribute *attr, locus *where)
932 if (check_used (attr, NULL, where))
935 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
936 && gfc_find_state (COMP_INTERFACE) == FAILURE))
938 duplicate_attr ("POINTER", where);
942 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
943 || (attr->if_source == IFSRC_IFBODY
944 && gfc_find_state (COMP_INTERFACE) == FAILURE))
945 attr->proc_pointer = 1;
949 return check_conflict (attr, NULL, where);
954 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
957 if (check_used (attr, NULL, where))
960 attr->cray_pointer = 1;
961 return check_conflict (attr, NULL, where);
966 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
969 if (check_used (attr, NULL, where))
972 if (attr->cray_pointee)
974 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
975 " statements", where);
979 attr->cray_pointee = 1;
980 return check_conflict (attr, NULL, where);
985 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
987 if (check_used (attr, name, where))
990 if (attr->is_protected)
992 if (gfc_notify_std (GFC_STD_LEGACY,
993 "Duplicate PROTECTED attribute specified at %L",
999 attr->is_protected = 1;
1000 return check_conflict (attr, name, where);
1005 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1008 if (check_used (attr, name, where))
1012 return check_conflict (attr, name, where);
1017 gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
1020 if (check_used (attr, name, where))
1023 if (gfc_pure (NULL))
1026 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1031 if (attr->save == SAVE_EXPLICIT)
1033 if (gfc_notify_std (GFC_STD_LEGACY,
1034 "Duplicate SAVE attribute specified at %L",
1040 attr->save = SAVE_EXPLICIT;
1041 return check_conflict (attr, name, where);
1046 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1049 if (check_used (attr, name, where))
1054 if (gfc_notify_std (GFC_STD_LEGACY,
1055 "Duplicate VALUE attribute specified at %L",
1062 return check_conflict (attr, name, where);
1067 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1069 /* No check_used needed as 11.2.1 of the F2003 standard allows
1070 that the local identifier made accessible by a use statement can be
1071 given a VOLATILE attribute. */
1073 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1074 if (gfc_notify_std (GFC_STD_LEGACY,
1075 "Duplicate VOLATILE attribute specified at %L", where)
1079 attr->volatile_ = 1;
1080 attr->volatile_ns = gfc_current_ns;
1081 return check_conflict (attr, name, where);
1086 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1089 if (check_used (attr, name, where))
1092 if (attr->threadprivate)
1094 duplicate_attr ("THREADPRIVATE", where);
1098 attr->threadprivate = 1;
1099 return check_conflict (attr, name, where);
1104 gfc_add_target (symbol_attribute *attr, locus *where)
1107 if (check_used (attr, NULL, where))
1112 duplicate_attr ("TARGET", where);
1117 return check_conflict (attr, NULL, where);
1122 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1125 if (check_used (attr, name, where))
1128 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1130 return check_conflict (attr, name, where);
1135 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1138 if (check_used (attr, name, where))
1141 /* Duplicate attribute already checked for. */
1142 attr->in_common = 1;
1143 return check_conflict (attr, name, where);
1148 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1151 /* Duplicate attribute already checked for. */
1152 attr->in_equivalence = 1;
1153 if (check_conflict (attr, name, where) == FAILURE)
1156 if (attr->flavor == FL_VARIABLE)
1159 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1164 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1167 if (check_used (attr, name, where))
1171 return check_conflict (attr, name, where);
1176 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1179 attr->in_namelist = 1;
1180 return check_conflict (attr, name, where);
1185 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1188 if (check_used (attr, name, where))
1192 return check_conflict (attr, name, where);
1197 gfc_add_elemental (symbol_attribute *attr, locus *where)
1200 if (check_used (attr, NULL, where))
1203 if (attr->elemental)
1205 duplicate_attr ("ELEMENTAL", where);
1209 attr->elemental = 1;
1210 return check_conflict (attr, NULL, where);
1215 gfc_add_pure (symbol_attribute *attr, locus *where)
1218 if (check_used (attr, NULL, where))
1223 duplicate_attr ("PURE", where);
1228 return check_conflict (attr, NULL, where);
1233 gfc_add_recursive (symbol_attribute *attr, locus *where)
1236 if (check_used (attr, NULL, where))
1239 if (attr->recursive)
1241 duplicate_attr ("RECURSIVE", where);
1245 attr->recursive = 1;
1246 return check_conflict (attr, NULL, where);
1251 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1254 if (check_used (attr, name, where))
1259 duplicate_attr ("ENTRY", where);
1264 return check_conflict (attr, name, where);
1269 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1272 if (attr->flavor != FL_PROCEDURE
1273 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1277 return check_conflict (attr, name, where);
1282 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1285 if (attr->flavor != FL_PROCEDURE
1286 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1289 attr->subroutine = 1;
1290 return check_conflict (attr, name, where);
1295 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1298 if (attr->flavor != FL_PROCEDURE
1299 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1303 return check_conflict (attr, name, where);
1308 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1311 if (check_used (attr, NULL, where))
1314 if (attr->flavor != FL_PROCEDURE
1315 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1318 if (attr->procedure)
1320 duplicate_attr ("PROCEDURE", where);
1324 attr->procedure = 1;
1326 return check_conflict (attr, NULL, where);
1331 gfc_add_abstract (symbol_attribute* attr, locus* where)
1335 duplicate_attr ("ABSTRACT", where);
1344 /* Flavors are special because some flavors are not what Fortran
1345 considers attributes and can be reaffirmed multiple times. */
1348 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1352 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1353 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1354 || f == FL_NAMELIST) && check_used (attr, name, where))
1357 if (attr->flavor == f && f == FL_VARIABLE)
1360 if (attr->flavor != FL_UNKNOWN)
1363 where = &gfc_current_locus;
1366 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1367 gfc_code2string (flavors, attr->flavor), name,
1368 gfc_code2string (flavors, f), where);
1370 gfc_error ("%s attribute conflicts with %s attribute at %L",
1371 gfc_code2string (flavors, attr->flavor),
1372 gfc_code2string (flavors, f), where);
1379 return check_conflict (attr, name, where);
1384 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1385 const char *name, locus *where)
1388 if (check_used (attr, name, where))
1391 if (attr->flavor != FL_PROCEDURE
1392 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1396 where = &gfc_current_locus;
1398 if (attr->proc != PROC_UNKNOWN)
1400 gfc_error ("%s procedure at %L is already declared as %s procedure",
1401 gfc_code2string (procedures, t), where,
1402 gfc_code2string (procedures, attr->proc));
1409 /* Statement functions are always scalar and functions. */
1410 if (t == PROC_ST_FUNCTION
1411 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1412 || attr->dimension))
1415 return check_conflict (attr, name, where);
1420 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1423 if (check_used (attr, NULL, where))
1426 if (attr->intent == INTENT_UNKNOWN)
1428 attr->intent = intent;
1429 return check_conflict (attr, NULL, where);
1433 where = &gfc_current_locus;
1435 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1436 gfc_intent_string (attr->intent),
1437 gfc_intent_string (intent), where);
1443 /* No checks for use-association in public and private statements. */
1446 gfc_add_access (symbol_attribute *attr, gfc_access access,
1447 const char *name, locus *where)
1450 if (attr->access == ACCESS_UNKNOWN
1451 || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1453 attr->access = access;
1454 return check_conflict (attr, name, where);
1458 where = &gfc_current_locus;
1459 gfc_error ("ACCESS specification at %L was already specified", where);
1465 /* Set the is_bind_c field for the given symbol_attribute. */
1468 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1469 int is_proc_lang_bind_spec)
1472 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1473 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1474 "variables or common blocks", where);
1475 else if (attr->is_bind_c)
1476 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1478 attr->is_bind_c = 1;
1481 where = &gfc_current_locus;
1483 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1487 return check_conflict (attr, name, where);
1491 /* Set the extension field for the given symbol_attribute. */
1494 gfc_add_extension (symbol_attribute *attr, locus *where)
1497 where = &gfc_current_locus;
1499 if (attr->extension)
1500 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1502 attr->extension = 1;
1504 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
1513 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1514 gfc_formal_arglist * formal, locus *where)
1517 if (check_used (&sym->attr, sym->name, where))
1521 where = &gfc_current_locus;
1523 if (sym->attr.if_source != IFSRC_UNKNOWN
1524 && sym->attr.if_source != IFSRC_DECL)
1526 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1531 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1533 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1534 "body", sym->name, where);
1538 sym->formal = formal;
1539 sym->attr.if_source = source;
1545 /* Add a type to a symbol. */
1548 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1553 where = &gfc_current_locus;
1555 if (sym->ts.type != BT_UNKNOWN)
1557 const char *msg = "Symbol '%s' at %L already has basic type of %s";
1558 if (!(sym->ts.type == ts->type && sym->attr.result)
1559 || gfc_notification_std (GFC_STD_GNU) == ERROR
1562 gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1565 if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
1566 gfc_basic_typename (sym->ts.type)) == FAILURE)
1568 if (gfc_option.warn_surprising)
1569 gfc_warning (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1572 if (sym->attr.procedure && sym->ts.interface)
1574 gfc_error ("Procedure '%s' at %L may not have basic type of %s", sym->name, where,
1575 gfc_basic_typename (ts->type));
1579 flavor = sym->attr.flavor;
1581 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1582 || flavor == FL_LABEL
1583 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1584 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1586 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1595 /* Clears all attributes. */
1598 gfc_clear_attr (symbol_attribute *attr)
1600 memset (attr, 0, sizeof (symbol_attribute));
1604 /* Check for missing attributes in the new symbol. Currently does
1605 nothing, but it's not clear that it is unnecessary yet. */
1608 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1609 locus *where ATTRIBUTE_UNUSED)
1616 /* Copy an attribute to a symbol attribute, bit by bit. Some
1617 attributes have a lot of side-effects but cannot be present given
1618 where we are called from, so we ignore some bits. */
1621 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1623 int is_proc_lang_bind_spec;
1625 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1628 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1630 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1632 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1634 if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1636 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1638 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1640 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1642 if (src->threadprivate
1643 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1645 if (src->target && gfc_add_target (dest, where) == FAILURE)
1647 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1649 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1654 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1657 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1660 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1662 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1664 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1667 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1669 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1671 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1673 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1676 if (src->flavor != FL_UNKNOWN
1677 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1680 if (src->intent != INTENT_UNKNOWN
1681 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1684 if (src->access != ACCESS_UNKNOWN
1685 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1688 if (gfc_missing_attr (dest, where) == FAILURE)
1691 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1693 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1696 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1698 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1702 if (src->is_c_interop)
1703 dest->is_c_interop = 1;
1707 if (src->external && gfc_add_external (dest, where) == FAILURE)
1709 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1711 if (src->proc_pointer)
1712 dest->proc_pointer = 1;
1721 /************** Component name management ************/
1723 /* Component names of a derived type form their own little namespaces
1724 that are separate from all other spaces. The space is composed of
1725 a singly linked list of gfc_component structures whose head is
1726 located in the parent symbol. */
1729 /* Add a component name to a symbol. The call fails if the name is
1730 already present. On success, the component pointer is modified to
1731 point to the additional component structure. */
1734 gfc_add_component (gfc_symbol *sym, const char *name,
1735 gfc_component **component)
1737 gfc_component *p, *tail;
1741 for (p = sym->components; p; p = p->next)
1743 if (strcmp (p->name, name) == 0)
1745 gfc_error ("Component '%s' at %C already declared at %L",
1753 if (sym->attr.extension
1754 && gfc_find_component (sym->components->ts.derived, name, true, true))
1756 gfc_error ("Component '%s' at %C already in the parent type "
1757 "at %L", name, &sym->components->ts.derived->declared_at);
1761 /* Allocate a new component. */
1762 p = gfc_get_component ();
1765 sym->components = p;
1769 p->name = gfc_get_string (name);
1770 p->loc = gfc_current_locus;
1777 /* Recursive function to switch derived types of all symbol in a
1781 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1789 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1790 sym->ts.derived = to;
1792 switch_types (st->left, from, to);
1793 switch_types (st->right, from, to);
1797 /* This subroutine is called when a derived type is used in order to
1798 make the final determination about which version to use. The
1799 standard requires that a type be defined before it is 'used', but
1800 such types can appear in IMPLICIT statements before the actual
1801 definition. 'Using' in this context means declaring a variable to
1802 be that type or using the type constructor.
1804 If a type is used and the components haven't been defined, then we
1805 have to have a derived type in a parent unit. We find the node in
1806 the other namespace and point the symtree node in this namespace to
1807 that node. Further reference to this name point to the correct
1808 node. If we can't find the node in a parent namespace, then we have
1811 This subroutine takes a pointer to a symbol node and returns a
1812 pointer to the translated node or NULL for an error. Usually there
1813 is no translation and we return the node we were passed. */
1816 gfc_use_derived (gfc_symbol *sym)
1823 if (sym->components != NULL || sym->attr.zero_comp)
1824 return sym; /* Already defined. */
1826 if (sym->ns->parent == NULL)
1829 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1831 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1835 if (s == NULL || s->attr.flavor != FL_DERIVED)
1838 /* Get rid of symbol sym, translating all references to s. */
1839 for (i = 0; i < GFC_LETTERS; i++)
1841 t = &sym->ns->default_type[i];
1842 if (t->derived == sym)
1846 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1851 /* Unlink from list of modified symbols. */
1852 gfc_commit_symbol (sym);
1854 switch_types (sym->ns->sym_root, sym, s);
1856 /* TODO: Also have to replace sym -> s in other lists like
1857 namelists, common lists and interface lists. */
1858 gfc_free_symbol (sym);
1863 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1869 /* Given a derived type node and a component name, try to locate the
1870 component structure. Returns the NULL pointer if the component is
1871 not found or the components are private. If noaccess is set, no access
1875 gfc_find_component (gfc_symbol *sym, const char *name,
1876 bool noaccess, bool silent)
1883 sym = gfc_use_derived (sym);
1888 for (p = sym->components; p; p = p->next)
1889 if (strcmp (p->name, name) == 0)
1893 && sym->attr.extension
1894 && sym->components->ts.type == BT_DERIVED)
1896 p = gfc_find_component (sym->components->ts.derived, name,
1898 /* Do not overwrite the error. */
1903 if (p == NULL && !silent)
1904 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1907 else if (sym->attr.use_assoc && !noaccess)
1909 if (p->attr.access == ACCESS_PRIVATE)
1912 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1917 /* If there were components given and all components are private, error
1918 out at this place. */
1919 if (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
1922 gfc_error ("All components of '%s' are PRIVATE in structure"
1923 " constructor at %C", sym->name);
1932 /* Given a symbol, free all of the component structures and everything
1936 free_components (gfc_component *p)
1944 gfc_free_array_spec (p->as);
1945 gfc_free_expr (p->initializer);
1952 /******************** Statement label management ********************/
1954 /* Comparison function for statement labels, used for managing the
1958 compare_st_labels (void *a1, void *b1)
1960 int a = ((gfc_st_label *) a1)->value;
1961 int b = ((gfc_st_label *) b1)->value;
1967 /* Free a single gfc_st_label structure, making sure the tree is not
1968 messed up. This function is called only when some parse error
1972 gfc_free_st_label (gfc_st_label *label)
1978 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
1980 if (label->format != NULL)
1981 gfc_free_expr (label->format);
1987 /* Free a whole tree of gfc_st_label structures. */
1990 free_st_labels (gfc_st_label *label)
1996 free_st_labels (label->left);
1997 free_st_labels (label->right);
1999 if (label->format != NULL)
2000 gfc_free_expr (label->format);
2005 /* Given a label number, search for and return a pointer to the label
2006 structure, creating it if it does not exist. */
2009 gfc_get_st_label (int labelno)
2013 /* First see if the label is already in this namespace. */
2014 lp = gfc_current_ns->st_labels;
2017 if (lp->value == labelno)
2020 if (lp->value < labelno)
2026 lp = XCNEW (gfc_st_label);
2028 lp->value = labelno;
2029 lp->defined = ST_LABEL_UNKNOWN;
2030 lp->referenced = ST_LABEL_UNKNOWN;
2032 gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
2038 /* Called when a statement with a statement label is about to be
2039 accepted. We add the label to the list of the current namespace,
2040 making sure it hasn't been defined previously and referenced
2044 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2048 labelno = lp->value;
2050 if (lp->defined != ST_LABEL_UNKNOWN)
2051 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2052 &lp->where, label_locus);
2055 lp->where = *label_locus;
2059 case ST_LABEL_FORMAT:
2060 if (lp->referenced == ST_LABEL_TARGET)
2061 gfc_error ("Label %d at %C already referenced as branch target",
2064 lp->defined = ST_LABEL_FORMAT;
2068 case ST_LABEL_TARGET:
2069 if (lp->referenced == ST_LABEL_FORMAT)
2070 gfc_error ("Label %d at %C already referenced as a format label",
2073 lp->defined = ST_LABEL_TARGET;
2078 lp->defined = ST_LABEL_BAD_TARGET;
2079 lp->referenced = ST_LABEL_BAD_TARGET;
2085 /* Reference a label. Given a label and its type, see if that
2086 reference is consistent with what is known about that label,
2087 updating the unknown state. Returns FAILURE if something goes
2091 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2093 gfc_sl_type label_type;
2100 labelno = lp->value;
2102 if (lp->defined != ST_LABEL_UNKNOWN)
2103 label_type = lp->defined;
2106 label_type = lp->referenced;
2107 lp->where = gfc_current_locus;
2110 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2112 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2117 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2118 && type == ST_LABEL_FORMAT)
2120 gfc_error ("Label %d at %C previously used as branch target", labelno);
2125 lp->referenced = type;
2133 /*******A helper function for creating new expressions*************/
2137 gfc_lval_expr_from_sym (gfc_symbol *sym)
2140 lval = gfc_get_expr ();
2141 lval->expr_type = EXPR_VARIABLE;
2142 lval->where = sym->declared_at;
2144 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2146 /* It will always be a full array. */
2147 lval->rank = sym->as ? sym->as->rank : 0;
2150 lval->ref = gfc_get_ref ();
2151 lval->ref->type = REF_ARRAY;
2152 lval->ref->u.ar.type = AR_FULL;
2153 lval->ref->u.ar.dimen = lval->rank;
2154 lval->ref->u.ar.where = sym->declared_at;
2155 lval->ref->u.ar.as = sym->as;
2162 /************** Symbol table management subroutines ****************/
2164 /* Basic details: Fortran 95 requires a potentially unlimited number
2165 of distinct namespaces when compiling a program unit. This case
2166 occurs during a compilation of internal subprograms because all of
2167 the internal subprograms must be read before we can start
2168 generating code for the host.
2170 Given the tricky nature of the Fortran grammar, we must be able to
2171 undo changes made to a symbol table if the current interpretation
2172 of a statement is found to be incorrect. Whenever a symbol is
2173 looked up, we make a copy of it and link to it. All of these
2174 symbols are kept in a singly linked list so that we can commit or
2175 undo the changes at a later time.
2177 A symtree may point to a symbol node outside of its namespace. In
2178 this case, that symbol has been used as a host associated variable
2179 at some previous time. */
2181 /* Allocate a new namespace structure. Copies the implicit types from
2182 PARENT if PARENT_TYPES is set. */
2185 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2189 gfc_intrinsic_op in;
2192 ns = XCNEW (gfc_namespace);
2193 ns->sym_root = NULL;
2194 ns->uop_root = NULL;
2195 ns->finalizers = NULL;
2196 ns->default_access = ACCESS_UNKNOWN;
2197 ns->parent = parent;
2199 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2200 ns->operator_access[in] = ACCESS_UNKNOWN;
2202 /* Initialize default implicit types. */
2203 for (i = 'a'; i <= 'z'; i++)
2205 ns->set_flag[i - 'a'] = 0;
2206 ts = &ns->default_type[i - 'a'];
2208 if (parent_types && ns->parent != NULL)
2210 /* Copy parent settings. */
2211 *ts = ns->parent->default_type[i - 'a'];
2215 if (gfc_option.flag_implicit_none != 0)
2221 if ('i' <= i && i <= 'n')
2223 ts->type = BT_INTEGER;
2224 ts->kind = gfc_default_integer_kind;
2229 ts->kind = gfc_default_real_kind;
2239 /* Comparison function for symtree nodes. */
2242 compare_symtree (void *_st1, void *_st2)
2244 gfc_symtree *st1, *st2;
2246 st1 = (gfc_symtree *) _st1;
2247 st2 = (gfc_symtree *) _st2;
2249 return strcmp (st1->name, st2->name);
2253 /* Allocate a new symtree node and associate it with the new symbol. */
2256 gfc_new_symtree (gfc_symtree **root, const char *name)
2260 st = XCNEW (gfc_symtree);
2261 st->name = gfc_get_string (name);
2262 st->typebound = NULL;
2264 gfc_insert_bbt (root, st, compare_symtree);
2269 /* Delete a symbol from the tree. Does not free the symbol itself! */
2272 gfc_delete_symtree (gfc_symtree **root, const char *name)
2274 gfc_symtree st, *st0;
2276 st0 = gfc_find_symtree (*root, name);
2278 st.name = gfc_get_string (name);
2279 gfc_delete_bbt (root, &st, compare_symtree);
2285 /* Given a root symtree node and a name, try to find the symbol within
2286 the namespace. Returns NULL if the symbol is not found. */
2289 gfc_find_symtree (gfc_symtree *st, const char *name)
2295 c = strcmp (name, st->name);
2299 st = (c < 0) ? st->left : st->right;
2306 /* Return a symtree node with a name that is guaranteed to be unique
2307 within the namespace and corresponds to an illegal fortran name. */
2310 gfc_get_unique_symtree (gfc_namespace *ns)
2312 char name[GFC_MAX_SYMBOL_LEN + 1];
2313 static int serial = 0;
2315 sprintf (name, "@%d", serial++);
2316 return gfc_new_symtree (&ns->sym_root, name);
2320 /* Given a name find a user operator node, creating it if it doesn't
2321 exist. These are much simpler than symbols because they can't be
2322 ambiguous with one another. */
2325 gfc_get_uop (const char *name)
2330 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2334 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2336 uop = st->n.uop = XCNEW (gfc_user_op);
2337 uop->name = gfc_get_string (name);
2338 uop->access = ACCESS_UNKNOWN;
2339 uop->ns = gfc_current_ns;
2345 /* Given a name find the user operator node. Returns NULL if it does
2349 gfc_find_uop (const char *name, gfc_namespace *ns)
2354 ns = gfc_current_ns;
2356 st = gfc_find_symtree (ns->uop_root, name);
2357 return (st == NULL) ? NULL : st->n.uop;
2361 /* Remove a gfc_symbol structure and everything it points to. */
2364 gfc_free_symbol (gfc_symbol *sym)
2370 gfc_free_array_spec (sym->as);
2372 free_components (sym->components);
2374 gfc_free_expr (sym->value);
2376 gfc_free_namelist (sym->namelist);
2378 gfc_free_namespace (sym->formal_ns);
2380 if (!sym->attr.generic_copy)
2381 gfc_free_interface (sym->generic);
2383 gfc_free_formal_arglist (sym->formal);
2385 gfc_free_namespace (sym->f2k_derived);
2391 /* Allocate and initialize a new symbol node. */
2394 gfc_new_symbol (const char *name, gfc_namespace *ns)
2398 p = XCNEW (gfc_symbol);
2400 gfc_clear_ts (&p->ts);
2401 gfc_clear_attr (&p->attr);
2404 p->declared_at = gfc_current_locus;
2406 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2407 gfc_internal_error ("new_symbol(): Symbol name too long");
2409 p->name = gfc_get_string (name);
2411 /* Make sure flags for symbol being C bound are clear initially. */
2412 p->attr.is_bind_c = 0;
2413 p->attr.is_iso_c = 0;
2414 /* Make sure the binding label field has a Nul char to start. */
2415 p->binding_label[0] = '\0';
2417 /* Clear the ptrs we may need. */
2418 p->common_block = NULL;
2419 p->f2k_derived = NULL;
2425 /* Generate an error if a symbol is ambiguous. */
2428 ambiguous_symbol (const char *name, gfc_symtree *st)
2431 if (st->n.sym->module)
2432 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2433 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2435 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2436 "from current program unit", name, st->n.sym->name);
2440 /* Search for a symtree starting in the current namespace, resorting to
2441 any parent namespaces if requested by a nonzero parent_flag.
2442 Returns nonzero if the name is ambiguous. */
2445 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2446 gfc_symtree **result)
2451 ns = gfc_current_ns;
2455 st = gfc_find_symtree (ns->sym_root, name);
2459 /* Ambiguous generic interfaces are permitted, as long
2460 as the specific interfaces are different. */
2461 if (st->ambiguous && !st->n.sym->attr.generic)
2463 ambiguous_symbol (name, st);
2482 /* Same, but returns the symbol instead. */
2485 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2486 gfc_symbol **result)
2491 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2496 *result = st->n.sym;
2502 /* Save symbol with the information necessary to back it out. */
2505 save_symbol_data (gfc_symbol *sym)
2508 if (sym->gfc_new || sym->old_symbol != NULL)
2511 sym->old_symbol = XCNEW (gfc_symbol);
2512 *(sym->old_symbol) = *sym;
2514 sym->tlink = changed_syms;
2519 /* Given a name, find a symbol, or create it if it does not exist yet
2520 in the current namespace. If the symbol is found we make sure that
2523 The integer return code indicates
2525 1 The symbol name was ambiguous
2526 2 The name meant to be established was already host associated.
2528 So if the return value is nonzero, then an error was issued. */
2531 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
2536 /* This doesn't usually happen during resolution. */
2538 ns = gfc_current_ns;
2540 /* Try to find the symbol in ns. */
2541 st = gfc_find_symtree (ns->sym_root, name);
2545 /* If not there, create a new symbol. */
2546 p = gfc_new_symbol (name, ns);
2548 /* Add to the list of tentative symbols. */
2549 p->old_symbol = NULL;
2550 p->tlink = changed_syms;
2555 st = gfc_new_symtree (&ns->sym_root, name);
2562 /* Make sure the existing symbol is OK. Ambiguous
2563 generic interfaces are permitted, as long as the
2564 specific interfaces are different. */
2565 if (st->ambiguous && !st->n.sym->attr.generic)
2567 ambiguous_symbol (name, st);
2573 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2575 && ns->proc_name->attr.if_source == IFSRC_IFBODY
2576 && (ns->has_import_set || p->attr.imported)))
2578 /* Symbol is from another namespace. */
2579 gfc_error ("Symbol '%s' at %C has already been host associated",
2586 /* Copy in case this symbol is changed. */
2587 save_symbol_data (p);
2596 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2601 i = gfc_get_sym_tree (name, ns, &st);
2606 *result = st->n.sym;
2613 /* Subroutine that searches for a symbol, creating it if it doesn't
2614 exist, but tries to host-associate the symbol if possible. */
2617 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2622 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2625 save_symbol_data (st->n.sym);
2630 if (gfc_current_ns->parent != NULL)
2632 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2643 return gfc_get_sym_tree (name, gfc_current_ns, result);
2648 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2653 i = gfc_get_ha_sym_tree (name, &st);
2656 *result = st->n.sym;
2663 /* Return true if both symbols could refer to the same data object. Does
2664 not take account of aliasing due to equivalence statements. */
2667 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2669 /* Aliasing isn't possible if the symbols have different base types. */
2670 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2673 /* Pointers can point to other pointers, target objects and allocatable
2674 objects. Two allocatable objects cannot share the same storage. */
2675 if (lsym->attr.pointer
2676 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2678 if (lsym->attr.target && rsym->attr.pointer)
2680 if (lsym->attr.allocatable && rsym->attr.pointer)
2687 /* Undoes all the changes made to symbols in the current statement.
2688 This subroutine is made simpler due to the fact that attributes are
2689 never removed once added. */
2692 gfc_undo_symbols (void)
2694 gfc_symbol *p, *q, *old;
2696 for (p = changed_syms; p; p = q)
2702 /* Symbol was new. */
2703 if (p->attr.in_common && p->common_block->head)
2705 /* If the symbol was added to any common block, it
2706 needs to be removed to stop the resolver looking
2707 for a (possibly) dead symbol. */
2709 if (p->common_block->head == p)
2710 p->common_block->head = p->common_next;
2713 gfc_symbol *cparent, *csym;
2715 cparent = p->common_block->head;
2716 csym = cparent->common_next;
2721 csym = csym->common_next;
2724 gcc_assert(cparent->common_next == p);
2726 cparent->common_next = csym->common_next;
2730 gfc_delete_symtree (&p->ns->sym_root, p->name);
2734 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2736 gfc_free_symbol (p);
2740 /* Restore previous state of symbol. Just copy simple stuff. */
2742 old = p->old_symbol;
2744 p->ts.type = old->ts.type;
2745 p->ts.kind = old->ts.kind;
2747 p->attr = old->attr;
2749 if (p->value != old->value)
2751 gfc_free_expr (old->value);
2755 if (p->as != old->as)
2758 gfc_free_array_spec (p->as);
2762 p->generic = old->generic;
2763 p->component_access = old->component_access;
2765 if (p->namelist != NULL && old->namelist == NULL)
2767 gfc_free_namelist (p->namelist);
2772 if (p->namelist_tail != old->namelist_tail)
2774 gfc_free_namelist (old->namelist_tail);
2775 old->namelist_tail->next = NULL;
2779 p->namelist_tail = old->namelist_tail;
2781 if (p->formal != old->formal)
2783 gfc_free_formal_arglist (p->formal);
2784 p->formal = old->formal;
2787 gfc_free (p->old_symbol);
2788 p->old_symbol = NULL;
2792 changed_syms = NULL;
2796 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2797 components of old_symbol that might need deallocation are the "allocatables"
2798 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2799 namelist_tail. In case these differ between old_symbol and sym, it's just
2800 because sym->namelist has gotten a few more items. */
2803 free_old_symbol (gfc_symbol *sym)
2806 if (sym->old_symbol == NULL)
2809 if (sym->old_symbol->as != sym->as)
2810 gfc_free_array_spec (sym->old_symbol->as);
2812 if (sym->old_symbol->value != sym->value)
2813 gfc_free_expr (sym->old_symbol->value);
2815 if (sym->old_symbol->formal != sym->formal)
2816 gfc_free_formal_arglist (sym->old_symbol->formal);
2818 gfc_free (sym->old_symbol);
2819 sym->old_symbol = NULL;
2823 /* Makes the changes made in the current statement permanent-- gets
2824 rid of undo information. */
2827 gfc_commit_symbols (void)
2831 for (p = changed_syms; p; p = q)
2837 free_old_symbol (p);
2839 changed_syms = NULL;
2843 /* Makes the changes made in one symbol permanent -- gets rid of undo
2847 gfc_commit_symbol (gfc_symbol *sym)
2851 if (changed_syms == sym)
2852 changed_syms = sym->tlink;
2855 for (p = changed_syms; p; p = p->tlink)
2856 if (p->tlink == sym)
2858 p->tlink = sym->tlink;
2867 free_old_symbol (sym);
2871 /* Recursive function that deletes an entire tree and all the common
2872 head structures it points to. */
2875 free_common_tree (gfc_symtree * common_tree)
2877 if (common_tree == NULL)
2880 free_common_tree (common_tree->left);
2881 free_common_tree (common_tree->right);
2883 gfc_free (common_tree);
2887 /* Recursive function that deletes an entire tree and all the user
2888 operator nodes that it contains. */
2891 free_uop_tree (gfc_symtree *uop_tree)
2894 if (uop_tree == NULL)
2897 free_uop_tree (uop_tree->left);
2898 free_uop_tree (uop_tree->right);
2900 gfc_free_interface (uop_tree->n.uop->op);
2902 gfc_free (uop_tree->n.uop);
2903 gfc_free (uop_tree);
2907 /* Recursive function that deletes an entire tree and all the symbols
2908 that it contains. */
2911 free_sym_tree (gfc_symtree *sym_tree)
2916 if (sym_tree == NULL)
2919 free_sym_tree (sym_tree->left);
2920 free_sym_tree (sym_tree->right);
2922 sym = sym_tree->n.sym;
2926 gfc_internal_error ("free_sym_tree(): Negative refs");
2928 if (sym->formal_ns != NULL && sym->refs == 1)
2930 /* As formal_ns contains a reference to sym, delete formal_ns just
2931 before the deletion of sym. */
2932 ns = sym->formal_ns;
2933 sym->formal_ns = NULL;
2934 gfc_free_namespace (ns);
2936 else if (sym->refs == 0)
2938 /* Go ahead and delete the symbol. */
2939 gfc_free_symbol (sym);
2942 gfc_free (sym_tree);
2946 /* Free the derived type list. */
2949 gfc_free_dt_list (void)
2951 gfc_dt_list *dt, *n;
2953 for (dt = gfc_derived_types; dt; dt = n)
2959 gfc_derived_types = NULL;
2963 /* Free the gfc_equiv_info's. */
2966 gfc_free_equiv_infos (gfc_equiv_info *s)
2970 gfc_free_equiv_infos (s->next);
2975 /* Free the gfc_equiv_lists. */
2978 gfc_free_equiv_lists (gfc_equiv_list *l)
2982 gfc_free_equiv_lists (l->next);
2983 gfc_free_equiv_infos (l->equiv);
2988 /* Free a finalizer procedure list. */
2991 gfc_free_finalizer (gfc_finalizer* el)
2997 --el->proc_sym->refs;
2998 if (!el->proc_sym->refs)
2999 gfc_free_symbol (el->proc_sym);
3007 gfc_free_finalizer_list (gfc_finalizer* list)
3011 gfc_finalizer* current = list;
3013 gfc_free_finalizer (current);
3018 /* Free the charlen list from cl to end (end is not freed).
3019 Free the whole list if end is NULL. */
3021 void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3025 for (; cl != end; cl = cl2)
3030 gfc_free_expr (cl->length);
3036 /* Free a namespace structure and everything below it. Interface
3037 lists associated with intrinsic operators are not freed. These are
3038 taken care of when a specific name is freed. */
3041 gfc_free_namespace (gfc_namespace *ns)
3043 gfc_namespace *p, *q;
3052 gcc_assert (ns->refs == 0);
3054 gfc_free_statements (ns->code);
3056 free_sym_tree (ns->sym_root);
3057 free_uop_tree (ns->uop_root);
3058 free_common_tree (ns->common_root);
3059 gfc_free_finalizer_list (ns->finalizers);
3060 gfc_free_charlen (ns->cl_list, NULL);
3061 free_st_labels (ns->st_labels);
3063 gfc_free_equiv (ns->equiv);
3064 gfc_free_equiv_lists (ns->equiv_lists);
3065 gfc_free_use_stmts (ns->use_stmts);
3067 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3068 gfc_free_interface (ns->op[i]);
3070 gfc_free_data (ns->data);
3074 /* Recursively free any contained namespaces. */
3079 gfc_free_namespace (q);
3085 gfc_symbol_init_2 (void)
3088 gfc_current_ns = gfc_get_namespace (NULL, 0);
3093 gfc_symbol_done_2 (void)
3096 gfc_free_namespace (gfc_current_ns);
3097 gfc_current_ns = NULL;
3098 gfc_free_dt_list ();
3102 /* Clear mark bits from symbol nodes associated with a symtree node. */
3105 clear_sym_mark (gfc_symtree *st)
3108 st->n.sym->mark = 0;
3112 /* Recursively traverse the symtree nodes. */
3115 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
3120 gfc_traverse_symtree (st->left, func);
3122 gfc_traverse_symtree (st->right, func);
3126 /* Recursive namespace traversal function. */
3129 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
3135 traverse_ns (st->left, func);
3137 if (st->n.sym->mark == 0)
3138 (*func) (st->n.sym);
3139 st->n.sym->mark = 1;
3141 traverse_ns (st->right, func);
3145 /* Call a given function for all symbols in the namespace. We take
3146 care that each gfc_symbol node is called exactly once. */
3149 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3152 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3154 traverse_ns (ns->sym_root, func);
3158 /* Return TRUE when name is the name of an intrinsic type. */
3161 gfc_is_intrinsic_typename (const char *name)
3163 if (strcmp (name, "integer") == 0
3164 || strcmp (name, "real") == 0
3165 || strcmp (name, "character") == 0
3166 || strcmp (name, "logical") == 0
3167 || strcmp (name, "complex") == 0
3168 || strcmp (name, "doubleprecision") == 0
3169 || strcmp (name, "doublecomplex") == 0)
3176 /* Return TRUE if the symbol is an automatic variable. */
3179 gfc_is_var_automatic (gfc_symbol *sym)
3181 /* Pointer and allocatable variables are never automatic. */
3182 if (sym->attr.pointer || sym->attr.allocatable)
3184 /* Check for arrays with non-constant size. */
3185 if (sym->attr.dimension && sym->as
3186 && !gfc_is_compile_time_shape (sym->as))
3188 /* Check for non-constant length character variables. */
3189 if (sym->ts.type == BT_CHARACTER
3191 && !gfc_is_constant_expr (sym->ts.cl->length))
3196 /* Given a symbol, mark it as SAVEd if it is allowed. */
3199 save_symbol (gfc_symbol *sym)
3202 if (sym->attr.use_assoc)
3205 if (sym->attr.in_common
3208 || sym->attr.flavor != FL_VARIABLE)
3210 /* Automatic objects are not saved. */
3211 if (gfc_is_var_automatic (sym))
3213 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3217 /* Mark those symbols which can be SAVEd as such. */
3220 gfc_save_all (gfc_namespace *ns)
3222 gfc_traverse_ns (ns, save_symbol);
3227 /* Make sure that no changes to symbols are pending. */
3230 gfc_symbol_state(void) {
3232 if (changed_syms != NULL)
3233 gfc_internal_error("Symbol changes still pending!");
3238 /************** Global symbol handling ************/
3241 /* Search a tree for the global symbol. */
3244 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3253 c = strcmp (name, symbol->name);
3257 symbol = (c < 0) ? symbol->left : symbol->right;
3264 /* Compare two global symbols. Used for managing the BB tree. */
3267 gsym_compare (void *_s1, void *_s2)
3269 gfc_gsymbol *s1, *s2;
3271 s1 = (gfc_gsymbol *) _s1;
3272 s2 = (gfc_gsymbol *) _s2;
3273 return strcmp (s1->name, s2->name);
3277 /* Get a global symbol, creating it if it doesn't exist. */
3280 gfc_get_gsymbol (const char *name)
3284 s = gfc_find_gsymbol (gfc_gsym_root, name);
3288 s = XCNEW (gfc_gsymbol);
3289 s->type = GSYM_UNKNOWN;
3290 s->name = gfc_get_string (name);
3292 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3299 get_iso_c_binding_dt (int sym_id)
3301 gfc_dt_list *dt_list;
3303 dt_list = gfc_derived_types;
3305 /* Loop through the derived types in the name list, searching for
3306 the desired symbol from iso_c_binding. Search the parent namespaces
3307 if necessary and requested to (parent_flag). */
3308 while (dt_list != NULL)
3310 if (dt_list->derived->from_intmod != INTMOD_NONE
3311 && dt_list->derived->intmod_sym_id == sym_id)
3312 return dt_list->derived;
3314 dt_list = dt_list->next;
3321 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3322 with C. This is necessary for any derived type that is BIND(C) and for
3323 derived types that are parameters to functions that are BIND(C). All
3324 fields of the derived type are required to be interoperable, and are tested
3325 for such. If an error occurs, the errors are reported here, allowing for
3326 multiple errors to be handled for a single derived type. */
3329 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3331 gfc_component *curr_comp = NULL;
3332 gfc_try is_c_interop = FAILURE;
3333 gfc_try retval = SUCCESS;
3335 if (derived_sym == NULL)
3336 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3337 "unexpectedly NULL");
3339 /* If we've already looked at this derived symbol, do not look at it again
3340 so we don't repeat warnings/errors. */
3341 if (derived_sym->ts.is_c_interop)
3344 /* The derived type must have the BIND attribute to be interoperable
3345 J3/04-007, Section 15.2.3. */
3346 if (derived_sym->attr.is_bind_c != 1)
3348 derived_sym->ts.is_c_interop = 0;
3349 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3350 "attribute to be C interoperable", derived_sym->name,
3351 &(derived_sym->declared_at));
3355 curr_comp = derived_sym->components;
3357 /* TODO: is this really an error? */
3358 if (curr_comp == NULL)
3360 gfc_error ("Derived type '%s' at %L is empty",
3361 derived_sym->name, &(derived_sym->declared_at));
3365 /* Initialize the derived type as being C interoperable.
3366 If we find an error in the components, this will be set false. */
3367 derived_sym->ts.is_c_interop = 1;
3369 /* Loop through the list of components to verify that the kind of
3370 each is a C interoperable type. */
3373 /* The components cannot be pointers (fortran sense).
3374 J3/04-007, Section 15.2.3, C1505. */
3375 if (curr_comp->attr.pointer != 0)
3377 gfc_error ("Component '%s' at %L cannot have the "
3378 "POINTER attribute because it is a member "
3379 "of the BIND(C) derived type '%s' at %L",
3380 curr_comp->name, &(curr_comp->loc),
3381 derived_sym->name, &(derived_sym->declared_at));
3385 /* The components cannot be allocatable.
3386 J3/04-007, Section 15.2.3, C1505. */
3387 if (curr_comp->attr.allocatable != 0)
3389 gfc_error ("Component '%s' at %L cannot have the "
3390 "ALLOCATABLE attribute because it is a member "
3391 "of the BIND(C) derived type '%s' at %L",
3392 curr_comp->name, &(curr_comp->loc),
3393 derived_sym->name, &(derived_sym->declared_at));
3397 /* BIND(C) derived types must have interoperable components. */
3398 if (curr_comp->ts.type == BT_DERIVED
3399 && curr_comp->ts.derived->ts.is_iso_c != 1
3400 && curr_comp->ts.derived != derived_sym)
3402 /* This should be allowed; the draft says a derived-type can not
3403 have type parameters if it is has the BIND attribute. Type
3404 parameters seem to be for making parameterized derived types.
3405 There's no need to verify the type if it is c_ptr/c_funptr. */
3406 retval = verify_bind_c_derived_type (curr_comp->ts.derived);
3410 /* Grab the typespec for the given component and test the kind. */
3411 is_c_interop = verify_c_interop (&(curr_comp->ts));
3413 if (is_c_interop != SUCCESS)
3415 /* Report warning and continue since not fatal. The
3416 draft does specify a constraint that requires all fields
3417 to interoperate, but if the user says real(4), etc., it
3418 may interoperate with *something* in C, but the compiler
3419 most likely won't know exactly what. Further, it may not
3420 interoperate with the same data type(s) in C if the user
3421 recompiles with different flags (e.g., -m32 and -m64 on
3422 x86_64 and using integer(4) to claim interop with a
3424 if (derived_sym->attr.is_bind_c == 1)
3425 /* If the derived type is bind(c), all fields must be
3427 gfc_warning ("Component '%s' in derived type '%s' at %L "
3428 "may not be C interoperable, even though "
3429 "derived type '%s' is BIND(C)",
3430 curr_comp->name, derived_sym->name,
3431 &(curr_comp->loc), derived_sym->name);
3433 /* If derived type is param to bind(c) routine, or to one
3434 of the iso_c_binding procs, it must be interoperable, so
3435 all fields must interop too. */
3436 gfc_warning ("Component '%s' in derived type '%s' at %L "
3437 "may not be C interoperable",
3438 curr_comp->name, derived_sym->name,
3443 curr_comp = curr_comp->next;
3444 } while (curr_comp != NULL);
3447 /* Make sure we don't have conflicts with the attributes. */
3448 if (derived_sym->attr.access == ACCESS_PRIVATE)
3450 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3451 "PRIVATE and BIND(C) attributes", derived_sym->name,
3452 &(derived_sym->declared_at));
3456 if (derived_sym->attr.sequence != 0)
3458 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3459 "attribute because it is BIND(C)", derived_sym->name,
3460 &(derived_sym->declared_at));
3464 /* Mark the derived type as not being C interoperable if we found an
3465 error. If there were only warnings, proceed with the assumption
3466 it's interoperable. */
3467 if (retval == FAILURE)
3468 derived_sym->ts.is_c_interop = 0;
3474 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3477 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3478 const char *module_name)
3480 gfc_symtree *tmp_symtree;
3481 gfc_symbol *tmp_sym;
3483 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3485 if (tmp_symtree != NULL)
3486 tmp_sym = tmp_symtree->n.sym;
3490 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3491 "create symbol for %s", ptr_name);
3494 /* Set up the symbol's important fields. Save attr required so we can
3495 initialize the ptr to NULL. */
3496 tmp_sym->attr.save = SAVE_EXPLICIT;
3497 tmp_sym->ts.is_c_interop = 1;
3498 tmp_sym->attr.is_c_interop = 1;
3499 tmp_sym->ts.is_iso_c = 1;
3500 tmp_sym->ts.type = BT_DERIVED;
3502 /* The c_ptr and c_funptr derived types will provide the
3503 definition for c_null_ptr and c_null_funptr, respectively. */
3504 if (ptr_id == ISOCBINDING_NULL_PTR)
3505 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3507 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3508 if (tmp_sym->ts.derived == NULL)
3510 /* This can occur if the user forgot to declare c_ptr or
3511 c_funptr and they're trying to use one of the procedures
3512 that has arg(s) of the missing type. In this case, a
3513 regular version of the thing should have been put in the
3515 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3516 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3517 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3518 ? "_gfortran_iso_c_binding_c_ptr"
3519 : "_gfortran_iso_c_binding_c_funptr"));
3521 tmp_sym->ts.derived =
3522 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3523 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3526 /* Module name is some mangled version of iso_c_binding. */
3527 tmp_sym->module = gfc_get_string (module_name);
3529 /* Say it's from the iso_c_binding module. */
3530 tmp_sym->attr.is_iso_c = 1;
3532 tmp_sym->attr.use_assoc = 1;
3533 tmp_sym->attr.is_bind_c = 1;
3534 /* Set the binding_label. */
3535 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3537 /* Set the c_address field of c_null_ptr and c_null_funptr to
3538 the value of NULL. */
3539 tmp_sym->value = gfc_get_expr ();
3540 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3541 tmp_sym->value->ts.type = BT_DERIVED;
3542 tmp_sym->value->ts.derived = tmp_sym->ts.derived;
3543 /* Create a constructor with no expr, that way we can recognize if the user
3544 tries to call the structure constructor for one of the iso_c_binding
3545 derived types during resolution (resolve_structure_cons). */
3546 tmp_sym->value->value.constructor = gfc_get_constructor ();
3547 /* Must declare c_null_ptr and c_null_funptr as having the
3548 PARAMETER attribute so they can be used in init expressions. */
3549 tmp_sym->attr.flavor = FL_PARAMETER;
3555 /* Add a formal argument, gfc_formal_arglist, to the
3556 end of the given list of arguments. Set the reference to the
3557 provided symbol, param_sym, in the argument. */
3560 add_formal_arg (gfc_formal_arglist **head,
3561 gfc_formal_arglist **tail,
3562 gfc_formal_arglist *formal_arg,
3563 gfc_symbol *param_sym)
3565 /* Put in list, either as first arg or at the tail (curr arg). */
3567 *head = *tail = formal_arg;
3570 (*tail)->next = formal_arg;
3571 (*tail) = formal_arg;
3574 (*tail)->sym = param_sym;
3575 (*tail)->next = NULL;
3581 /* Generates a symbol representing the CPTR argument to an
3582 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3583 CPTR and add it to the provided argument list. */
3586 gen_cptr_param (gfc_formal_arglist **head,
3587 gfc_formal_arglist **tail,
3588 const char *module_name,
3589 gfc_namespace *ns, const char *c_ptr_name,
3592 gfc_symbol *param_sym = NULL;
3593 gfc_symbol *c_ptr_sym = NULL;
3594 gfc_symtree *param_symtree = NULL;
3595 gfc_formal_arglist *formal_arg = NULL;
3596 const char *c_ptr_in;
3597 const char *c_ptr_type = NULL;
3599 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3600 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3602 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3604 if(c_ptr_name == NULL)
3605 c_ptr_in = "gfc_cptr__";
3607 c_ptr_in = c_ptr_name;
3608 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree);
3609 if (param_symtree != NULL)
3610 param_sym = param_symtree->n.sym;
3612 gfc_internal_error ("gen_cptr_param(): Unable to "
3613 "create symbol for %s", c_ptr_in);
3615 /* Set up the appropriate fields for the new c_ptr param sym. */
3617 param_sym->attr.flavor = FL_DERIVED;
3618 param_sym->ts.type = BT_DERIVED;
3619 param_sym->attr.intent = INTENT_IN;
3620 param_sym->attr.dummy = 1;
3622 /* This will pass the ptr to the iso_c routines as a (void *). */
3623 param_sym->attr.value = 1;
3624 param_sym->attr.use_assoc = 1;
3626 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3628 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3629 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3631 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3632 if (c_ptr_sym == NULL)
3634 /* This can happen if the user did not define c_ptr but they are
3635 trying to use one of the iso_c_binding functions that need it. */
3636 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3637 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3638 (const char *)c_ptr_type);
3640 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3641 (const char *)c_ptr_type);
3643 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3646 param_sym->ts.derived = c_ptr_sym;
3647 param_sym->module = gfc_get_string (module_name);
3649 /* Make new formal arg. */
3650 formal_arg = gfc_get_formal_arglist ();
3651 /* Add arg to list of formal args (the CPTR arg). */
3652 add_formal_arg (head, tail, formal_arg, param_sym);
3656 /* Generates a symbol representing the FPTR argument to an
3657 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3658 FPTR and add it to the provided argument list. */
3661 gen_fptr_param (gfc_formal_arglist **head,
3662 gfc_formal_arglist **tail,
3663 const char *module_name,
3664 gfc_namespace *ns, const char *f_ptr_name, int proc)
3666 gfc_symbol *param_sym = NULL;
3667 gfc_symtree *param_symtree = NULL;
3668 gfc_formal_arglist *formal_arg = NULL;
3669 const char *f_ptr_out = "gfc_fptr__";
3671 if (f_ptr_name != NULL)
3672 f_ptr_out = f_ptr_name;
3674 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree);
3675 if (param_symtree != NULL)
3676 param_sym = param_symtree->n.sym;
3678 gfc_internal_error ("generateFPtrParam(): Unable to "
3679 "create symbol for %s", f_ptr_out);
3681 /* Set up the necessary fields for the fptr output param sym. */
3684 param_sym->attr.proc_pointer = 1;
3686 param_sym->attr.pointer = 1;
3687 param_sym->attr.dummy = 1;
3688 param_sym->attr.use_assoc = 1;
3690 /* ISO C Binding type to allow any pointer type as actual param. */
3691 param_sym->ts.type = BT_VOID;
3692 param_sym->module = gfc_get_string (module_name);
3695 formal_arg = gfc_get_formal_arglist ();
3696 /* Add arg to list of formal args. */
3697 add_formal_arg (head, tail, formal_arg, param_sym);
3701 /* Generates a symbol representing the optional SHAPE argument for the
3702 iso_c_binding c_f_pointer() procedure. Also, create a
3703 gfc_formal_arglist for the SHAPE and add it to the provided
3707 gen_shape_param (gfc_formal_arglist **head,
3708 gfc_formal_arglist **tail,
3709 const char *module_name,
3710 gfc_namespace *ns, const char *shape_param_name)
3712 gfc_symbol *param_sym = NULL;
3713 gfc_symtree *param_symtree = NULL;
3714 gfc_formal_arglist *formal_arg = NULL;
3715 const char *shape_param = "gfc_shape_array__";
3718 if (shape_param_name != NULL)
3719 shape_param = shape_param_name;
3721 gfc_get_sym_tree (shape_param, ns, ¶m_symtree);
3722 if (param_symtree != NULL)
3723 param_sym = param_symtree->n.sym;
3725 gfc_internal_error ("generateShapeParam(): Unable to "
3726 "create symbol for %s", shape_param);
3728 /* Set up the necessary fields for the shape input param sym. */
3730 param_sym->attr.dummy = 1;
3731 param_sym->attr.use_assoc = 1;
3733 /* Integer array, rank 1, describing the shape of the object. Make it's
3734 type BT_VOID initially so we can accept any type/kind combination of
3735 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3736 of BT_INTEGER type. */
3737 param_sym->ts.type = BT_VOID;
3739 /* Initialize the kind to default integer. However, it will be overridden
3740 during resolution to match the kind of the SHAPE parameter given as
3741 the actual argument (to allow for any valid integer kind). */
3742 param_sym->ts.kind = gfc_default_integer_kind;
3743 param_sym->as = gfc_get_array_spec ();
3745 /* Clear out the dimension info for the array. */
3746 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3748 param_sym->as->lower[i] = NULL;
3749 param_sym->as->upper[i] = NULL;
3751 param_sym->as->rank = 1;
3752 param_sym->as->lower[0] = gfc_int_expr (1);
3754 /* The extent is unknown until we get it. The length give us
3755 the rank the incoming pointer. */
3756 param_sym->as->type = AS_ASSUMED_SHAPE;
3758 /* The arg is also optional; it is required iff the second arg
3759 (fptr) is to an array, otherwise, it's ignored. */
3760 param_sym->attr.optional = 1;
3761 param_sym->attr.intent = INTENT_IN;
3762 param_sym->attr.dimension = 1;
3763 param_sym->module = gfc_get_string (module_name);
3766 formal_arg = gfc_get_formal_arglist ();
3767 /* Add arg to list of formal args. */
3768 add_formal_arg (head, tail, formal_arg, param_sym);
3771 /* Add a procedure interface to the given symbol (i.e., store a
3772 reference to the list of formal arguments). */
3775 add_proc_interface (gfc_symbol *sym, ifsrc source,
3776 gfc_formal_arglist *formal)
3779 sym->formal = formal;
3780 sym->attr.if_source = source;
3783 /* Copy the formal args from an existing symbol, src, into a new
3784 symbol, dest. New formal args are created, and the description of
3785 each arg is set according to the existing ones. This function is
3786 used when creating procedure declaration variables from a procedure
3787 declaration statement (see match_proc_decl()) to create the formal
3788 args based on the args of a given named interface. */
3791 copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
3793 gfc_formal_arglist *head = NULL;
3794 gfc_formal_arglist *tail = NULL;
3795 gfc_formal_arglist *formal_arg = NULL;
3796 gfc_formal_arglist *curr_arg = NULL;
3797 gfc_formal_arglist *formal_prev = NULL;
3798 /* Save current namespace so we can change it for formal args. */
3799 gfc_namespace *parent_ns = gfc_current_ns;
3801 /* Create a new namespace, which will be the formal ns (namespace
3802 of the formal args). */
3803 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3804 gfc_current_ns->proc_name = dest;
3806 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3808 formal_arg = gfc_get_formal_arglist ();
3809 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
3811 /* May need to copy more info for the symbol. */
3812 formal_arg->sym->attr = curr_arg->sym->attr;
3813 formal_arg->sym->ts = curr_arg->sym->ts;
3814 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
3815 copy_formal_args (formal_arg->sym, curr_arg->sym);
3817 /* If this isn't the first arg, set up the next ptr. For the
3818 last arg built, the formal_arg->next will never get set to
3819 anything other than NULL. */
3820 if (formal_prev != NULL)
3821 formal_prev->next = formal_arg;
3823 formal_arg->next = NULL;
3825 formal_prev = formal_arg;
3827 /* Add arg to list of formal args. */
3828 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3831 /* Add the interface to the symbol. */
3832 add_proc_interface (dest, IFSRC_DECL, head);
3834 /* Store the formal namespace information. */
3835 if (dest->formal != NULL)
3836 /* The current ns should be that for the dest proc. */
3837 dest->formal_ns = gfc_current_ns;
3838 /* Restore the current namespace to what it was on entry. */
3839 gfc_current_ns = parent_ns;
3842 /* Builds the parameter list for the iso_c_binding procedure
3843 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3844 generic version of either the c_f_pointer or c_f_procpointer
3845 functions. The new_proc_sym represents a "resolved" version of the
3846 symbol. The functions are resolved to match the types of their
3847 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3848 something similar to c_f_pointer_i4 if the type of data object fptr
3849 pointed to was a default integer. The actual name of the resolved
3850 procedure symbol is further mangled with the module name, etc., but
3851 the idea holds true. */
3854 build_formal_args (gfc_symbol *new_proc_sym,
3855 gfc_symbol *old_sym, int add_optional_arg)
3857 gfc_formal_arglist *head = NULL, *tail = NULL;
3858 gfc_namespace *parent_ns = NULL;
3860 parent_ns = gfc_current_ns;
3861 /* Create a new namespace, which will be the formal ns (namespace
3862 of the formal args). */
3863 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
3864 gfc_current_ns->proc_name = new_proc_sym;
3866 /* Generate the params. */
3867 if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
3869 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3870 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3871 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3872 gfc_current_ns, "fptr", 1);
3874 else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3876 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3877 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3878 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3879 gfc_current_ns, "fptr", 0);
3880 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3881 gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
3882 gfc_current_ns, "shape");
3885 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3887 /* c_associated has one required arg and one optional; both
3889 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3890 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
3891 if (add_optional_arg)
3893 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3894 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
3895 /* The last param is optional so mark it as such. */
3896 tail->sym->attr.optional = 1;
3900 /* Add the interface (store formal args to new_proc_sym). */
3901 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
3903 /* Set up the formal_ns pointer to the one created for the
3904 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3905 new_proc_sym->formal_ns = gfc_current_ns;
3907 gfc_current_ns = parent_ns;
3911 std_for_isocbinding_symbol (int id)
3915 #define NAMED_INTCST(a,b,c,d) \
3918 #include "iso-c-binding.def"
3921 return GFC_STD_F2003;
3925 /* Generate the given set of C interoperable kind objects, or all
3926 interoperable kinds. This function will only be given kind objects
3927 for valid iso_c_binding defined types because this is verified when
3928 the 'use' statement is parsed. If the user gives an 'only' clause,
3929 the specific kinds are looked up; if they don't exist, an error is
3930 reported. If the user does not give an 'only' clause, all
3931 iso_c_binding symbols are generated. If a list of specific kinds
3932 is given, it must have a NULL in the first empty spot to mark the
3937 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
3938 const char *local_name)
3940 const char *const name = (local_name && local_name[0]) ? local_name
3941 : c_interop_kinds_table[s].name;
3942 gfc_symtree *tmp_symtree = NULL;
3943 gfc_symbol *tmp_sym = NULL;
3944 gfc_dt_list **dt_list_ptr = NULL;
3945 gfc_component *tmp_comp = NULL;
3946 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
3949 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
3951 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
3953 /* Already exists in this scope so don't re-add it.
3954 TODO: we should probably check that it's really the same symbol. */
3955 if (tmp_symtree != NULL)
3958 /* Create the sym tree in the current ns. */
3959 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
3961 tmp_sym = tmp_symtree->n.sym;
3963 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3966 /* Say what module this symbol belongs to. */
3967 tmp_sym->module = gfc_get_string (mod_name);
3968 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
3969 tmp_sym->intmod_sym_id = s;
3974 #define NAMED_INTCST(a,b,c,d) case a :
3975 #define NAMED_REALCST(a,b,c) case a :
3976 #define NAMED_CMPXCST(a,b,c) case a :
3977 #define NAMED_LOGCST(a,b,c) case a :
3978 #define NAMED_CHARKNDCST(a,b,c) case a :
3979 #include "iso-c-binding.def"
3981 tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
3983 /* Initialize an integer constant expression node. */
3984 tmp_sym->attr.flavor = FL_PARAMETER;
3985 tmp_sym->ts.type = BT_INTEGER;
3986 tmp_sym->ts.kind = gfc_default_integer_kind;
3988 /* Mark this type as a C interoperable one. */
3989 tmp_sym->ts.is_c_interop = 1;
3990 tmp_sym->ts.is_iso_c = 1;
3991 tmp_sym->value->ts.is_c_interop = 1;
3992 tmp_sym->value->ts.is_iso_c = 1;
3993 tmp_sym->attr.is_c_interop = 1;
3995 /* Tell what f90 type this c interop kind is valid. */
3996 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
3998 /* Say it's from the iso_c_binding module. */
3999 tmp_sym->attr.is_iso_c = 1;
4001 /* Make it use associated. */
4002 tmp_sym->attr.use_assoc = 1;
4006 #define NAMED_CHARCST(a,b,c) case a :
4007 #include "iso-c-binding.def"
4009 /* Initialize an integer constant expression node for the
4010 length of the character. */
4011 tmp_sym->value = gfc_get_expr ();
4012 tmp_sym->value->expr_type = EXPR_CONSTANT;
4013 tmp_sym->value->ts.type = BT_CHARACTER;
4014 tmp_sym->value->ts.kind = gfc_default_character_kind;
4015 tmp_sym->value->where = gfc_current_locus;
4016 tmp_sym->value->ts.is_c_interop = 1;
4017 tmp_sym->value->ts.is_iso_c = 1;
4018 tmp_sym->value->value.character.length = 1;
4019 tmp_sym->value->value.character.string = gfc_get_wide_string (2);
4020 tmp_sym->value->value.character.string[0]
4021 = (gfc_char_t) c_interop_kinds_table[s].value;
4022 tmp_sym->value->value.character.string[1] = '\0';
4023 tmp_sym->ts.cl = gfc_get_charlen ();
4024 tmp_sym->ts.cl->length = gfc_int_expr (1);
4026 /* May not need this in both attr and ts, but do need in
4027 attr for writing module file. */
4028 tmp_sym->attr.is_c_interop = 1;
4030 tmp_sym->attr.flavor = FL_PARAMETER;
4031 tmp_sym->ts.type = BT_CHARACTER;
4033 /* Need to set it to the C_CHAR kind. */
4034 tmp_sym->ts.kind = gfc_default_character_kind;
4036 /* Mark this type as a C interoperable one. */
4037 tmp_sym->ts.is_c_interop = 1;
4038 tmp_sym->ts.is_iso_c = 1;
4040 /* Tell what f90 type this c interop kind is valid. */
4041 tmp_sym->ts.f90_type = BT_CHARACTER;
4043 /* Say it's from the iso_c_binding module. */
4044 tmp_sym->attr.is_iso_c = 1;
4046 /* Make it use associated. */
4047 tmp_sym->attr.use_assoc = 1;
4050 case ISOCBINDING_PTR:
4051 case ISOCBINDING_FUNPTR:
4053 /* Initialize an integer constant expression node. */
4054 tmp_sym->attr.flavor = FL_DERIVED;
4055 tmp_sym->ts.is_c_interop = 1;
4056 tmp_sym->attr.is_c_interop = 1;
4057 tmp_sym->attr.is_iso_c = 1;
4058 tmp_sym->ts.is_iso_c = 1;
4059 tmp_sym->ts.type = BT_DERIVED;
4061 /* A derived type must have the bind attribute to be
4062 interoperable (J3/04-007, Section 15.2.3), even though
4063 the binding label is not used. */
4064 tmp_sym->attr.is_bind_c = 1;
4066 tmp_sym->attr.referenced = 1;
4068 tmp_sym->ts.derived = tmp_sym;
4070 /* Add the symbol created for the derived type to the current ns. */
4071 dt_list_ptr = &(gfc_derived_types);
4072 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4073 dt_list_ptr = &((*dt_list_ptr)->next);
4075 /* There is already at least one derived type in the list, so append
4076 the one we're currently building for c_ptr or c_funptr. */
4077 if (*dt_list_ptr != NULL)
4078 dt_list_ptr = &((*dt_list_ptr)->next);
4079 (*dt_list_ptr) = gfc_get_dt_list ();
4080 (*dt_list_ptr)->derived = tmp_sym;
4081 (*dt_list_ptr)->next = NULL;
4083 /* Set up the component of the derived type, which will be
4084 an integer with kind equal to c_ptr_size. Mangle the name of
4085 the field for the c_address to prevent the curious user from
4086 trying to access it from Fortran. */
4087 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
4088 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
4089 if (tmp_comp == NULL)
4090 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4091 "create component for c_address");
4093 tmp_comp->ts.type = BT_INTEGER;
4095 /* Set this because the module will need to read/write this field. */
4096 tmp_comp->ts.f90_type = BT_INTEGER;
4098 /* The kinds for c_ptr and c_funptr are the same. */
4099 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4100 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4102 tmp_comp->attr.pointer = 0;
4103 tmp_comp->attr.dimension = 0;
4105 /* Mark the component as C interoperable. */
4106 tmp_comp->ts.is_c_interop = 1;
4108 /* Make it use associated (iso_c_binding module). */
4109 tmp_sym->attr.use_assoc = 1;
4112 case ISOCBINDING_NULL_PTR:
4113 case ISOCBINDING_NULL_FUNPTR:
4114 gen_special_c_interop_ptr (s, name, mod_name);
4117 case ISOCBINDING_F_POINTER:
4118 case ISOCBINDING_ASSOCIATED:
4119 case ISOCBINDING_LOC:
4120 case ISOCBINDING_FUNLOC:
4121 case ISOCBINDING_F_PROCPOINTER:
4123 tmp_sym->attr.proc = PROC_MODULE;
4125 /* Use the procedure's name as it is in the iso_c_binding module for
4126 setting the binding label in case the user renamed the symbol. */
4127 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
4128 c_interop_kinds_table[s].name);
4129 tmp_sym->attr.is_iso_c = 1;
4130 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4131 tmp_sym->attr.subroutine = 1;
4134 /* TODO! This needs to be finished more for the expr of the
4135 function or something!
4136 This may not need to be here, because trying to do c_loc
4138 if (s == ISOCBINDING_ASSOCIATED)
4140 tmp_sym->attr.function = 1;
4141 tmp_sym->ts.type = BT_LOGICAL;
4142 tmp_sym->ts.kind = gfc_default_logical_kind;
4143 tmp_sym->result = tmp_sym;
4147 /* Here, we're taking the simple approach. We're defining
4148 c_loc as an external identifier so the compiler will put
4149 what we expect on the stack for the address we want the
4151 tmp_sym->ts.type = BT_DERIVED;
4152 if (s == ISOCBINDING_LOC)
4153 tmp_sym->ts.derived =
4154 get_iso_c_binding_dt (ISOCBINDING_PTR);
4156 tmp_sym->ts.derived =
4157 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4159 if (tmp_sym->ts.derived == NULL)
4161 /* Create the necessary derived type so we can continue
4162 processing the file. */
4163 generate_isocbinding_symbol
4164 (mod_name, s == ISOCBINDING_FUNLOC
4165 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4166 (const char *)(s == ISOCBINDING_FUNLOC
4167 ? "_gfortran_iso_c_binding_c_funptr"
4168 : "_gfortran_iso_c_binding_c_ptr"));
4169 tmp_sym->ts.derived =
4170 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4171 ? ISOCBINDING_FUNPTR
4175 /* The function result is itself (no result clause). */
4176 tmp_sym->result = tmp_sym;
4177 tmp_sym->attr.external = 1;
4178 tmp_sym->attr.use_assoc = 0;
4179 tmp_sym->attr.pure = 1;
4180 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4181 tmp_sym->attr.proc = PROC_UNKNOWN;
4185 tmp_sym->attr.flavor = FL_PROCEDURE;
4186 tmp_sym->attr.contained = 0;
4188 /* Try using this builder routine, with the new and old symbols
4189 both being the generic iso_c proc sym being created. This
4190 will create the formal args (and the new namespace for them).
4191 Don't build an arg list for c_loc because we're going to treat
4192 c_loc as an external procedure. */
4193 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4194 /* The 1 says to add any optional args, if applicable. */
4195 build_formal_args (tmp_sym, tmp_sym, 1);
4197 /* Set this after setting up the symbol, to prevent error messages. */
4198 tmp_sym->attr.use_assoc = 1;
4200 /* This symbol will not be referenced directly. It will be
4201 resolved to the implementation for the given f90 kind. */
4202 tmp_sym->attr.referenced = 0;
4212 /* Creates a new symbol based off of an old iso_c symbol, with a new
4213 binding label. This function can be used to create a new,
4214 resolved, version of a procedure symbol for c_f_pointer or
4215 c_f_procpointer that is based on the generic symbols. A new
4216 parameter list is created for the new symbol using
4217 build_formal_args(). The add_optional_flag specifies whether the
4218 to add the optional SHAPE argument. The new symbol is
4222 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4223 char *new_binding_label, int add_optional_arg)
4225 gfc_symtree *new_symtree = NULL;
4227 /* See if we have a symbol by that name already available, looking
4228 through any parent namespaces. */
4229 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4230 if (new_symtree != NULL)
4231 /* Return the existing symbol. */
4232 return new_symtree->n.sym;
4234 /* Create the symtree/symbol, with attempted host association. */
4235 gfc_get_ha_sym_tree (new_name, &new_symtree);
4236 if (new_symtree == NULL)
4237 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4238 "symtree for '%s'", new_name);
4240 /* Now fill in the fields of the resolved symbol with the old sym. */
4241 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4242 new_symtree->n.sym->attr = old_sym->attr;
4243 new_symtree->n.sym->ts = old_sym->ts;
4244 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4245 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4246 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4247 /* Build the formal arg list. */
4248 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4250 gfc_commit_symbol (new_symtree->n.sym);
4252 return new_symtree->n.sym;
4256 /* Check that a symbol is already typed. If strict is not set, an untyped
4257 symbol is acceptable for non-standard-conforming mode. */
4260 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4261 bool strict, locus where)
4265 if (gfc_matching_prefix)
4268 /* Check for the type and try to give it an implicit one. */
4269 if (sym->ts.type == BT_UNKNOWN
4270 && gfc_set_default_type (sym, 0, ns) == FAILURE)
4274 gfc_error ("Symbol '%s' is used before it is typed at %L",
4279 if (gfc_notify_std (GFC_STD_GNU,
4280 "Extension: Symbol '%s' is used before"
4281 " it is typed at %L", sym->name, &where) == FAILURE)
4285 /* Everything is ok. */
4290 /* Get the super-type of a given derived type. */
4293 gfc_get_derived_super_type (gfc_symbol* derived)
4295 if (!derived->attr.extension)
4298 gcc_assert (derived->components);
4299 gcc_assert (derived->components->ts.type == BT_DERIVED);
4300 gcc_assert (derived->components->ts.derived);
4302 return derived->components->ts.derived;
4306 /* Find a type-bound procedure by name for a derived-type (looking recursively
4307 through the super-types). */
4310 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
4311 const char* name, bool noaccess)
4315 /* Set default to failure. */
4319 /* Try to find it in the current type's namespace. */
4320 gcc_assert (derived->f2k_derived);
4321 res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
4322 if (res && res->typebound)
4328 if (!noaccess && derived->attr.use_assoc
4329 && res->typebound->access == ACCESS_PRIVATE)
4331 gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
4339 /* Otherwise, recurse on parent type if derived is an extension. */
4340 if (derived->attr.extension)
4342 gfc_symbol* super_type;
4343 super_type = gfc_get_derived_super_type (derived);
4344 gcc_assert (super_type);
4345 return gfc_find_typebound_proc (super_type, t, name, noaccess);
4348 /* Nothing found. */