1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
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;
97 gfc_gsymbol *gfc_gsym_root = NULL;
99 static gfc_symbol *changed_syms = NULL;
101 gfc_dt_list *gfc_derived_types;
104 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
106 /* The following static variable indicates whether a particular element has
107 been explicitly set or not. */
109 static int new_flag[GFC_LETTERS];
112 /* Handle a correctly parsed IMPLICIT NONE. */
115 gfc_set_implicit_none (void)
119 if (gfc_current_ns->seen_implicit_none)
121 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
125 gfc_current_ns->seen_implicit_none = 1;
127 for (i = 0; i < GFC_LETTERS; i++)
129 gfc_clear_ts (&gfc_current_ns->default_type[i]);
130 gfc_current_ns->set_flag[i] = 1;
135 /* Reset the implicit range flags. */
138 gfc_clear_new_implicit (void)
142 for (i = 0; i < GFC_LETTERS; i++)
147 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
150 gfc_add_new_implicit_range (int c1, int c2)
157 for (i = c1; i <= c2; i++)
161 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
173 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
174 the new implicit types back into the existing types will work. */
177 gfc_merge_new_implicit (gfc_typespec *ts)
181 if (gfc_current_ns->seen_implicit_none)
183 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
187 for (i = 0; i < GFC_LETTERS; i++)
191 if (gfc_current_ns->set_flag[i])
193 gfc_error ("Letter %c already has an IMPLICIT type at %C",
198 gfc_current_ns->default_type[i] = *ts;
199 gfc_current_ns->implicit_loc[i] = gfc_current_locus;
200 gfc_current_ns->set_flag[i] = 1;
207 /* Given a symbol, return a pointer to the typespec for its default type. */
210 gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
214 letter = sym->name[0];
216 if (gfc_option.flag_allow_leading_underscore && letter == '_')
217 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
218 "gfortran developers, and should not be used for "
219 "implicitly typed variables");
221 if (letter < 'a' || letter > 'z')
222 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
227 return &ns->default_type[letter - 'a'];
231 /* Given a pointer to a symbol, set its type according to the first
232 letter of its name. Fails if the letter in question has no default
236 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
240 if (sym->ts.type != BT_UNKNOWN)
241 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
243 ts = gfc_get_default_type (sym, ns);
245 if (ts->type == BT_UNKNOWN)
247 if (error_flag && !sym->attr.untyped)
249 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
250 sym->name, &sym->declared_at);
251 sym->attr.untyped = 1; /* Ensure we only give an error once. */
258 sym->attr.implicit_type = 1;
260 if (sym->attr.is_bind_c == 1)
262 /* BIND(C) variables should not be implicitly declared. */
263 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
264 "not be C interoperable", sym->name, &sym->declared_at);
265 sym->ts.f90_type = sym->ts.type;
268 if (sym->attr.dummy != 0)
270 if (sym->ns->proc_name != NULL
271 && (sym->ns->proc_name->attr.subroutine != 0
272 || sym->ns->proc_name->attr.function != 0)
273 && sym->ns->proc_name->attr.is_bind_c != 0)
275 /* Dummy args to a BIND(C) routine may not be interoperable if
276 they are implicitly typed. */
277 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
278 "be C interoperable but it is a dummy argument to "
279 "the BIND(C) procedure '%s' at %L", sym->name,
280 &(sym->declared_at), sym->ns->proc_name->name,
281 &(sym->ns->proc_name->declared_at));
282 sym->ts.f90_type = sym->ts.type;
290 /* This function is called from parse.c(parse_progunit) to check the
291 type of the function is not implicitly typed in the host namespace
292 and to implicitly type the function result, if necessary. */
295 gfc_check_function_type (gfc_namespace *ns)
297 gfc_symbol *proc = ns->proc_name;
299 if (!proc->attr.contained || proc->result->attr.implicit_type)
302 if (proc->result->ts.type == BT_UNKNOWN)
304 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
307 if (proc->result != proc)
309 proc->ts = proc->result->ts;
310 proc->as = gfc_copy_array_spec (proc->result->as);
311 proc->attr.dimension = proc->result->attr.dimension;
312 proc->attr.pointer = proc->result->attr.pointer;
313 proc->attr.allocatable = proc->result->attr.allocatable;
318 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
319 proc->result->name, &proc->result->declared_at);
320 proc->result->attr.untyped = 1;
326 /******************** Symbol attribute stuff *********************/
328 /* This is a generic conflict-checker. We do this to avoid having a
329 single conflict in two places. */
331 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
332 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
333 #define conf_std(a, b, std) if (attr->a && attr->b)\
342 check_conflict (symbol_attribute *attr, const char *name, locus *where)
344 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
345 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
346 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
347 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
348 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
349 *privat = "PRIVATE", *recursive = "RECURSIVE",
350 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
351 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
352 *function = "FUNCTION", *subroutine = "SUBROUTINE",
353 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
354 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
355 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
356 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
357 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
358 static const char *threadprivate = "THREADPRIVATE";
364 where = &gfc_current_locus;
366 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
370 standard = GFC_STD_F2003;
374 /* Check for attributes not allowed in a BLOCK DATA. */
375 if (gfc_current_state () == COMP_BLOCK_DATA)
379 if (attr->in_namelist)
381 if (attr->allocatable)
387 if (attr->access == ACCESS_PRIVATE)
389 if (attr->access == ACCESS_PUBLIC)
391 if (attr->intent != INTENT_UNKNOWN)
397 ("%s attribute not allowed in BLOCK DATA program unit at %L",
403 if (attr->save == SAVE_EXPLICIT)
406 conf (in_common, save);
409 switch (attr->flavor)
417 a1 = gfc_code2string (flavors, attr->flavor);
422 /* Conflicts between SAVE and PROCEDURE will be checked at
423 resolution stage, see "resolve_fl_procedure". */
432 conf (dummy, intrinsic);
433 conf (dummy, threadprivate);
434 conf (pointer, target);
435 conf (pointer, intrinsic);
436 conf (pointer, elemental);
437 conf (allocatable, elemental);
439 conf (target, external);
440 conf (target, intrinsic);
442 if (!attr->if_source)
443 conf (external, dimension); /* See Fortran 95's R504. */
445 conf (external, intrinsic);
446 conf (entry, intrinsic);
448 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
450 conf (external, subroutine);
451 conf (external, function);
454 conf (allocatable, pointer);
455 conf_std (allocatable, dummy, GFC_STD_F2003);
456 conf_std (allocatable, function, GFC_STD_F2003);
457 conf_std (allocatable, result, GFC_STD_F2003);
458 conf (elemental, recursive);
460 conf (in_common, dummy);
461 conf (in_common, allocatable);
462 conf (in_common, result);
464 conf (dummy, result);
466 conf (in_equivalence, use_assoc);
467 conf (in_equivalence, dummy);
468 conf (in_equivalence, target);
469 conf (in_equivalence, pointer);
470 conf (in_equivalence, function);
471 conf (in_equivalence, result);
472 conf (in_equivalence, entry);
473 conf (in_equivalence, allocatable);
474 conf (in_equivalence, threadprivate);
476 conf (in_namelist, pointer);
477 conf (in_namelist, allocatable);
479 conf (entry, result);
481 conf (function, subroutine);
483 if (!function && !subroutine)
484 conf (is_bind_c, dummy);
486 conf (is_bind_c, cray_pointer);
487 conf (is_bind_c, cray_pointee);
488 conf (is_bind_c, allocatable);
489 conf (is_bind_c, elemental);
491 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
492 Parameter conflict caught below. Also, value cannot be specified
493 for a dummy procedure. */
495 /* Cray pointer/pointee conflicts. */
496 conf (cray_pointer, cray_pointee);
497 conf (cray_pointer, dimension);
498 conf (cray_pointer, pointer);
499 conf (cray_pointer, target);
500 conf (cray_pointer, allocatable);
501 conf (cray_pointer, external);
502 conf (cray_pointer, intrinsic);
503 conf (cray_pointer, in_namelist);
504 conf (cray_pointer, function);
505 conf (cray_pointer, subroutine);
506 conf (cray_pointer, entry);
508 conf (cray_pointee, allocatable);
509 conf (cray_pointee, intent);
510 conf (cray_pointee, optional);
511 conf (cray_pointee, dummy);
512 conf (cray_pointee, target);
513 conf (cray_pointee, intrinsic);
514 conf (cray_pointee, pointer);
515 conf (cray_pointee, entry);
516 conf (cray_pointee, in_common);
517 conf (cray_pointee, in_equivalence);
518 conf (cray_pointee, threadprivate);
521 conf (data, function);
523 conf (data, allocatable);
524 conf (data, use_assoc);
526 conf (value, pointer)
527 conf (value, allocatable)
528 conf (value, subroutine)
529 conf (value, function)
530 conf (value, volatile_)
531 conf (value, dimension)
532 conf (value, external)
535 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
538 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
542 conf (is_protected, intrinsic)
543 conf (is_protected, external)
544 conf (is_protected, in_common)
546 conf (volatile_, intrinsic)
547 conf (volatile_, external)
549 if (attr->volatile_ && attr->intent == INTENT_IN)
556 conf (procedure, allocatable)
557 conf (procedure, dimension)
558 conf (procedure, intrinsic)
559 conf (procedure, is_protected)
560 conf (procedure, target)
561 conf (procedure, value)
562 conf (procedure, volatile_)
563 conf (procedure, entry)
565 a1 = gfc_code2string (flavors, attr->flavor);
567 if (attr->in_namelist
568 && attr->flavor != FL_VARIABLE
569 && attr->flavor != FL_PROCEDURE
570 && attr->flavor != FL_UNKNOWN)
576 switch (attr->flavor)
586 conf2 (is_protected);
596 conf2 (threadprivate);
598 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
600 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
601 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
608 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
619 /* Conflicts with INTENT will be checked at resolution stage,
620 see "resolve_fl_procedure". */
622 if (attr->subroutine)
630 conf2 (threadprivate);
635 case PROC_ST_FUNCTION:
647 conf2 (threadprivate);
667 conf2 (threadprivate);
669 if (attr->intent != INTENT_UNKNOWN)
685 conf2 (is_protected);
691 conf2 (threadprivate);
704 gfc_error ("%s attribute conflicts with %s attribute at %L",
707 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
708 a1, a2, name, where);
715 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
716 "with %s attribute at %L", a1, a2,
721 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
722 "with %s attribute in '%s' at %L",
723 a1, a2, name, where);
732 /* Mark a symbol as referenced. */
735 gfc_set_sym_referenced (gfc_symbol *sym)
738 if (sym->attr.referenced)
741 sym->attr.referenced = 1;
743 /* Remember which order dummy variables are accessed in. */
745 sym->dummy_order = next_dummy_order++;
749 /* Common subroutine called by attribute changing subroutines in order
750 to prevent them from changing a symbol that has been
751 use-associated. Returns zero if it is OK to change the symbol,
755 check_used (symbol_attribute *attr, const char *name, locus *where)
758 if (attr->use_assoc == 0)
762 where = &gfc_current_locus;
765 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
768 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
775 /* Generate an error because of a duplicate attribute. */
778 duplicate_attr (const char *attr, locus *where)
782 where = &gfc_current_locus;
784 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
788 /* Called from decl.c (attr_decl1) to check attributes, when declared
792 gfc_add_attribute (symbol_attribute *attr, locus *where)
795 if (check_used (attr, NULL, where))
798 return check_conflict (attr, NULL, where);
802 gfc_add_allocatable (symbol_attribute *attr, locus *where)
805 if (check_used (attr, NULL, where))
808 if (attr->allocatable)
810 duplicate_attr ("ALLOCATABLE", where);
814 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
815 && gfc_find_state (COMP_INTERFACE) == FAILURE)
817 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
822 attr->allocatable = 1;
823 return check_conflict (attr, NULL, where);
828 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
831 if (check_used (attr, name, where))
836 duplicate_attr ("DIMENSION", where);
840 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
841 && gfc_find_state (COMP_INTERFACE) == FAILURE)
843 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
844 "at %L", name, where);
849 return check_conflict (attr, name, where);
854 gfc_add_external (symbol_attribute *attr, locus *where)
857 if (check_used (attr, NULL, where))
862 duplicate_attr ("EXTERNAL", where);
866 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
869 attr->proc_pointer = 1;
874 return check_conflict (attr, NULL, where);
879 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
882 if (check_used (attr, NULL, where))
887 duplicate_attr ("INTRINSIC", where);
893 return check_conflict (attr, NULL, where);
898 gfc_add_optional (symbol_attribute *attr, locus *where)
901 if (check_used (attr, NULL, where))
906 duplicate_attr ("OPTIONAL", where);
911 return check_conflict (attr, NULL, where);
916 gfc_add_pointer (symbol_attribute *attr, locus *where)
919 if (check_used (attr, NULL, where))
922 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
923 && gfc_find_state (COMP_INTERFACE) == FAILURE))
925 duplicate_attr ("POINTER", where);
929 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
930 || (attr->if_source == IFSRC_IFBODY
931 && gfc_find_state (COMP_INTERFACE) == FAILURE))
932 attr->proc_pointer = 1;
936 return check_conflict (attr, NULL, where);
941 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
944 if (check_used (attr, NULL, where))
947 attr->cray_pointer = 1;
948 return check_conflict (attr, NULL, where);
953 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
956 if (check_used (attr, NULL, where))
959 if (attr->cray_pointee)
961 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
962 " statements", where);
966 attr->cray_pointee = 1;
967 return check_conflict (attr, NULL, where);
972 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
974 if (check_used (attr, name, where))
977 if (attr->is_protected)
979 if (gfc_notify_std (GFC_STD_LEGACY,
980 "Duplicate PROTECTED attribute specified at %L",
986 attr->is_protected = 1;
987 return check_conflict (attr, name, where);
992 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
995 if (check_used (attr, name, where))
999 return check_conflict (attr, name, where);
1004 gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
1007 if (check_used (attr, name, where))
1010 if (gfc_pure (NULL))
1013 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1018 if (attr->save == SAVE_EXPLICIT)
1020 if (gfc_notify_std (GFC_STD_LEGACY,
1021 "Duplicate SAVE attribute specified at %L",
1027 attr->save = SAVE_EXPLICIT;
1028 return check_conflict (attr, name, where);
1033 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1036 if (check_used (attr, name, where))
1041 if (gfc_notify_std (GFC_STD_LEGACY,
1042 "Duplicate VALUE attribute specified at %L",
1049 return check_conflict (attr, name, where);
1054 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1056 /* No check_used needed as 11.2.1 of the F2003 standard allows
1057 that the local identifier made accessible by a use statement can be
1058 given a VOLATILE attribute. */
1060 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1061 if (gfc_notify_std (GFC_STD_LEGACY,
1062 "Duplicate VOLATILE attribute specified at %L", where)
1066 attr->volatile_ = 1;
1067 attr->volatile_ns = gfc_current_ns;
1068 return check_conflict (attr, name, where);
1073 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1076 if (check_used (attr, name, where))
1079 if (attr->threadprivate)
1081 duplicate_attr ("THREADPRIVATE", where);
1085 attr->threadprivate = 1;
1086 return check_conflict (attr, name, where);
1091 gfc_add_target (symbol_attribute *attr, locus *where)
1094 if (check_used (attr, NULL, where))
1099 duplicate_attr ("TARGET", where);
1104 return check_conflict (attr, NULL, where);
1109 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1112 if (check_used (attr, name, where))
1115 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1117 return check_conflict (attr, name, where);
1122 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1125 if (check_used (attr, name, where))
1128 /* Duplicate attribute already checked for. */
1129 attr->in_common = 1;
1130 if (check_conflict (attr, name, where) == FAILURE)
1133 if (attr->flavor == FL_VARIABLE)
1136 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1141 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1144 /* Duplicate attribute already checked for. */
1145 attr->in_equivalence = 1;
1146 if (check_conflict (attr, name, where) == FAILURE)
1149 if (attr->flavor == FL_VARIABLE)
1152 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1157 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1160 if (check_used (attr, name, where))
1164 return check_conflict (attr, name, where);
1169 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1172 attr->in_namelist = 1;
1173 return check_conflict (attr, name, where);
1178 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1181 if (check_used (attr, name, where))
1185 return check_conflict (attr, name, where);
1190 gfc_add_elemental (symbol_attribute *attr, locus *where)
1193 if (check_used (attr, NULL, where))
1196 if (attr->elemental)
1198 duplicate_attr ("ELEMENTAL", where);
1202 attr->elemental = 1;
1203 return check_conflict (attr, NULL, where);
1208 gfc_add_pure (symbol_attribute *attr, locus *where)
1211 if (check_used (attr, NULL, where))
1216 duplicate_attr ("PURE", where);
1221 return check_conflict (attr, NULL, where);
1226 gfc_add_recursive (symbol_attribute *attr, locus *where)
1229 if (check_used (attr, NULL, where))
1232 if (attr->recursive)
1234 duplicate_attr ("RECURSIVE", where);
1238 attr->recursive = 1;
1239 return check_conflict (attr, NULL, where);
1244 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1247 if (check_used (attr, name, where))
1252 duplicate_attr ("ENTRY", where);
1257 return check_conflict (attr, name, where);
1262 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1265 if (attr->flavor != FL_PROCEDURE
1266 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1270 return check_conflict (attr, name, where);
1275 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1278 if (attr->flavor != FL_PROCEDURE
1279 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1282 attr->subroutine = 1;
1283 return check_conflict (attr, name, where);
1288 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1291 if (attr->flavor != FL_PROCEDURE
1292 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1296 return check_conflict (attr, name, where);
1301 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1304 if (check_used (attr, NULL, where))
1307 if (attr->flavor != FL_PROCEDURE
1308 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1311 if (attr->procedure)
1313 duplicate_attr ("PROCEDURE", where);
1317 attr->procedure = 1;
1319 return check_conflict (attr, NULL, where);
1324 gfc_add_abstract (symbol_attribute* attr, locus* where)
1328 duplicate_attr ("ABSTRACT", where);
1337 /* Flavors are special because some flavors are not what Fortran
1338 considers attributes and can be reaffirmed multiple times. */
1341 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1345 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1346 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1347 || f == FL_NAMELIST) && check_used (attr, name, where))
1350 if (attr->flavor == f && f == FL_VARIABLE)
1353 if (attr->flavor != FL_UNKNOWN)
1356 where = &gfc_current_locus;
1359 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1360 gfc_code2string (flavors, attr->flavor), name,
1361 gfc_code2string (flavors, f), where);
1363 gfc_error ("%s attribute conflicts with %s attribute at %L",
1364 gfc_code2string (flavors, attr->flavor),
1365 gfc_code2string (flavors, f), where);
1372 return check_conflict (attr, name, where);
1377 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1378 const char *name, locus *where)
1381 if (check_used (attr, name, where))
1384 if (attr->flavor != FL_PROCEDURE
1385 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1389 where = &gfc_current_locus;
1391 if (attr->proc != PROC_UNKNOWN)
1393 gfc_error ("%s procedure at %L is already declared as %s procedure",
1394 gfc_code2string (procedures, t), where,
1395 gfc_code2string (procedures, attr->proc));
1402 /* Statement functions are always scalar and functions. */
1403 if (t == PROC_ST_FUNCTION
1404 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1405 || attr->dimension))
1408 return check_conflict (attr, name, where);
1413 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1416 if (check_used (attr, NULL, where))
1419 if (attr->intent == INTENT_UNKNOWN)
1421 attr->intent = intent;
1422 return check_conflict (attr, NULL, where);
1426 where = &gfc_current_locus;
1428 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1429 gfc_intent_string (attr->intent),
1430 gfc_intent_string (intent), where);
1436 /* No checks for use-association in public and private statements. */
1439 gfc_add_access (symbol_attribute *attr, gfc_access access,
1440 const char *name, locus *where)
1443 if (attr->access == ACCESS_UNKNOWN)
1445 attr->access = access;
1446 return check_conflict (attr, name, where);
1450 where = &gfc_current_locus;
1451 gfc_error ("ACCESS specification at %L was already specified", where);
1457 /* Set the is_bind_c field for the given symbol_attribute. */
1460 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1461 int is_proc_lang_bind_spec)
1464 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1465 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1466 "variables or common blocks", where);
1467 else if (attr->is_bind_c)
1468 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1470 attr->is_bind_c = 1;
1473 where = &gfc_current_locus;
1475 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1479 return check_conflict (attr, name, where);
1483 /* Set the extension field for the given symbol_attribute. */
1486 gfc_add_extension (symbol_attribute *attr, locus *where)
1489 where = &gfc_current_locus;
1491 if (attr->extension)
1492 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1494 attr->extension = 1;
1496 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
1505 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1506 gfc_formal_arglist * formal, locus *where)
1509 if (check_used (&sym->attr, sym->name, where))
1513 where = &gfc_current_locus;
1515 if (sym->attr.if_source != IFSRC_UNKNOWN
1516 && sym->attr.if_source != IFSRC_DECL)
1518 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1523 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1525 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1526 "body", sym->name, where);
1530 sym->formal = formal;
1531 sym->attr.if_source = source;
1537 /* Add a type to a symbol. */
1540 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1545 where = &gfc_current_locus;
1547 if (sym->ts.type != BT_UNKNOWN)
1549 const char *msg = "Symbol '%s' at %L already has basic type of %s";
1550 if (!(sym->ts.type == ts->type
1551 && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
1552 || gfc_notification_std (GFC_STD_GNU) == ERROR
1555 gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1558 if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
1559 gfc_basic_typename (sym->ts.type)) == FAILURE)
1561 if (gfc_option.warn_surprising)
1562 gfc_warning (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1565 flavor = sym->attr.flavor;
1567 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1568 || flavor == FL_LABEL
1569 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1570 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1572 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1581 /* Clears all attributes. */
1584 gfc_clear_attr (symbol_attribute *attr)
1586 memset (attr, 0, sizeof (symbol_attribute));
1590 /* Check for missing attributes in the new symbol. Currently does
1591 nothing, but it's not clear that it is unnecessary yet. */
1594 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1595 locus *where ATTRIBUTE_UNUSED)
1602 /* Copy an attribute to a symbol attribute, bit by bit. Some
1603 attributes have a lot of side-effects but cannot be present given
1604 where we are called from, so we ignore some bits. */
1607 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1609 int is_proc_lang_bind_spec;
1611 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1614 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1616 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1618 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1620 if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1622 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1624 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1626 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1628 if (src->threadprivate
1629 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1631 if (src->target && gfc_add_target (dest, where) == FAILURE)
1633 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1635 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1640 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1643 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1646 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1648 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1650 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1653 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1655 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1657 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1659 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1662 if (src->flavor != FL_UNKNOWN
1663 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1666 if (src->intent != INTENT_UNKNOWN
1667 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1670 if (src->access != ACCESS_UNKNOWN
1671 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1674 if (gfc_missing_attr (dest, where) == FAILURE)
1677 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1679 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1682 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1684 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1688 if (src->is_c_interop)
1689 dest->is_c_interop = 1;
1693 if (src->external && gfc_add_external (dest, where) == FAILURE)
1695 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1697 if (src->proc_pointer)
1698 dest->proc_pointer = 1;
1707 /************** Component name management ************/
1709 /* Component names of a derived type form their own little namespaces
1710 that are separate from all other spaces. The space is composed of
1711 a singly linked list of gfc_component structures whose head is
1712 located in the parent symbol. */
1715 /* Add a component name to a symbol. The call fails if the name is
1716 already present. On success, the component pointer is modified to
1717 point to the additional component structure. */
1720 gfc_add_component (gfc_symbol *sym, const char *name,
1721 gfc_component **component)
1723 gfc_component *p, *tail;
1727 for (p = sym->components; p; p = p->next)
1729 if (strcmp (p->name, name) == 0)
1731 gfc_error ("Component '%s' at %C already declared at %L",
1739 if (sym->attr.extension
1740 && gfc_find_component (sym->components->ts.derived, name, true, true))
1742 gfc_error ("Component '%s' at %C already in the parent type "
1743 "at %L", name, &sym->components->ts.derived->declared_at);
1747 /* Allocate a new component. */
1748 p = gfc_get_component ();
1751 sym->components = p;
1755 p->name = gfc_get_string (name);
1756 p->loc = gfc_current_locus;
1763 /* Recursive function to switch derived types of all symbol in a
1767 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1775 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1776 sym->ts.derived = to;
1778 switch_types (st->left, from, to);
1779 switch_types (st->right, from, to);
1783 /* This subroutine is called when a derived type is used in order to
1784 make the final determination about which version to use. The
1785 standard requires that a type be defined before it is 'used', but
1786 such types can appear in IMPLICIT statements before the actual
1787 definition. 'Using' in this context means declaring a variable to
1788 be that type or using the type constructor.
1790 If a type is used and the components haven't been defined, then we
1791 have to have a derived type in a parent unit. We find the node in
1792 the other namespace and point the symtree node in this namespace to
1793 that node. Further reference to this name point to the correct
1794 node. If we can't find the node in a parent namespace, then we have
1797 This subroutine takes a pointer to a symbol node and returns a
1798 pointer to the translated node or NULL for an error. Usually there
1799 is no translation and we return the node we were passed. */
1802 gfc_use_derived (gfc_symbol *sym)
1809 if (sym->components != NULL || sym->attr.zero_comp)
1810 return sym; /* Already defined. */
1812 if (sym->ns->parent == NULL)
1815 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1817 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1821 if (s == NULL || s->attr.flavor != FL_DERIVED)
1824 /* Get rid of symbol sym, translating all references to s. */
1825 for (i = 0; i < GFC_LETTERS; i++)
1827 t = &sym->ns->default_type[i];
1828 if (t->derived == sym)
1832 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1837 /* Unlink from list of modified symbols. */
1838 gfc_commit_symbol (sym);
1840 switch_types (sym->ns->sym_root, sym, s);
1842 /* TODO: Also have to replace sym -> s in other lists like
1843 namelists, common lists and interface lists. */
1844 gfc_free_symbol (sym);
1849 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1855 /* Given a derived type node and a component name, try to locate the
1856 component structure. Returns the NULL pointer if the component is
1857 not found or the components are private. If noaccess is set, no access
1861 gfc_find_component (gfc_symbol *sym, const char *name,
1862 bool noaccess, bool silent)
1869 sym = gfc_use_derived (sym);
1874 for (p = sym->components; p; p = p->next)
1875 if (strcmp (p->name, name) == 0)
1879 && sym->attr.extension
1880 && sym->components->ts.type == BT_DERIVED)
1882 p = gfc_find_component (sym->components->ts.derived, name,
1884 /* Do not overwrite the error. */
1889 if (p == NULL && !silent)
1890 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1893 else if (sym->attr.use_assoc && !noaccess)
1895 if (p->attr.access == ACCESS_PRIVATE)
1898 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1903 /* If there were components given and all components are private, error
1904 out at this place. */
1905 if (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
1908 gfc_error ("All components of '%s' are PRIVATE in structure"
1909 " constructor at %C", sym->name);
1918 /* Given a symbol, free all of the component structures and everything
1922 free_components (gfc_component *p)
1930 gfc_free_array_spec (p->as);
1931 gfc_free_expr (p->initializer);
1938 /******************** Statement label management ********************/
1940 /* Comparison function for statement labels, used for managing the
1944 compare_st_labels (void *a1, void *b1)
1946 int a = ((gfc_st_label *) a1)->value;
1947 int b = ((gfc_st_label *) b1)->value;
1953 /* Free a single gfc_st_label structure, making sure the tree is not
1954 messed up. This function is called only when some parse error
1958 gfc_free_st_label (gfc_st_label *label)
1964 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
1966 if (label->format != NULL)
1967 gfc_free_expr (label->format);
1973 /* Free a whole tree of gfc_st_label structures. */
1976 free_st_labels (gfc_st_label *label)
1982 free_st_labels (label->left);
1983 free_st_labels (label->right);
1985 if (label->format != NULL)
1986 gfc_free_expr (label->format);
1991 /* Given a label number, search for and return a pointer to the label
1992 structure, creating it if it does not exist. */
1995 gfc_get_st_label (int labelno)
1999 /* First see if the label is already in this namespace. */
2000 lp = gfc_current_ns->st_labels;
2003 if (lp->value == labelno)
2006 if (lp->value < labelno)
2012 lp = XCNEW (gfc_st_label);
2014 lp->value = labelno;
2015 lp->defined = ST_LABEL_UNKNOWN;
2016 lp->referenced = ST_LABEL_UNKNOWN;
2018 gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
2024 /* Called when a statement with a statement label is about to be
2025 accepted. We add the label to the list of the current namespace,
2026 making sure it hasn't been defined previously and referenced
2030 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2034 labelno = lp->value;
2036 if (lp->defined != ST_LABEL_UNKNOWN)
2037 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2038 &lp->where, label_locus);
2041 lp->where = *label_locus;
2045 case ST_LABEL_FORMAT:
2046 if (lp->referenced == ST_LABEL_TARGET)
2047 gfc_error ("Label %d at %C already referenced as branch target",
2050 lp->defined = ST_LABEL_FORMAT;
2054 case ST_LABEL_TARGET:
2055 if (lp->referenced == ST_LABEL_FORMAT)
2056 gfc_error ("Label %d at %C already referenced as a format label",
2059 lp->defined = ST_LABEL_TARGET;
2064 lp->defined = ST_LABEL_BAD_TARGET;
2065 lp->referenced = ST_LABEL_BAD_TARGET;
2071 /* Reference a label. Given a label and its type, see if that
2072 reference is consistent with what is known about that label,
2073 updating the unknown state. Returns FAILURE if something goes
2077 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2079 gfc_sl_type label_type;
2086 labelno = lp->value;
2088 if (lp->defined != ST_LABEL_UNKNOWN)
2089 label_type = lp->defined;
2092 label_type = lp->referenced;
2093 lp->where = gfc_current_locus;
2096 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2098 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2103 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2104 && type == ST_LABEL_FORMAT)
2106 gfc_error ("Label %d at %C previously used as branch target", labelno);
2111 lp->referenced = type;
2119 /*******A helper function for creating new expressions*************/
2123 gfc_lval_expr_from_sym (gfc_symbol *sym)
2126 lval = gfc_get_expr ();
2127 lval->expr_type = EXPR_VARIABLE;
2128 lval->where = sym->declared_at;
2130 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2132 /* It will always be a full array. */
2133 lval->rank = sym->as ? sym->as->rank : 0;
2136 lval->ref = gfc_get_ref ();
2137 lval->ref->type = REF_ARRAY;
2138 lval->ref->u.ar.type = AR_FULL;
2139 lval->ref->u.ar.dimen = lval->rank;
2140 lval->ref->u.ar.where = sym->declared_at;
2141 lval->ref->u.ar.as = sym->as;
2148 /************** Symbol table management subroutines ****************/
2150 /* Basic details: Fortran 95 requires a potentially unlimited number
2151 of distinct namespaces when compiling a program unit. This case
2152 occurs during a compilation of internal subprograms because all of
2153 the internal subprograms must be read before we can start
2154 generating code for the host.
2156 Given the tricky nature of the Fortran grammar, we must be able to
2157 undo changes made to a symbol table if the current interpretation
2158 of a statement is found to be incorrect. Whenever a symbol is
2159 looked up, we make a copy of it and link to it. All of these
2160 symbols are kept in a singly linked list so that we can commit or
2161 undo the changes at a later time.
2163 A symtree may point to a symbol node outside of its namespace. In
2164 this case, that symbol has been used as a host associated variable
2165 at some previous time. */
2167 /* Allocate a new namespace structure. Copies the implicit types from
2168 PARENT if PARENT_TYPES is set. */
2171 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2175 gfc_intrinsic_op in;
2178 ns = XCNEW (gfc_namespace);
2179 ns->sym_root = NULL;
2180 ns->uop_root = NULL;
2181 ns->finalizers = NULL;
2182 ns->default_access = ACCESS_UNKNOWN;
2183 ns->parent = parent;
2185 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2186 ns->operator_access[in] = ACCESS_UNKNOWN;
2188 /* Initialize default implicit types. */
2189 for (i = 'a'; i <= 'z'; i++)
2191 ns->set_flag[i - 'a'] = 0;
2192 ts = &ns->default_type[i - 'a'];
2194 if (parent_types && ns->parent != NULL)
2196 /* Copy parent settings. */
2197 *ts = ns->parent->default_type[i - 'a'];
2201 if (gfc_option.flag_implicit_none != 0)
2207 if ('i' <= i && i <= 'n')
2209 ts->type = BT_INTEGER;
2210 ts->kind = gfc_default_integer_kind;
2215 ts->kind = gfc_default_real_kind;
2225 /* Comparison function for symtree nodes. */
2228 compare_symtree (void *_st1, void *_st2)
2230 gfc_symtree *st1, *st2;
2232 st1 = (gfc_symtree *) _st1;
2233 st2 = (gfc_symtree *) _st2;
2235 return strcmp (st1->name, st2->name);
2239 /* Allocate a new symtree node and associate it with the new symbol. */
2242 gfc_new_symtree (gfc_symtree **root, const char *name)
2246 st = XCNEW (gfc_symtree);
2247 st->name = gfc_get_string (name);
2248 st->typebound = NULL;
2250 gfc_insert_bbt (root, st, compare_symtree);
2255 /* Delete a symbol from the tree. Does not free the symbol itself! */
2258 gfc_delete_symtree (gfc_symtree **root, const char *name)
2260 gfc_symtree st, *st0;
2262 st0 = gfc_find_symtree (*root, name);
2264 st.name = gfc_get_string (name);
2265 gfc_delete_bbt (root, &st, compare_symtree);
2271 /* Given a root symtree node and a name, try to find the symbol within
2272 the namespace. Returns NULL if the symbol is not found. */
2275 gfc_find_symtree (gfc_symtree *st, const char *name)
2281 c = strcmp (name, st->name);
2285 st = (c < 0) ? st->left : st->right;
2292 /* Return a symtree node with a name that is guaranteed to be unique
2293 within the namespace and corresponds to an illegal fortran name. */
2296 gfc_get_unique_symtree (gfc_namespace *ns)
2298 char name[GFC_MAX_SYMBOL_LEN + 1];
2299 static int serial = 0;
2301 sprintf (name, "@%d", serial++);
2302 return gfc_new_symtree (&ns->sym_root, name);
2306 /* Given a name find a user operator node, creating it if it doesn't
2307 exist. These are much simpler than symbols because they can't be
2308 ambiguous with one another. */
2311 gfc_get_uop (const char *name)
2316 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2320 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2322 uop = st->n.uop = XCNEW (gfc_user_op);
2323 uop->name = gfc_get_string (name);
2324 uop->access = ACCESS_UNKNOWN;
2325 uop->ns = gfc_current_ns;
2331 /* Given a name find the user operator node. Returns NULL if it does
2335 gfc_find_uop (const char *name, gfc_namespace *ns)
2340 ns = gfc_current_ns;
2342 st = gfc_find_symtree (ns->uop_root, name);
2343 return (st == NULL) ? NULL : st->n.uop;
2347 /* Remove a gfc_symbol structure and everything it points to. */
2350 gfc_free_symbol (gfc_symbol *sym)
2356 gfc_free_array_spec (sym->as);
2358 free_components (sym->components);
2360 gfc_free_expr (sym->value);
2362 gfc_free_namelist (sym->namelist);
2364 gfc_free_namespace (sym->formal_ns);
2366 if (!sym->attr.generic_copy)
2367 gfc_free_interface (sym->generic);
2369 gfc_free_formal_arglist (sym->formal);
2371 gfc_free_namespace (sym->f2k_derived);
2377 /* Allocate and initialize a new symbol node. */
2380 gfc_new_symbol (const char *name, gfc_namespace *ns)
2384 p = XCNEW (gfc_symbol);
2386 gfc_clear_ts (&p->ts);
2387 gfc_clear_attr (&p->attr);
2390 p->declared_at = gfc_current_locus;
2392 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2393 gfc_internal_error ("new_symbol(): Symbol name too long");
2395 p->name = gfc_get_string (name);
2397 /* Make sure flags for symbol being C bound are clear initially. */
2398 p->attr.is_bind_c = 0;
2399 p->attr.is_iso_c = 0;
2400 /* Make sure the binding label field has a Nul char to start. */
2401 p->binding_label[0] = '\0';
2403 /* Clear the ptrs we may need. */
2404 p->common_block = NULL;
2405 p->f2k_derived = NULL;
2411 /* Generate an error if a symbol is ambiguous. */
2414 ambiguous_symbol (const char *name, gfc_symtree *st)
2417 if (st->n.sym->module)
2418 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2419 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2421 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2422 "from current program unit", name, st->n.sym->name);
2426 /* Search for a symtree starting in the current namespace, resorting to
2427 any parent namespaces if requested by a nonzero parent_flag.
2428 Returns nonzero if the name is ambiguous. */
2431 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2432 gfc_symtree **result)
2437 ns = gfc_current_ns;
2441 st = gfc_find_symtree (ns->sym_root, name);
2445 /* Ambiguous generic interfaces are permitted, as long
2446 as the specific interfaces are different. */
2447 if (st->ambiguous && !st->n.sym->attr.generic)
2449 ambiguous_symbol (name, st);
2468 /* Same, but returns the symbol instead. */
2471 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2472 gfc_symbol **result)
2477 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2482 *result = st->n.sym;
2488 /* Save symbol with the information necessary to back it out. */
2491 save_symbol_data (gfc_symbol *sym)
2494 if (sym->gfc_new || sym->old_symbol != NULL)
2497 sym->old_symbol = XCNEW (gfc_symbol);
2498 *(sym->old_symbol) = *sym;
2500 sym->tlink = changed_syms;
2505 /* Given a name, find a symbol, or create it if it does not exist yet
2506 in the current namespace. If the symbol is found we make sure that
2509 The integer return code indicates
2511 1 The symbol name was ambiguous
2512 2 The name meant to be established was already host associated.
2514 So if the return value is nonzero, then an error was issued. */
2517 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
2522 /* This doesn't usually happen during resolution. */
2524 ns = gfc_current_ns;
2526 /* Try to find the symbol in ns. */
2527 st = gfc_find_symtree (ns->sym_root, name);
2531 /* If not there, create a new symbol. */
2532 p = gfc_new_symbol (name, ns);
2534 /* Add to the list of tentative symbols. */
2535 p->old_symbol = NULL;
2536 p->tlink = changed_syms;
2541 st = gfc_new_symtree (&ns->sym_root, name);
2548 /* Make sure the existing symbol is OK. Ambiguous
2549 generic interfaces are permitted, as long as the
2550 specific interfaces are different. */
2551 if (st->ambiguous && !st->n.sym->attr.generic)
2553 ambiguous_symbol (name, st);
2559 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2561 && ns->proc_name->attr.if_source == IFSRC_IFBODY
2562 && (ns->has_import_set || p->attr.imported)))
2564 /* Symbol is from another namespace. */
2565 gfc_error ("Symbol '%s' at %C has already been host associated",
2572 /* Copy in case this symbol is changed. */
2573 save_symbol_data (p);
2582 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2587 i = gfc_get_sym_tree (name, ns, &st);
2592 *result = st->n.sym;
2599 /* Subroutine that searches for a symbol, creating it if it doesn't
2600 exist, but tries to host-associate the symbol if possible. */
2603 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2608 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2611 save_symbol_data (st->n.sym);
2616 if (gfc_current_ns->parent != NULL)
2618 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2629 return gfc_get_sym_tree (name, gfc_current_ns, result);
2634 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2639 i = gfc_get_ha_sym_tree (name, &st);
2642 *result = st->n.sym;
2649 /* Return true if both symbols could refer to the same data object. Does
2650 not take account of aliasing due to equivalence statements. */
2653 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2655 /* Aliasing isn't possible if the symbols have different base types. */
2656 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2659 /* Pointers can point to other pointers, target objects and allocatable
2660 objects. Two allocatable objects cannot share the same storage. */
2661 if (lsym->attr.pointer
2662 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2664 if (lsym->attr.target && rsym->attr.pointer)
2666 if (lsym->attr.allocatable && rsym->attr.pointer)
2673 /* Undoes all the changes made to symbols in the current statement.
2674 This subroutine is made simpler due to the fact that attributes are
2675 never removed once added. */
2678 gfc_undo_symbols (void)
2680 gfc_symbol *p, *q, *old;
2682 for (p = changed_syms; p; p = q)
2688 /* Symbol was new. */
2689 if (p->attr.in_common && p->common_block->head)
2691 /* If the symbol was added to any common block, it
2692 needs to be removed to stop the resolver looking
2693 for a (possibly) dead symbol. */
2695 if (p->common_block->head == p)
2696 p->common_block->head = p->common_next;
2699 gfc_symbol *cparent, *csym;
2701 cparent = p->common_block->head;
2702 csym = cparent->common_next;
2707 csym = csym->common_next;
2710 gcc_assert(cparent->common_next == p);
2712 cparent->common_next = csym->common_next;
2716 gfc_delete_symtree (&p->ns->sym_root, p->name);
2720 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2722 gfc_free_symbol (p);
2726 /* Restore previous state of symbol. Just copy simple stuff. */
2728 old = p->old_symbol;
2730 p->ts.type = old->ts.type;
2731 p->ts.kind = old->ts.kind;
2733 p->attr = old->attr;
2735 if (p->value != old->value)
2737 gfc_free_expr (old->value);
2741 if (p->as != old->as)
2744 gfc_free_array_spec (p->as);
2748 p->generic = old->generic;
2749 p->component_access = old->component_access;
2751 if (p->namelist != NULL && old->namelist == NULL)
2753 gfc_free_namelist (p->namelist);
2758 if (p->namelist_tail != old->namelist_tail)
2760 gfc_free_namelist (old->namelist_tail);
2761 old->namelist_tail->next = NULL;
2765 p->namelist_tail = old->namelist_tail;
2767 if (p->formal != old->formal)
2769 gfc_free_formal_arglist (p->formal);
2770 p->formal = old->formal;
2773 gfc_free (p->old_symbol);
2774 p->old_symbol = NULL;
2778 changed_syms = NULL;
2782 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2783 components of old_symbol that might need deallocation are the "allocatables"
2784 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2785 namelist_tail. In case these differ between old_symbol and sym, it's just
2786 because sym->namelist has gotten a few more items. */
2789 free_old_symbol (gfc_symbol *sym)
2792 if (sym->old_symbol == NULL)
2795 if (sym->old_symbol->as != sym->as)
2796 gfc_free_array_spec (sym->old_symbol->as);
2798 if (sym->old_symbol->value != sym->value)
2799 gfc_free_expr (sym->old_symbol->value);
2801 if (sym->old_symbol->formal != sym->formal)
2802 gfc_free_formal_arglist (sym->old_symbol->formal);
2804 gfc_free (sym->old_symbol);
2805 sym->old_symbol = NULL;
2809 /* Makes the changes made in the current statement permanent-- gets
2810 rid of undo information. */
2813 gfc_commit_symbols (void)
2817 for (p = changed_syms; p; p = q)
2823 free_old_symbol (p);
2825 changed_syms = NULL;
2829 /* Makes the changes made in one symbol permanent -- gets rid of undo
2833 gfc_commit_symbol (gfc_symbol *sym)
2837 if (changed_syms == sym)
2838 changed_syms = sym->tlink;
2841 for (p = changed_syms; p; p = p->tlink)
2842 if (p->tlink == sym)
2844 p->tlink = sym->tlink;
2853 free_old_symbol (sym);
2857 /* Recursive function that deletes an entire tree and all the common
2858 head structures it points to. */
2861 free_common_tree (gfc_symtree * common_tree)
2863 if (common_tree == NULL)
2866 free_common_tree (common_tree->left);
2867 free_common_tree (common_tree->right);
2869 gfc_free (common_tree);
2873 /* Recursive function that deletes an entire tree and all the user
2874 operator nodes that it contains. */
2877 free_uop_tree (gfc_symtree *uop_tree)
2880 if (uop_tree == NULL)
2883 free_uop_tree (uop_tree->left);
2884 free_uop_tree (uop_tree->right);
2886 gfc_free_interface (uop_tree->n.uop->op);
2888 gfc_free (uop_tree->n.uop);
2889 gfc_free (uop_tree);
2893 /* Recursive function that deletes an entire tree and all the symbols
2894 that it contains. */
2897 free_sym_tree (gfc_symtree *sym_tree)
2902 if (sym_tree == NULL)
2905 free_sym_tree (sym_tree->left);
2906 free_sym_tree (sym_tree->right);
2908 sym = sym_tree->n.sym;
2912 gfc_internal_error ("free_sym_tree(): Negative refs");
2914 if (sym->formal_ns != NULL && sym->refs == 1)
2916 /* As formal_ns contains a reference to sym, delete formal_ns just
2917 before the deletion of sym. */
2918 ns = sym->formal_ns;
2919 sym->formal_ns = NULL;
2920 gfc_free_namespace (ns);
2922 else if (sym->refs == 0)
2924 /* Go ahead and delete the symbol. */
2925 gfc_free_symbol (sym);
2928 gfc_free (sym_tree);
2932 /* Free the derived type list. */
2935 gfc_free_dt_list (void)
2937 gfc_dt_list *dt, *n;
2939 for (dt = gfc_derived_types; dt; dt = n)
2945 gfc_derived_types = NULL;
2949 /* Free the gfc_equiv_info's. */
2952 gfc_free_equiv_infos (gfc_equiv_info *s)
2956 gfc_free_equiv_infos (s->next);
2961 /* Free the gfc_equiv_lists. */
2964 gfc_free_equiv_lists (gfc_equiv_list *l)
2968 gfc_free_equiv_lists (l->next);
2969 gfc_free_equiv_infos (l->equiv);
2974 /* Free a finalizer procedure list. */
2977 gfc_free_finalizer (gfc_finalizer* el)
2983 --el->proc_sym->refs;
2984 if (!el->proc_sym->refs)
2985 gfc_free_symbol (el->proc_sym);
2993 gfc_free_finalizer_list (gfc_finalizer* list)
2997 gfc_finalizer* current = list;
2999 gfc_free_finalizer (current);
3004 /* Free a namespace structure and everything below it. Interface
3005 lists associated with intrinsic operators are not freed. These are
3006 taken care of when a specific name is freed. */
3009 gfc_free_namespace (gfc_namespace *ns)
3011 gfc_charlen *cl, *cl2;
3012 gfc_namespace *p, *q;
3021 gcc_assert (ns->refs == 0);
3023 gfc_free_statements (ns->code);
3025 free_sym_tree (ns->sym_root);
3026 free_uop_tree (ns->uop_root);
3027 free_common_tree (ns->common_root);
3028 gfc_free_finalizer_list (ns->finalizers);
3030 for (cl = ns->cl_list; cl; cl = cl2)
3033 gfc_free_expr (cl->length);
3037 free_st_labels (ns->st_labels);
3039 gfc_free_equiv (ns->equiv);
3040 gfc_free_equiv_lists (ns->equiv_lists);
3041 gfc_free_use_stmts (ns->use_stmts);
3043 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3044 gfc_free_interface (ns->op[i]);
3046 gfc_free_data (ns->data);
3050 /* Recursively free any contained namespaces. */
3055 gfc_free_namespace (q);
3061 gfc_symbol_init_2 (void)
3064 gfc_current_ns = gfc_get_namespace (NULL, 0);
3069 gfc_symbol_done_2 (void)
3072 gfc_free_namespace (gfc_current_ns);
3073 gfc_current_ns = NULL;
3074 gfc_free_dt_list ();
3078 /* Clear mark bits from symbol nodes associated with a symtree node. */
3081 clear_sym_mark (gfc_symtree *st)
3084 st->n.sym->mark = 0;
3088 /* Recursively traverse the symtree nodes. */
3091 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
3096 gfc_traverse_symtree (st->left, func);
3098 gfc_traverse_symtree (st->right, func);
3102 /* Recursive namespace traversal function. */
3105 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
3111 traverse_ns (st->left, func);
3113 if (st->n.sym->mark == 0)
3114 (*func) (st->n.sym);
3115 st->n.sym->mark = 1;
3117 traverse_ns (st->right, func);
3121 /* Call a given function for all symbols in the namespace. We take
3122 care that each gfc_symbol node is called exactly once. */
3125 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3128 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3130 traverse_ns (ns->sym_root, func);
3134 /* Return TRUE when name is the name of an intrinsic type. */
3137 gfc_is_intrinsic_typename (const char *name)
3139 if (strcmp (name, "integer") == 0
3140 || strcmp (name, "real") == 0
3141 || strcmp (name, "character") == 0
3142 || strcmp (name, "logical") == 0
3143 || strcmp (name, "complex") == 0
3144 || strcmp (name, "doubleprecision") == 0
3145 || strcmp (name, "doublecomplex") == 0)
3152 /* Return TRUE if the symbol is an automatic variable. */
3155 gfc_is_var_automatic (gfc_symbol *sym)
3157 /* Pointer and allocatable variables are never automatic. */
3158 if (sym->attr.pointer || sym->attr.allocatable)
3160 /* Check for arrays with non-constant size. */
3161 if (sym->attr.dimension && sym->as
3162 && !gfc_is_compile_time_shape (sym->as))
3164 /* Check for non-constant length character variables. */
3165 if (sym->ts.type == BT_CHARACTER
3167 && !gfc_is_constant_expr (sym->ts.cl->length))
3172 /* Given a symbol, mark it as SAVEd if it is allowed. */
3175 save_symbol (gfc_symbol *sym)
3178 if (sym->attr.use_assoc)
3181 if (sym->attr.in_common
3183 || sym->attr.flavor != FL_VARIABLE)
3185 /* Automatic objects are not saved. */
3186 if (gfc_is_var_automatic (sym))
3188 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3192 /* Mark those symbols which can be SAVEd as such. */
3195 gfc_save_all (gfc_namespace *ns)
3197 gfc_traverse_ns (ns, save_symbol);
3202 /* Make sure that no changes to symbols are pending. */
3205 gfc_symbol_state(void) {
3207 if (changed_syms != NULL)
3208 gfc_internal_error("Symbol changes still pending!");
3213 /************** Global symbol handling ************/
3216 /* Search a tree for the global symbol. */
3219 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3228 c = strcmp (name, symbol->name);
3232 symbol = (c < 0) ? symbol->left : symbol->right;
3239 /* Compare two global symbols. Used for managing the BB tree. */
3242 gsym_compare (void *_s1, void *_s2)
3244 gfc_gsymbol *s1, *s2;
3246 s1 = (gfc_gsymbol *) _s1;
3247 s2 = (gfc_gsymbol *) _s2;
3248 return strcmp (s1->name, s2->name);
3252 /* Get a global symbol, creating it if it doesn't exist. */
3255 gfc_get_gsymbol (const char *name)
3259 s = gfc_find_gsymbol (gfc_gsym_root, name);
3263 s = XCNEW (gfc_gsymbol);
3264 s->type = GSYM_UNKNOWN;
3265 s->name = gfc_get_string (name);
3267 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3274 get_iso_c_binding_dt (int sym_id)
3276 gfc_dt_list *dt_list;
3278 dt_list = gfc_derived_types;
3280 /* Loop through the derived types in the name list, searching for
3281 the desired symbol from iso_c_binding. Search the parent namespaces
3282 if necessary and requested to (parent_flag). */
3283 while (dt_list != NULL)
3285 if (dt_list->derived->from_intmod != INTMOD_NONE
3286 && dt_list->derived->intmod_sym_id == sym_id)
3287 return dt_list->derived;
3289 dt_list = dt_list->next;
3296 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3297 with C. This is necessary for any derived type that is BIND(C) and for
3298 derived types that are parameters to functions that are BIND(C). All
3299 fields of the derived type are required to be interoperable, and are tested
3300 for such. If an error occurs, the errors are reported here, allowing for
3301 multiple errors to be handled for a single derived type. */
3304 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3306 gfc_component *curr_comp = NULL;
3307 gfc_try is_c_interop = FAILURE;
3308 gfc_try retval = SUCCESS;
3310 if (derived_sym == NULL)
3311 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3312 "unexpectedly NULL");
3314 /* If we've already looked at this derived symbol, do not look at it again
3315 so we don't repeat warnings/errors. */
3316 if (derived_sym->ts.is_c_interop)
3319 /* The derived type must have the BIND attribute to be interoperable
3320 J3/04-007, Section 15.2.3. */
3321 if (derived_sym->attr.is_bind_c != 1)
3323 derived_sym->ts.is_c_interop = 0;
3324 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3325 "attribute to be C interoperable", derived_sym->name,
3326 &(derived_sym->declared_at));
3330 curr_comp = derived_sym->components;
3332 /* TODO: is this really an error? */
3333 if (curr_comp == NULL)
3335 gfc_error ("Derived type '%s' at %L is empty",
3336 derived_sym->name, &(derived_sym->declared_at));
3340 /* Initialize the derived type as being C interoperable.
3341 If we find an error in the components, this will be set false. */
3342 derived_sym->ts.is_c_interop = 1;
3344 /* Loop through the list of components to verify that the kind of
3345 each is a C interoperable type. */
3348 /* The components cannot be pointers (fortran sense).
3349 J3/04-007, Section 15.2.3, C1505. */
3350 if (curr_comp->attr.pointer != 0)
3352 gfc_error ("Component '%s' at %L cannot have the "
3353 "POINTER attribute because it is a member "
3354 "of the BIND(C) derived type '%s' at %L",
3355 curr_comp->name, &(curr_comp->loc),
3356 derived_sym->name, &(derived_sym->declared_at));
3360 /* The components cannot be allocatable.
3361 J3/04-007, Section 15.2.3, C1505. */
3362 if (curr_comp->attr.allocatable != 0)
3364 gfc_error ("Component '%s' at %L cannot have the "
3365 "ALLOCATABLE attribute because it is a member "
3366 "of the BIND(C) derived type '%s' at %L",
3367 curr_comp->name, &(curr_comp->loc),
3368 derived_sym->name, &(derived_sym->declared_at));
3372 /* BIND(C) derived types must have interoperable components. */
3373 if (curr_comp->ts.type == BT_DERIVED
3374 && curr_comp->ts.derived->ts.is_iso_c != 1
3375 && curr_comp->ts.derived != derived_sym)
3377 /* This should be allowed; the draft says a derived-type can not
3378 have type parameters if it is has the BIND attribute. Type
3379 parameters seem to be for making parameterized derived types.
3380 There's no need to verify the type if it is c_ptr/c_funptr. */
3381 retval = verify_bind_c_derived_type (curr_comp->ts.derived);
3385 /* Grab the typespec for the given component and test the kind. */
3386 is_c_interop = verify_c_interop (&(curr_comp->ts), curr_comp->name,
3389 if (is_c_interop != SUCCESS)
3391 /* Report warning and continue since not fatal. The
3392 draft does specify a constraint that requires all fields
3393 to interoperate, but if the user says real(4), etc., it
3394 may interoperate with *something* in C, but the compiler
3395 most likely won't know exactly what. Further, it may not
3396 interoperate with the same data type(s) in C if the user
3397 recompiles with different flags (e.g., -m32 and -m64 on
3398 x86_64 and using integer(4) to claim interop with a
3400 if (derived_sym->attr.is_bind_c == 1)
3401 /* If the derived type is bind(c), all fields must be
3403 gfc_warning ("Component '%s' in derived type '%s' at %L "
3404 "may not be C interoperable, even though "
3405 "derived type '%s' is BIND(C)",
3406 curr_comp->name, derived_sym->name,
3407 &(curr_comp->loc), derived_sym->name);
3409 /* If derived type is param to bind(c) routine, or to one
3410 of the iso_c_binding procs, it must be interoperable, so
3411 all fields must interop too. */
3412 gfc_warning ("Component '%s' in derived type '%s' at %L "
3413 "may not be C interoperable",
3414 curr_comp->name, derived_sym->name,
3419 curr_comp = curr_comp->next;
3420 } while (curr_comp != NULL);
3423 /* Make sure we don't have conflicts with the attributes. */
3424 if (derived_sym->attr.access == ACCESS_PRIVATE)
3426 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3427 "PRIVATE and BIND(C) attributes", derived_sym->name,
3428 &(derived_sym->declared_at));
3432 if (derived_sym->attr.sequence != 0)
3434 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3435 "attribute because it is BIND(C)", derived_sym->name,
3436 &(derived_sym->declared_at));
3440 /* Mark the derived type as not being C interoperable if we found an
3441 error. If there were only warnings, proceed with the assumption
3442 it's interoperable. */
3443 if (retval == FAILURE)
3444 derived_sym->ts.is_c_interop = 0;
3450 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3453 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3454 const char *module_name)
3456 gfc_symtree *tmp_symtree;
3457 gfc_symbol *tmp_sym;
3459 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3461 if (tmp_symtree != NULL)
3462 tmp_sym = tmp_symtree->n.sym;
3466 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3467 "create symbol for %s", ptr_name);
3470 /* Set up the symbol's important fields. Save attr required so we can
3471 initialize the ptr to NULL. */
3472 tmp_sym->attr.save = SAVE_EXPLICIT;
3473 tmp_sym->ts.is_c_interop = 1;
3474 tmp_sym->attr.is_c_interop = 1;
3475 tmp_sym->ts.is_iso_c = 1;
3476 tmp_sym->ts.type = BT_DERIVED;
3478 /* The c_ptr and c_funptr derived types will provide the
3479 definition for c_null_ptr and c_null_funptr, respectively. */
3480 if (ptr_id == ISOCBINDING_NULL_PTR)
3481 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3483 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3484 if (tmp_sym->ts.derived == NULL)
3486 /* This can occur if the user forgot to declare c_ptr or
3487 c_funptr and they're trying to use one of the procedures
3488 that has arg(s) of the missing type. In this case, a
3489 regular version of the thing should have been put in the
3491 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3492 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3493 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3494 ? "_gfortran_iso_c_binding_c_ptr"
3495 : "_gfortran_iso_c_binding_c_funptr"));
3497 tmp_sym->ts.derived =
3498 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3499 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3502 /* Module name is some mangled version of iso_c_binding. */
3503 tmp_sym->module = gfc_get_string (module_name);
3505 /* Say it's from the iso_c_binding module. */
3506 tmp_sym->attr.is_iso_c = 1;
3508 tmp_sym->attr.use_assoc = 1;
3509 tmp_sym->attr.is_bind_c = 1;
3510 /* Set the binding_label. */
3511 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3513 /* Set the c_address field of c_null_ptr and c_null_funptr to
3514 the value of NULL. */
3515 tmp_sym->value = gfc_get_expr ();
3516 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3517 tmp_sym->value->ts.type = BT_DERIVED;
3518 tmp_sym->value->ts.derived = tmp_sym->ts.derived;
3519 /* Create a constructor with no expr, that way we can recognize if the user
3520 tries to call the structure constructor for one of the iso_c_binding
3521 derived types during resolution (resolve_structure_cons). */
3522 tmp_sym->value->value.constructor = gfc_get_constructor ();
3523 /* Must declare c_null_ptr and c_null_funptr as having the
3524 PARAMETER attribute so they can be used in init expressions. */
3525 tmp_sym->attr.flavor = FL_PARAMETER;
3531 /* Add a formal argument, gfc_formal_arglist, to the
3532 end of the given list of arguments. Set the reference to the
3533 provided symbol, param_sym, in the argument. */
3536 add_formal_arg (gfc_formal_arglist **head,
3537 gfc_formal_arglist **tail,
3538 gfc_formal_arglist *formal_arg,
3539 gfc_symbol *param_sym)
3541 /* Put in list, either as first arg or at the tail (curr arg). */
3543 *head = *tail = formal_arg;
3546 (*tail)->next = formal_arg;
3547 (*tail) = formal_arg;
3550 (*tail)->sym = param_sym;
3551 (*tail)->next = NULL;
3557 /* Generates a symbol representing the CPTR argument to an
3558 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3559 CPTR and add it to the provided argument list. */
3562 gen_cptr_param (gfc_formal_arglist **head,
3563 gfc_formal_arglist **tail,
3564 const char *module_name,
3565 gfc_namespace *ns, const char *c_ptr_name,
3568 gfc_symbol *param_sym = NULL;
3569 gfc_symbol *c_ptr_sym = NULL;
3570 gfc_symtree *param_symtree = NULL;
3571 gfc_formal_arglist *formal_arg = NULL;
3572 const char *c_ptr_in;
3573 const char *c_ptr_type = NULL;
3575 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3576 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3578 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3580 if(c_ptr_name == NULL)
3581 c_ptr_in = "gfc_cptr__";
3583 c_ptr_in = c_ptr_name;
3584 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree);
3585 if (param_symtree != NULL)
3586 param_sym = param_symtree->n.sym;
3588 gfc_internal_error ("gen_cptr_param(): Unable to "
3589 "create symbol for %s", c_ptr_in);
3591 /* Set up the appropriate fields for the new c_ptr param sym. */
3593 param_sym->attr.flavor = FL_DERIVED;
3594 param_sym->ts.type = BT_DERIVED;
3595 param_sym->attr.intent = INTENT_IN;
3596 param_sym->attr.dummy = 1;
3598 /* This will pass the ptr to the iso_c routines as a (void *). */
3599 param_sym->attr.value = 1;
3600 param_sym->attr.use_assoc = 1;
3602 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3604 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3605 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3607 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3608 if (c_ptr_sym == NULL)
3610 /* This can happen if the user did not define c_ptr but they are
3611 trying to use one of the iso_c_binding functions that need it. */
3612 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3613 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3614 (const char *)c_ptr_type);
3616 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3617 (const char *)c_ptr_type);
3619 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3622 param_sym->ts.derived = c_ptr_sym;
3623 param_sym->module = gfc_get_string (module_name);
3625 /* Make new formal arg. */
3626 formal_arg = gfc_get_formal_arglist ();
3627 /* Add arg to list of formal args (the CPTR arg). */
3628 add_formal_arg (head, tail, formal_arg, param_sym);
3632 /* Generates a symbol representing the FPTR argument to an
3633 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3634 FPTR and add it to the provided argument list. */
3637 gen_fptr_param (gfc_formal_arglist **head,
3638 gfc_formal_arglist **tail,
3639 const char *module_name,
3640 gfc_namespace *ns, const char *f_ptr_name, int proc)
3642 gfc_symbol *param_sym = NULL;
3643 gfc_symtree *param_symtree = NULL;
3644 gfc_formal_arglist *formal_arg = NULL;
3645 const char *f_ptr_out = "gfc_fptr__";
3647 if (f_ptr_name != NULL)
3648 f_ptr_out = f_ptr_name;
3650 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree);
3651 if (param_symtree != NULL)
3652 param_sym = param_symtree->n.sym;
3654 gfc_internal_error ("generateFPtrParam(): Unable to "
3655 "create symbol for %s", f_ptr_out);
3657 /* Set up the necessary fields for the fptr output param sym. */
3660 param_sym->attr.proc_pointer = 1;
3662 param_sym->attr.pointer = 1;
3663 param_sym->attr.dummy = 1;
3664 param_sym->attr.use_assoc = 1;
3666 /* ISO C Binding type to allow any pointer type as actual param. */
3667 param_sym->ts.type = BT_VOID;
3668 param_sym->module = gfc_get_string (module_name);
3671 formal_arg = gfc_get_formal_arglist ();
3672 /* Add arg to list of formal args. */
3673 add_formal_arg (head, tail, formal_arg, param_sym);
3677 /* Generates a symbol representing the optional SHAPE argument for the
3678 iso_c_binding c_f_pointer() procedure. Also, create a
3679 gfc_formal_arglist for the SHAPE and add it to the provided
3683 gen_shape_param (gfc_formal_arglist **head,
3684 gfc_formal_arglist **tail,
3685 const char *module_name,
3686 gfc_namespace *ns, const char *shape_param_name)
3688 gfc_symbol *param_sym = NULL;
3689 gfc_symtree *param_symtree = NULL;
3690 gfc_formal_arglist *formal_arg = NULL;
3691 const char *shape_param = "gfc_shape_array__";
3694 if (shape_param_name != NULL)
3695 shape_param = shape_param_name;
3697 gfc_get_sym_tree (shape_param, ns, ¶m_symtree);
3698 if (param_symtree != NULL)
3699 param_sym = param_symtree->n.sym;
3701 gfc_internal_error ("generateShapeParam(): Unable to "
3702 "create symbol for %s", shape_param);
3704 /* Set up the necessary fields for the shape input param sym. */
3706 param_sym->attr.dummy = 1;
3707 param_sym->attr.use_assoc = 1;
3709 /* Integer array, rank 1, describing the shape of the object. Make it's
3710 type BT_VOID initially so we can accept any type/kind combination of
3711 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3712 of BT_INTEGER type. */
3713 param_sym->ts.type = BT_VOID;
3715 /* Initialize the kind to default integer. However, it will be overridden
3716 during resolution to match the kind of the SHAPE parameter given as
3717 the actual argument (to allow for any valid integer kind). */
3718 param_sym->ts.kind = gfc_default_integer_kind;
3719 param_sym->as = gfc_get_array_spec ();
3721 /* Clear out the dimension info for the array. */
3722 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3724 param_sym->as->lower[i] = NULL;
3725 param_sym->as->upper[i] = NULL;
3727 param_sym->as->rank = 1;
3728 param_sym->as->lower[0] = gfc_int_expr (1);
3730 /* The extent is unknown until we get it. The length give us
3731 the rank the incoming pointer. */
3732 param_sym->as->type = AS_ASSUMED_SHAPE;
3734 /* The arg is also optional; it is required iff the second arg
3735 (fptr) is to an array, otherwise, it's ignored. */
3736 param_sym->attr.optional = 1;
3737 param_sym->attr.intent = INTENT_IN;
3738 param_sym->attr.dimension = 1;
3739 param_sym->module = gfc_get_string (module_name);
3742 formal_arg = gfc_get_formal_arglist ();
3743 /* Add arg to list of formal args. */
3744 add_formal_arg (head, tail, formal_arg, param_sym);
3747 /* Add a procedure interface to the given symbol (i.e., store a
3748 reference to the list of formal arguments). */
3751 add_proc_interface (gfc_symbol *sym, ifsrc source,
3752 gfc_formal_arglist *formal)
3755 sym->formal = formal;
3756 sym->attr.if_source = source;
3759 /* Copy the formal args from an existing symbol, src, into a new
3760 symbol, dest. New formal args are created, and the description of
3761 each arg is set according to the existing ones. This function is
3762 used when creating procedure declaration variables from a procedure
3763 declaration statement (see match_proc_decl()) to create the formal
3764 args based on the args of a given named interface. */
3767 copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
3769 gfc_formal_arglist *head = NULL;
3770 gfc_formal_arglist *tail = NULL;
3771 gfc_formal_arglist *formal_arg = NULL;
3772 gfc_formal_arglist *curr_arg = NULL;
3773 gfc_formal_arglist *formal_prev = NULL;
3774 /* Save current namespace so we can change it for formal args. */
3775 gfc_namespace *parent_ns = gfc_current_ns;
3777 /* Create a new namespace, which will be the formal ns (namespace
3778 of the formal args). */
3779 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3780 gfc_current_ns->proc_name = dest;
3782 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3784 formal_arg = gfc_get_formal_arglist ();
3785 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
3787 /* May need to copy more info for the symbol. */
3788 formal_arg->sym->attr = curr_arg->sym->attr;
3789 formal_arg->sym->ts = curr_arg->sym->ts;
3790 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
3792 /* If this isn't the first arg, set up the next ptr. For the
3793 last arg built, the formal_arg->next will never get set to
3794 anything other than NULL. */
3795 if (formal_prev != NULL)
3796 formal_prev->next = formal_arg;
3798 formal_arg->next = NULL;
3800 formal_prev = formal_arg;
3802 /* Add arg to list of formal args. */
3803 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3806 /* Add the interface to the symbol. */
3807 add_proc_interface (dest, IFSRC_DECL, head);
3809 /* Store the formal namespace information. */
3810 if (dest->formal != NULL)
3811 /* The current ns should be that for the dest proc. */
3812 dest->formal_ns = gfc_current_ns;
3813 /* Restore the current namespace to what it was on entry. */
3814 gfc_current_ns = parent_ns;
3817 /* Builds the parameter list for the iso_c_binding procedure
3818 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3819 generic version of either the c_f_pointer or c_f_procpointer
3820 functions. The new_proc_sym represents a "resolved" version of the
3821 symbol. The functions are resolved to match the types of their
3822 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3823 something similar to c_f_pointer_i4 if the type of data object fptr
3824 pointed to was a default integer. The actual name of the resolved
3825 procedure symbol is further mangled with the module name, etc., but
3826 the idea holds true. */
3829 build_formal_args (gfc_symbol *new_proc_sym,
3830 gfc_symbol *old_sym, int add_optional_arg)
3832 gfc_formal_arglist *head = NULL, *tail = NULL;
3833 gfc_namespace *parent_ns = NULL;
3835 parent_ns = gfc_current_ns;
3836 /* Create a new namespace, which will be the formal ns (namespace
3837 of the formal args). */
3838 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
3839 gfc_current_ns->proc_name = new_proc_sym;
3841 /* Generate the params. */
3842 if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
3844 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3845 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3846 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3847 gfc_current_ns, "fptr", 1);
3849 else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3851 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3852 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3853 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3854 gfc_current_ns, "fptr", 0);
3855 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3856 gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
3857 gfc_current_ns, "shape");
3860 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3862 /* c_associated has one required arg and one optional; both
3864 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3865 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
3866 if (add_optional_arg)
3868 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3869 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
3870 /* The last param is optional so mark it as such. */
3871 tail->sym->attr.optional = 1;
3875 /* Add the interface (store formal args to new_proc_sym). */
3876 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
3878 /* Set up the formal_ns pointer to the one created for the
3879 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3880 new_proc_sym->formal_ns = gfc_current_ns;
3882 gfc_current_ns = parent_ns;
3886 std_for_isocbinding_symbol (int id)
3890 #define NAMED_INTCST(a,b,c,d) \
3893 #include "iso-c-binding.def"
3896 return GFC_STD_F2003;
3900 /* Generate the given set of C interoperable kind objects, or all
3901 interoperable kinds. This function will only be given kind objects
3902 for valid iso_c_binding defined types because this is verified when
3903 the 'use' statement is parsed. If the user gives an 'only' clause,
3904 the specific kinds are looked up; if they don't exist, an error is
3905 reported. If the user does not give an 'only' clause, all
3906 iso_c_binding symbols are generated. If a list of specific kinds
3907 is given, it must have a NULL in the first empty spot to mark the
3912 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
3913 const char *local_name)
3915 const char *const name = (local_name && local_name[0]) ? local_name
3916 : c_interop_kinds_table[s].name;
3917 gfc_symtree *tmp_symtree = NULL;
3918 gfc_symbol *tmp_sym = NULL;
3919 gfc_dt_list **dt_list_ptr = NULL;
3920 gfc_component *tmp_comp = NULL;
3921 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
3924 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
3926 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
3928 /* Already exists in this scope so don't re-add it.
3929 TODO: we should probably check that it's really the same symbol. */
3930 if (tmp_symtree != NULL)
3933 /* Create the sym tree in the current ns. */
3934 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
3936 tmp_sym = tmp_symtree->n.sym;
3938 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3941 /* Say what module this symbol belongs to. */
3942 tmp_sym->module = gfc_get_string (mod_name);
3943 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
3944 tmp_sym->intmod_sym_id = s;
3949 #define NAMED_INTCST(a,b,c,d) case a :
3950 #define NAMED_REALCST(a,b,c) case a :
3951 #define NAMED_CMPXCST(a,b,c) case a :
3952 #define NAMED_LOGCST(a,b,c) case a :
3953 #define NAMED_CHARKNDCST(a,b,c) case a :
3954 #include "iso-c-binding.def"
3956 tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
3958 /* Initialize an integer constant expression node. */
3959 tmp_sym->attr.flavor = FL_PARAMETER;
3960 tmp_sym->ts.type = BT_INTEGER;
3961 tmp_sym->ts.kind = gfc_default_integer_kind;
3963 /* Mark this type as a C interoperable one. */
3964 tmp_sym->ts.is_c_interop = 1;
3965 tmp_sym->ts.is_iso_c = 1;
3966 tmp_sym->value->ts.is_c_interop = 1;
3967 tmp_sym->value->ts.is_iso_c = 1;
3968 tmp_sym->attr.is_c_interop = 1;
3970 /* Tell what f90 type this c interop kind is valid. */
3971 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
3973 /* Say it's from the iso_c_binding module. */
3974 tmp_sym->attr.is_iso_c = 1;
3976 /* Make it use associated. */
3977 tmp_sym->attr.use_assoc = 1;
3981 #define NAMED_CHARCST(a,b,c) case a :
3982 #include "iso-c-binding.def"
3984 /* Initialize an integer constant expression node for the
3985 length of the character. */
3986 tmp_sym->value = gfc_get_expr ();
3987 tmp_sym->value->expr_type = EXPR_CONSTANT;
3988 tmp_sym->value->ts.type = BT_CHARACTER;
3989 tmp_sym->value->ts.kind = gfc_default_character_kind;
3990 tmp_sym->value->where = gfc_current_locus;
3991 tmp_sym->value->ts.is_c_interop = 1;
3992 tmp_sym->value->ts.is_iso_c = 1;
3993 tmp_sym->value->value.character.length = 1;
3994 tmp_sym->value->value.character.string = gfc_get_wide_string (2);
3995 tmp_sym->value->value.character.string[0]
3996 = (gfc_char_t) c_interop_kinds_table[s].value;
3997 tmp_sym->value->value.character.string[1] = '\0';
3998 tmp_sym->ts.cl = gfc_get_charlen ();
3999 tmp_sym->ts.cl->length = gfc_int_expr (1);
4001 /* May not need this in both attr and ts, but do need in
4002 attr for writing module file. */
4003 tmp_sym->attr.is_c_interop = 1;
4005 tmp_sym->attr.flavor = FL_PARAMETER;
4006 tmp_sym->ts.type = BT_CHARACTER;
4008 /* Need to set it to the C_CHAR kind. */
4009 tmp_sym->ts.kind = gfc_default_character_kind;
4011 /* Mark this type as a C interoperable one. */
4012 tmp_sym->ts.is_c_interop = 1;
4013 tmp_sym->ts.is_iso_c = 1;
4015 /* Tell what f90 type this c interop kind is valid. */
4016 tmp_sym->ts.f90_type = BT_CHARACTER;
4018 /* Say it's from the iso_c_binding module. */
4019 tmp_sym->attr.is_iso_c = 1;
4021 /* Make it use associated. */
4022 tmp_sym->attr.use_assoc = 1;
4025 case ISOCBINDING_PTR:
4026 case ISOCBINDING_FUNPTR:
4028 /* Initialize an integer constant expression node. */
4029 tmp_sym->attr.flavor = FL_DERIVED;
4030 tmp_sym->ts.is_c_interop = 1;
4031 tmp_sym->attr.is_c_interop = 1;
4032 tmp_sym->attr.is_iso_c = 1;
4033 tmp_sym->ts.is_iso_c = 1;
4034 tmp_sym->ts.type = BT_DERIVED;
4036 /* A derived type must have the bind attribute to be
4037 interoperable (J3/04-007, Section 15.2.3), even though
4038 the binding label is not used. */
4039 tmp_sym->attr.is_bind_c = 1;
4041 tmp_sym->attr.referenced = 1;
4043 tmp_sym->ts.derived = tmp_sym;
4045 /* Add the symbol created for the derived type to the current ns. */
4046 dt_list_ptr = &(gfc_derived_types);
4047 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4048 dt_list_ptr = &((*dt_list_ptr)->next);
4050 /* There is already at least one derived type in the list, so append
4051 the one we're currently building for c_ptr or c_funptr. */
4052 if (*dt_list_ptr != NULL)
4053 dt_list_ptr = &((*dt_list_ptr)->next);
4054 (*dt_list_ptr) = gfc_get_dt_list ();
4055 (*dt_list_ptr)->derived = tmp_sym;
4056 (*dt_list_ptr)->next = NULL;
4058 /* Set up the component of the derived type, which will be
4059 an integer with kind equal to c_ptr_size. Mangle the name of
4060 the field for the c_address to prevent the curious user from
4061 trying to access it from Fortran. */
4062 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
4063 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
4064 if (tmp_comp == NULL)
4065 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4066 "create component for c_address");
4068 tmp_comp->ts.type = BT_INTEGER;
4070 /* Set this because the module will need to read/write this field. */
4071 tmp_comp->ts.f90_type = BT_INTEGER;
4073 /* The kinds for c_ptr and c_funptr are the same. */
4074 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4075 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4077 tmp_comp->attr.pointer = 0;
4078 tmp_comp->attr.dimension = 0;
4080 /* Mark the component as C interoperable. */
4081 tmp_comp->ts.is_c_interop = 1;
4083 /* Make it use associated (iso_c_binding module). */
4084 tmp_sym->attr.use_assoc = 1;
4087 case ISOCBINDING_NULL_PTR:
4088 case ISOCBINDING_NULL_FUNPTR:
4089 gen_special_c_interop_ptr (s, name, mod_name);
4092 case ISOCBINDING_F_POINTER:
4093 case ISOCBINDING_ASSOCIATED:
4094 case ISOCBINDING_LOC:
4095 case ISOCBINDING_FUNLOC:
4096 case ISOCBINDING_F_PROCPOINTER:
4098 tmp_sym->attr.proc = PROC_MODULE;
4100 /* Use the procedure's name as it is in the iso_c_binding module for
4101 setting the binding label in case the user renamed the symbol. */
4102 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
4103 c_interop_kinds_table[s].name);
4104 tmp_sym->attr.is_iso_c = 1;
4105 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4106 tmp_sym->attr.subroutine = 1;
4109 /* TODO! This needs to be finished more for the expr of the
4110 function or something!
4111 This may not need to be here, because trying to do c_loc
4113 if (s == ISOCBINDING_ASSOCIATED)
4115 tmp_sym->attr.function = 1;
4116 tmp_sym->ts.type = BT_LOGICAL;
4117 tmp_sym->ts.kind = gfc_default_logical_kind;
4118 tmp_sym->result = tmp_sym;
4122 /* Here, we're taking the simple approach. We're defining
4123 c_loc as an external identifier so the compiler will put
4124 what we expect on the stack for the address we want the
4126 tmp_sym->ts.type = BT_DERIVED;
4127 if (s == ISOCBINDING_LOC)
4128 tmp_sym->ts.derived =
4129 get_iso_c_binding_dt (ISOCBINDING_PTR);
4131 tmp_sym->ts.derived =
4132 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4134 if (tmp_sym->ts.derived == NULL)
4136 /* Create the necessary derived type so we can continue
4137 processing the file. */
4138 generate_isocbinding_symbol
4139 (mod_name, s == ISOCBINDING_FUNLOC
4140 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4141 (const char *)(s == ISOCBINDING_FUNLOC
4142 ? "_gfortran_iso_c_binding_c_funptr"
4143 : "_gfortran_iso_c_binding_c_ptr"));
4144 tmp_sym->ts.derived =
4145 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4146 ? ISOCBINDING_FUNPTR
4150 /* The function result is itself (no result clause). */
4151 tmp_sym->result = tmp_sym;
4152 tmp_sym->attr.external = 1;
4153 tmp_sym->attr.use_assoc = 0;
4154 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4155 tmp_sym->attr.proc = PROC_UNKNOWN;
4159 tmp_sym->attr.flavor = FL_PROCEDURE;
4160 tmp_sym->attr.contained = 0;
4162 /* Try using this builder routine, with the new and old symbols
4163 both being the generic iso_c proc sym being created. This
4164 will create the formal args (and the new namespace for them).
4165 Don't build an arg list for c_loc because we're going to treat
4166 c_loc as an external procedure. */
4167 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4168 /* The 1 says to add any optional args, if applicable. */
4169 build_formal_args (tmp_sym, tmp_sym, 1);
4171 /* Set this after setting up the symbol, to prevent error messages. */
4172 tmp_sym->attr.use_assoc = 1;
4174 /* This symbol will not be referenced directly. It will be
4175 resolved to the implementation for the given f90 kind. */
4176 tmp_sym->attr.referenced = 0;
4186 /* Creates a new symbol based off of an old iso_c symbol, with a new
4187 binding label. This function can be used to create a new,
4188 resolved, version of a procedure symbol for c_f_pointer or
4189 c_f_procpointer that is based on the generic symbols. A new
4190 parameter list is created for the new symbol using
4191 build_formal_args(). The add_optional_flag specifies whether the
4192 to add the optional SHAPE argument. The new symbol is
4196 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4197 char *new_binding_label, int add_optional_arg)
4199 gfc_symtree *new_symtree = NULL;
4201 /* See if we have a symbol by that name already available, looking
4202 through any parent namespaces. */
4203 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4204 if (new_symtree != NULL)
4205 /* Return the existing symbol. */
4206 return new_symtree->n.sym;
4208 /* Create the symtree/symbol, with attempted host association. */
4209 gfc_get_ha_sym_tree (new_name, &new_symtree);
4210 if (new_symtree == NULL)
4211 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4212 "symtree for '%s'", new_name);
4214 /* Now fill in the fields of the resolved symbol with the old sym. */
4215 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4216 new_symtree->n.sym->attr = old_sym->attr;
4217 new_symtree->n.sym->ts = old_sym->ts;
4218 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4219 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4220 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4221 /* Build the formal arg list. */
4222 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4224 gfc_commit_symbol (new_symtree->n.sym);
4226 return new_symtree->n.sym;
4230 /* Check that a symbol is already typed. If strict is not set, an untyped
4231 symbol is acceptable for non-standard-conforming mode. */
4234 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4235 bool strict, locus where)
4239 if (gfc_matching_prefix)
4242 /* Check for the type and try to give it an implicit one. */
4243 if (sym->ts.type == BT_UNKNOWN
4244 && gfc_set_default_type (sym, 0, ns) == FAILURE)
4248 gfc_error ("Symbol '%s' is used before it is typed at %L",
4253 if (gfc_notify_std (GFC_STD_GNU,
4254 "Extension: Symbol '%s' is used before"
4255 " it is typed at %L", sym->name, &where) == FAILURE)
4259 /* Everything is ok. */
4264 /* Get the super-type of a given derived type. */
4267 gfc_get_derived_super_type (gfc_symbol* derived)
4269 if (!derived->attr.extension)
4272 gcc_assert (derived->components);
4273 gcc_assert (derived->components->ts.type == BT_DERIVED);
4274 gcc_assert (derived->components->ts.derived);
4276 return derived->components->ts.derived;
4280 /* Find a type-bound procedure by name for a derived-type (looking recursively
4281 through the super-types). */
4284 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
4285 const char* name, bool noaccess)
4289 /* Set default to failure. */
4293 /* Try to find it in the current type's namespace. */
4294 gcc_assert (derived->f2k_derived);
4295 res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
4296 if (res && res->typebound)
4302 if (!noaccess && derived->attr.use_assoc
4303 && res->typebound->access == ACCESS_PRIVATE)
4305 gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
4313 /* Otherwise, recurse on parent type if derived is an extension. */
4314 if (derived->attr.extension)
4316 gfc_symbol* super_type;
4317 super_type = gfc_get_derived_super_type (derived);
4318 gcc_assert (super_type);
4319 return gfc_find_typebound_proc (super_type, t, name, noaccess);
4322 /* Nothing found. */