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 '%s'",sym->name);
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;
262 sym->ts.cl = gfc_get_charlen ();
263 *sym->ts.cl = *ts->cl;
266 if (sym->attr.is_bind_c == 1)
268 /* BIND(C) variables should not be implicitly declared. */
269 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
270 "not be C interoperable", sym->name, &sym->declared_at);
271 sym->ts.f90_type = sym->ts.type;
274 if (sym->attr.dummy != 0)
276 if (sym->ns->proc_name != NULL
277 && (sym->ns->proc_name->attr.subroutine != 0
278 || sym->ns->proc_name->attr.function != 0)
279 && sym->ns->proc_name->attr.is_bind_c != 0)
281 /* Dummy args to a BIND(C) routine may not be interoperable if
282 they are implicitly typed. */
283 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
284 "be C interoperable but it is a dummy argument to "
285 "the BIND(C) procedure '%s' at %L", sym->name,
286 &(sym->declared_at), sym->ns->proc_name->name,
287 &(sym->ns->proc_name->declared_at));
288 sym->ts.f90_type = sym->ts.type;
296 /* This function is called from parse.c(parse_progunit) to check the
297 type of the function is not implicitly typed in the host namespace
298 and to implicitly type the function result, if necessary. */
301 gfc_check_function_type (gfc_namespace *ns)
303 gfc_symbol *proc = ns->proc_name;
305 if (!proc->attr.contained || proc->result->attr.implicit_type)
308 if (proc->result->ts.type == BT_UNKNOWN)
310 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
313 if (proc->result != proc)
315 proc->ts = proc->result->ts;
316 proc->as = gfc_copy_array_spec (proc->result->as);
317 proc->attr.dimension = proc->result->attr.dimension;
318 proc->attr.pointer = proc->result->attr.pointer;
319 proc->attr.allocatable = proc->result->attr.allocatable;
324 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
325 proc->result->name, &proc->result->declared_at);
326 proc->result->attr.untyped = 1;
332 /******************** Symbol attribute stuff *********************/
334 /* This is a generic conflict-checker. We do this to avoid having a
335 single conflict in two places. */
337 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
338 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
339 #define conf_std(a, b, std) if (attr->a && attr->b)\
348 check_conflict (symbol_attribute *attr, const char *name, locus *where)
350 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
351 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
352 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
353 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
354 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
355 *privat = "PRIVATE", *recursive = "RECURSIVE",
356 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
357 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
358 *function = "FUNCTION", *subroutine = "SUBROUTINE",
359 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
360 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
361 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
362 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
363 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
364 static const char *threadprivate = "THREADPRIVATE";
370 where = &gfc_current_locus;
372 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
376 standard = GFC_STD_F2003;
380 /* Check for attributes not allowed in a BLOCK DATA. */
381 if (gfc_current_state () == COMP_BLOCK_DATA)
385 if (attr->in_namelist)
387 if (attr->allocatable)
393 if (attr->access == ACCESS_PRIVATE)
395 if (attr->access == ACCESS_PUBLIC)
397 if (attr->intent != INTENT_UNKNOWN)
403 ("%s attribute not allowed in BLOCK DATA program unit at %L",
409 if (attr->save == SAVE_EXPLICIT)
412 conf (in_common, save);
415 switch (attr->flavor)
423 a1 = gfc_code2string (flavors, attr->flavor);
428 /* Conflicts between SAVE and PROCEDURE will be checked at
429 resolution stage, see "resolve_fl_procedure". */
438 conf (dummy, intrinsic);
439 conf (dummy, threadprivate);
440 conf (pointer, target);
441 conf (pointer, intrinsic);
442 conf (pointer, elemental);
443 conf (allocatable, elemental);
445 conf (target, external);
446 conf (target, intrinsic);
448 if (!attr->if_source)
449 conf (external, dimension); /* See Fortran 95's R504. */
451 conf (external, intrinsic);
452 conf (entry, intrinsic);
454 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
456 conf (external, subroutine);
457 conf (external, function);
460 conf (allocatable, pointer);
461 conf_std (allocatable, dummy, GFC_STD_F2003);
462 conf_std (allocatable, function, GFC_STD_F2003);
463 conf_std (allocatable, result, GFC_STD_F2003);
464 conf (elemental, recursive);
466 conf (in_common, dummy);
467 conf (in_common, allocatable);
468 conf (in_common, result);
470 conf (dummy, result);
472 conf (in_equivalence, use_assoc);
473 conf (in_equivalence, dummy);
474 conf (in_equivalence, target);
475 conf (in_equivalence, pointer);
476 conf (in_equivalence, function);
477 conf (in_equivalence, result);
478 conf (in_equivalence, entry);
479 conf (in_equivalence, allocatable);
480 conf (in_equivalence, threadprivate);
482 conf (in_namelist, pointer);
483 conf (in_namelist, allocatable);
485 conf (entry, result);
487 conf (function, subroutine);
489 if (!function && !subroutine)
490 conf (is_bind_c, dummy);
492 conf (is_bind_c, cray_pointer);
493 conf (is_bind_c, cray_pointee);
494 conf (is_bind_c, allocatable);
495 conf (is_bind_c, elemental);
497 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
498 Parameter conflict caught below. Also, value cannot be specified
499 for a dummy procedure. */
501 /* Cray pointer/pointee conflicts. */
502 conf (cray_pointer, cray_pointee);
503 conf (cray_pointer, dimension);
504 conf (cray_pointer, pointer);
505 conf (cray_pointer, target);
506 conf (cray_pointer, allocatable);
507 conf (cray_pointer, external);
508 conf (cray_pointer, intrinsic);
509 conf (cray_pointer, in_namelist);
510 conf (cray_pointer, function);
511 conf (cray_pointer, subroutine);
512 conf (cray_pointer, entry);
514 conf (cray_pointee, allocatable);
515 conf (cray_pointee, intent);
516 conf (cray_pointee, optional);
517 conf (cray_pointee, dummy);
518 conf (cray_pointee, target);
519 conf (cray_pointee, intrinsic);
520 conf (cray_pointee, pointer);
521 conf (cray_pointee, entry);
522 conf (cray_pointee, in_common);
523 conf (cray_pointee, in_equivalence);
524 conf (cray_pointee, threadprivate);
527 conf (data, function);
529 conf (data, allocatable);
530 conf (data, use_assoc);
532 conf (value, pointer)
533 conf (value, allocatable)
534 conf (value, subroutine)
535 conf (value, function)
536 conf (value, volatile_)
537 conf (value, dimension)
538 conf (value, external)
541 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
544 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
548 conf (is_protected, intrinsic)
549 conf (is_protected, external)
550 conf (is_protected, in_common)
552 conf (volatile_, intrinsic)
553 conf (volatile_, external)
555 if (attr->volatile_ && attr->intent == INTENT_IN)
562 conf (procedure, allocatable)
563 conf (procedure, dimension)
564 conf (procedure, intrinsic)
565 conf (procedure, is_protected)
566 conf (procedure, target)
567 conf (procedure, value)
568 conf (procedure, volatile_)
569 conf (procedure, entry)
571 a1 = gfc_code2string (flavors, attr->flavor);
573 if (attr->in_namelist
574 && attr->flavor != FL_VARIABLE
575 && attr->flavor != FL_PROCEDURE
576 && attr->flavor != FL_UNKNOWN)
582 switch (attr->flavor)
592 conf2 (is_protected);
602 conf2 (threadprivate);
604 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
606 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
607 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
614 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
625 /* Conflicts with INTENT will be checked at resolution stage,
626 see "resolve_fl_procedure". */
628 if (attr->subroutine)
636 conf2 (threadprivate);
639 if (!attr->proc_pointer)
644 case PROC_ST_FUNCTION:
654 conf2 (threadprivate);
674 conf2 (threadprivate);
676 if (attr->intent != INTENT_UNKNOWN)
692 conf2 (is_protected);
698 conf2 (threadprivate);
711 gfc_error ("%s attribute conflicts with %s attribute at %L",
714 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
715 a1, a2, name, where);
722 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
723 "with %s attribute at %L", a1, a2,
728 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
729 "with %s attribute in '%s' at %L",
730 a1, a2, name, where);
739 /* Mark a symbol as referenced. */
742 gfc_set_sym_referenced (gfc_symbol *sym)
745 if (sym->attr.referenced)
748 sym->attr.referenced = 1;
750 /* Remember which order dummy variables are accessed in. */
752 sym->dummy_order = next_dummy_order++;
756 /* Common subroutine called by attribute changing subroutines in order
757 to prevent them from changing a symbol that has been
758 use-associated. Returns zero if it is OK to change the symbol,
762 check_used (symbol_attribute *attr, const char *name, locus *where)
765 if (attr->use_assoc == 0)
769 where = &gfc_current_locus;
772 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
775 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
782 /* Generate an error because of a duplicate attribute. */
785 duplicate_attr (const char *attr, locus *where)
789 where = &gfc_current_locus;
791 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
795 /* Called from decl.c (attr_decl1) to check attributes, when declared
799 gfc_add_attribute (symbol_attribute *attr, locus *where)
802 if (check_used (attr, NULL, where))
805 return check_conflict (attr, NULL, where);
809 gfc_add_allocatable (symbol_attribute *attr, locus *where)
812 if (check_used (attr, NULL, where))
815 if (attr->allocatable)
817 duplicate_attr ("ALLOCATABLE", where);
821 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
822 && gfc_find_state (COMP_INTERFACE) == FAILURE)
824 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
829 attr->allocatable = 1;
830 return check_conflict (attr, NULL, where);
835 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
838 if (check_used (attr, name, where))
843 duplicate_attr ("DIMENSION", where);
847 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
848 && gfc_find_state (COMP_INTERFACE) == FAILURE)
850 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
851 "at %L", name, where);
856 return check_conflict (attr, name, where);
861 gfc_add_external (symbol_attribute *attr, locus *where)
864 if (check_used (attr, NULL, where))
869 duplicate_attr ("EXTERNAL", where);
873 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
876 attr->proc_pointer = 1;
881 return check_conflict (attr, NULL, where);
886 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
889 if (check_used (attr, NULL, where))
894 duplicate_attr ("INTRINSIC", where);
900 return check_conflict (attr, NULL, where);
905 gfc_add_optional (symbol_attribute *attr, locus *where)
908 if (check_used (attr, NULL, where))
913 duplicate_attr ("OPTIONAL", where);
918 return check_conflict (attr, NULL, where);
923 gfc_add_pointer (symbol_attribute *attr, locus *where)
926 if (check_used (attr, NULL, where))
929 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
930 && gfc_find_state (COMP_INTERFACE) == FAILURE))
932 duplicate_attr ("POINTER", where);
936 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
937 || (attr->if_source == IFSRC_IFBODY
938 && gfc_find_state (COMP_INTERFACE) == FAILURE))
939 attr->proc_pointer = 1;
943 return check_conflict (attr, NULL, where);
948 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
951 if (check_used (attr, NULL, where))
954 attr->cray_pointer = 1;
955 return check_conflict (attr, NULL, where);
960 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
963 if (check_used (attr, NULL, where))
966 if (attr->cray_pointee)
968 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
969 " statements", where);
973 attr->cray_pointee = 1;
974 return check_conflict (attr, NULL, where);
979 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
981 if (check_used (attr, name, where))
984 if (attr->is_protected)
986 if (gfc_notify_std (GFC_STD_LEGACY,
987 "Duplicate PROTECTED attribute specified at %L",
993 attr->is_protected = 1;
994 return check_conflict (attr, name, where);
999 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1002 if (check_used (attr, name, where))
1006 return check_conflict (attr, name, where);
1011 gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
1014 if (check_used (attr, name, where))
1017 if (gfc_pure (NULL))
1020 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1025 if (attr->save == SAVE_EXPLICIT)
1027 if (gfc_notify_std (GFC_STD_LEGACY,
1028 "Duplicate SAVE attribute specified at %L",
1034 attr->save = SAVE_EXPLICIT;
1035 return check_conflict (attr, name, where);
1040 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1043 if (check_used (attr, name, where))
1048 if (gfc_notify_std (GFC_STD_LEGACY,
1049 "Duplicate VALUE attribute specified at %L",
1056 return check_conflict (attr, name, where);
1061 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1063 /* No check_used needed as 11.2.1 of the F2003 standard allows
1064 that the local identifier made accessible by a use statement can be
1065 given a VOLATILE attribute. */
1067 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1068 if (gfc_notify_std (GFC_STD_LEGACY,
1069 "Duplicate VOLATILE attribute specified at %L", where)
1073 attr->volatile_ = 1;
1074 attr->volatile_ns = gfc_current_ns;
1075 return check_conflict (attr, name, where);
1080 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1083 if (check_used (attr, name, where))
1086 if (attr->threadprivate)
1088 duplicate_attr ("THREADPRIVATE", where);
1092 attr->threadprivate = 1;
1093 return check_conflict (attr, name, where);
1098 gfc_add_target (symbol_attribute *attr, locus *where)
1101 if (check_used (attr, NULL, where))
1106 duplicate_attr ("TARGET", where);
1111 return check_conflict (attr, NULL, where);
1116 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1119 if (check_used (attr, name, where))
1122 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1124 return check_conflict (attr, name, where);
1129 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1132 if (check_used (attr, name, where))
1135 /* Duplicate attribute already checked for. */
1136 attr->in_common = 1;
1137 return check_conflict (attr, name, where);
1142 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1145 /* Duplicate attribute already checked for. */
1146 attr->in_equivalence = 1;
1147 if (check_conflict (attr, name, where) == FAILURE)
1150 if (attr->flavor == FL_VARIABLE)
1153 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1158 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1161 if (check_used (attr, name, where))
1165 return check_conflict (attr, name, where);
1170 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1173 attr->in_namelist = 1;
1174 return check_conflict (attr, name, where);
1179 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1182 if (check_used (attr, name, where))
1186 return check_conflict (attr, name, where);
1191 gfc_add_elemental (symbol_attribute *attr, locus *where)
1194 if (check_used (attr, NULL, where))
1197 if (attr->elemental)
1199 duplicate_attr ("ELEMENTAL", where);
1203 attr->elemental = 1;
1204 return check_conflict (attr, NULL, where);
1209 gfc_add_pure (symbol_attribute *attr, locus *where)
1212 if (check_used (attr, NULL, where))
1217 duplicate_attr ("PURE", where);
1222 return check_conflict (attr, NULL, where);
1227 gfc_add_recursive (symbol_attribute *attr, locus *where)
1230 if (check_used (attr, NULL, where))
1233 if (attr->recursive)
1235 duplicate_attr ("RECURSIVE", where);
1239 attr->recursive = 1;
1240 return check_conflict (attr, NULL, where);
1245 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1248 if (check_used (attr, name, where))
1253 duplicate_attr ("ENTRY", where);
1258 return check_conflict (attr, name, where);
1263 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1266 if (attr->flavor != FL_PROCEDURE
1267 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1271 return check_conflict (attr, name, where);
1276 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1279 if (attr->flavor != FL_PROCEDURE
1280 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1283 attr->subroutine = 1;
1284 return check_conflict (attr, name, where);
1289 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1292 if (attr->flavor != FL_PROCEDURE
1293 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1297 return check_conflict (attr, name, where);
1302 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1305 if (check_used (attr, NULL, where))
1308 if (attr->flavor != FL_PROCEDURE
1309 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1312 if (attr->procedure)
1314 duplicate_attr ("PROCEDURE", where);
1318 attr->procedure = 1;
1320 return check_conflict (attr, NULL, where);
1325 gfc_add_abstract (symbol_attribute* attr, locus* where)
1329 duplicate_attr ("ABSTRACT", where);
1338 /* Flavors are special because some flavors are not what Fortran
1339 considers attributes and can be reaffirmed multiple times. */
1342 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1346 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1347 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1348 || f == FL_NAMELIST) && check_used (attr, name, where))
1351 if (attr->flavor == f && f == FL_VARIABLE)
1354 if (attr->flavor != FL_UNKNOWN)
1357 where = &gfc_current_locus;
1360 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1361 gfc_code2string (flavors, attr->flavor), name,
1362 gfc_code2string (flavors, f), where);
1364 gfc_error ("%s attribute conflicts with %s attribute at %L",
1365 gfc_code2string (flavors, attr->flavor),
1366 gfc_code2string (flavors, f), where);
1373 return check_conflict (attr, name, where);
1378 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1379 const char *name, locus *where)
1382 if (check_used (attr, name, where))
1385 if (attr->flavor != FL_PROCEDURE
1386 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1390 where = &gfc_current_locus;
1392 if (attr->proc != PROC_UNKNOWN)
1394 gfc_error ("%s procedure at %L is already declared as %s procedure",
1395 gfc_code2string (procedures, t), where,
1396 gfc_code2string (procedures, attr->proc));
1403 /* Statement functions are always scalar and functions. */
1404 if (t == PROC_ST_FUNCTION
1405 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1406 || attr->dimension))
1409 return check_conflict (attr, name, where);
1414 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1417 if (check_used (attr, NULL, where))
1420 if (attr->intent == INTENT_UNKNOWN)
1422 attr->intent = intent;
1423 return check_conflict (attr, NULL, where);
1427 where = &gfc_current_locus;
1429 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1430 gfc_intent_string (attr->intent),
1431 gfc_intent_string (intent), where);
1437 /* No checks for use-association in public and private statements. */
1440 gfc_add_access (symbol_attribute *attr, gfc_access access,
1441 const char *name, locus *where)
1444 if (attr->access == ACCESS_UNKNOWN
1445 || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1447 attr->access = access;
1448 return check_conflict (attr, name, where);
1452 where = &gfc_current_locus;
1453 gfc_error ("ACCESS specification at %L was already specified", where);
1459 /* Set the is_bind_c field for the given symbol_attribute. */
1462 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1463 int is_proc_lang_bind_spec)
1466 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1467 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1468 "variables or common blocks", where);
1469 else if (attr->is_bind_c)
1470 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1472 attr->is_bind_c = 1;
1475 where = &gfc_current_locus;
1477 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1481 return check_conflict (attr, name, where);
1485 /* Set the extension field for the given symbol_attribute. */
1488 gfc_add_extension (symbol_attribute *attr, locus *where)
1491 where = &gfc_current_locus;
1493 if (attr->extension)
1494 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1496 attr->extension = 1;
1498 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
1507 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1508 gfc_formal_arglist * formal, locus *where)
1511 if (check_used (&sym->attr, sym->name, where))
1515 where = &gfc_current_locus;
1517 if (sym->attr.if_source != IFSRC_UNKNOWN
1518 && sym->attr.if_source != IFSRC_DECL)
1520 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1525 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1527 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1528 "body", sym->name, where);
1532 sym->formal = formal;
1533 sym->attr.if_source = source;
1539 /* Add a type to a symbol. */
1542 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1547 where = &gfc_current_locus;
1549 if (sym->ts.type != BT_UNKNOWN)
1551 const char *msg = "Symbol '%s' at %L already has basic type of %s";
1552 if (!(sym->ts.type == ts->type
1553 && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
1554 || gfc_notification_std (GFC_STD_GNU) == ERROR
1557 gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1560 if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
1561 gfc_basic_typename (sym->ts.type)) == FAILURE)
1563 if (gfc_option.warn_surprising)
1564 gfc_warning (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1567 flavor = sym->attr.flavor;
1569 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1570 || flavor == FL_LABEL
1571 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1572 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1574 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1583 /* Clears all attributes. */
1586 gfc_clear_attr (symbol_attribute *attr)
1588 memset (attr, 0, sizeof (symbol_attribute));
1592 /* Check for missing attributes in the new symbol. Currently does
1593 nothing, but it's not clear that it is unnecessary yet. */
1596 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1597 locus *where ATTRIBUTE_UNUSED)
1604 /* Copy an attribute to a symbol attribute, bit by bit. Some
1605 attributes have a lot of side-effects but cannot be present given
1606 where we are called from, so we ignore some bits. */
1609 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1611 int is_proc_lang_bind_spec;
1613 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1616 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1618 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1620 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1622 if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1624 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1626 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1628 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1630 if (src->threadprivate
1631 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1633 if (src->target && gfc_add_target (dest, where) == FAILURE)
1635 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1637 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1642 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1645 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1648 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1650 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1652 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1655 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1657 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1659 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1661 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1664 if (src->flavor != FL_UNKNOWN
1665 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1668 if (src->intent != INTENT_UNKNOWN
1669 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1672 if (src->access != ACCESS_UNKNOWN
1673 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1676 if (gfc_missing_attr (dest, where) == FAILURE)
1679 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1681 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1684 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1686 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1690 if (src->is_c_interop)
1691 dest->is_c_interop = 1;
1695 if (src->external && gfc_add_external (dest, where) == FAILURE)
1697 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1699 if (src->proc_pointer)
1700 dest->proc_pointer = 1;
1709 /************** Component name management ************/
1711 /* Component names of a derived type form their own little namespaces
1712 that are separate from all other spaces. The space is composed of
1713 a singly linked list of gfc_component structures whose head is
1714 located in the parent symbol. */
1717 /* Add a component name to a symbol. The call fails if the name is
1718 already present. On success, the component pointer is modified to
1719 point to the additional component structure. */
1722 gfc_add_component (gfc_symbol *sym, const char *name,
1723 gfc_component **component)
1725 gfc_component *p, *tail;
1729 for (p = sym->components; p; p = p->next)
1731 if (strcmp (p->name, name) == 0)
1733 gfc_error ("Component '%s' at %C already declared at %L",
1741 if (sym->attr.extension
1742 && gfc_find_component (sym->components->ts.derived, name, true, true))
1744 gfc_error ("Component '%s' at %C already in the parent type "
1745 "at %L", name, &sym->components->ts.derived->declared_at);
1749 /* Allocate a new component. */
1750 p = gfc_get_component ();
1753 sym->components = p;
1757 p->name = gfc_get_string (name);
1758 p->loc = gfc_current_locus;
1765 /* Recursive function to switch derived types of all symbol in a
1769 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1777 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1778 sym->ts.derived = to;
1780 switch_types (st->left, from, to);
1781 switch_types (st->right, from, to);
1785 /* This subroutine is called when a derived type is used in order to
1786 make the final determination about which version to use. The
1787 standard requires that a type be defined before it is 'used', but
1788 such types can appear in IMPLICIT statements before the actual
1789 definition. 'Using' in this context means declaring a variable to
1790 be that type or using the type constructor.
1792 If a type is used and the components haven't been defined, then we
1793 have to have a derived type in a parent unit. We find the node in
1794 the other namespace and point the symtree node in this namespace to
1795 that node. Further reference to this name point to the correct
1796 node. If we can't find the node in a parent namespace, then we have
1799 This subroutine takes a pointer to a symbol node and returns a
1800 pointer to the translated node or NULL for an error. Usually there
1801 is no translation and we return the node we were passed. */
1804 gfc_use_derived (gfc_symbol *sym)
1811 if (sym->components != NULL || sym->attr.zero_comp)
1812 return sym; /* Already defined. */
1814 if (sym->ns->parent == NULL)
1817 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1819 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1823 if (s == NULL || s->attr.flavor != FL_DERIVED)
1826 /* Get rid of symbol sym, translating all references to s. */
1827 for (i = 0; i < GFC_LETTERS; i++)
1829 t = &sym->ns->default_type[i];
1830 if (t->derived == sym)
1834 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1839 /* Unlink from list of modified symbols. */
1840 gfc_commit_symbol (sym);
1842 switch_types (sym->ns->sym_root, sym, s);
1844 /* TODO: Also have to replace sym -> s in other lists like
1845 namelists, common lists and interface lists. */
1846 gfc_free_symbol (sym);
1851 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1857 /* Given a derived type node and a component name, try to locate the
1858 component structure. Returns the NULL pointer if the component is
1859 not found or the components are private. If noaccess is set, no access
1863 gfc_find_component (gfc_symbol *sym, const char *name,
1864 bool noaccess, bool silent)
1871 sym = gfc_use_derived (sym);
1876 for (p = sym->components; p; p = p->next)
1877 if (strcmp (p->name, name) == 0)
1881 && sym->attr.extension
1882 && sym->components->ts.type == BT_DERIVED)
1884 p = gfc_find_component (sym->components->ts.derived, name,
1886 /* Do not overwrite the error. */
1891 if (p == NULL && !silent)
1892 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1895 else if (sym->attr.use_assoc && !noaccess)
1897 if (p->attr.access == ACCESS_PRIVATE)
1900 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1905 /* If there were components given and all components are private, error
1906 out at this place. */
1907 if (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
1910 gfc_error ("All components of '%s' are PRIVATE in structure"
1911 " constructor at %C", sym->name);
1920 /* Given a symbol, free all of the component structures and everything
1924 free_components (gfc_component *p)
1932 gfc_free_array_spec (p->as);
1933 gfc_free_expr (p->initializer);
1940 /******************** Statement label management ********************/
1942 /* Comparison function for statement labels, used for managing the
1946 compare_st_labels (void *a1, void *b1)
1948 int a = ((gfc_st_label *) a1)->value;
1949 int b = ((gfc_st_label *) b1)->value;
1955 /* Free a single gfc_st_label structure, making sure the tree is not
1956 messed up. This function is called only when some parse error
1960 gfc_free_st_label (gfc_st_label *label)
1966 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
1968 if (label->format != NULL)
1969 gfc_free_expr (label->format);
1975 /* Free a whole tree of gfc_st_label structures. */
1978 free_st_labels (gfc_st_label *label)
1984 free_st_labels (label->left);
1985 free_st_labels (label->right);
1987 if (label->format != NULL)
1988 gfc_free_expr (label->format);
1993 /* Given a label number, search for and return a pointer to the label
1994 structure, creating it if it does not exist. */
1997 gfc_get_st_label (int labelno)
2001 /* First see if the label is already in this namespace. */
2002 lp = gfc_current_ns->st_labels;
2005 if (lp->value == labelno)
2008 if (lp->value < labelno)
2014 lp = XCNEW (gfc_st_label);
2016 lp->value = labelno;
2017 lp->defined = ST_LABEL_UNKNOWN;
2018 lp->referenced = ST_LABEL_UNKNOWN;
2020 gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
2026 /* Called when a statement with a statement label is about to be
2027 accepted. We add the label to the list of the current namespace,
2028 making sure it hasn't been defined previously and referenced
2032 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2036 labelno = lp->value;
2038 if (lp->defined != ST_LABEL_UNKNOWN)
2039 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2040 &lp->where, label_locus);
2043 lp->where = *label_locus;
2047 case ST_LABEL_FORMAT:
2048 if (lp->referenced == ST_LABEL_TARGET)
2049 gfc_error ("Label %d at %C already referenced as branch target",
2052 lp->defined = ST_LABEL_FORMAT;
2056 case ST_LABEL_TARGET:
2057 if (lp->referenced == ST_LABEL_FORMAT)
2058 gfc_error ("Label %d at %C already referenced as a format label",
2061 lp->defined = ST_LABEL_TARGET;
2066 lp->defined = ST_LABEL_BAD_TARGET;
2067 lp->referenced = ST_LABEL_BAD_TARGET;
2073 /* Reference a label. Given a label and its type, see if that
2074 reference is consistent with what is known about that label,
2075 updating the unknown state. Returns FAILURE if something goes
2079 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2081 gfc_sl_type label_type;
2088 labelno = lp->value;
2090 if (lp->defined != ST_LABEL_UNKNOWN)
2091 label_type = lp->defined;
2094 label_type = lp->referenced;
2095 lp->where = gfc_current_locus;
2098 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2100 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2105 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2106 && type == ST_LABEL_FORMAT)
2108 gfc_error ("Label %d at %C previously used as branch target", labelno);
2113 lp->referenced = type;
2121 /*******A helper function for creating new expressions*************/
2125 gfc_lval_expr_from_sym (gfc_symbol *sym)
2128 lval = gfc_get_expr ();
2129 lval->expr_type = EXPR_VARIABLE;
2130 lval->where = sym->declared_at;
2132 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2134 /* It will always be a full array. */
2135 lval->rank = sym->as ? sym->as->rank : 0;
2138 lval->ref = gfc_get_ref ();
2139 lval->ref->type = REF_ARRAY;
2140 lval->ref->u.ar.type = AR_FULL;
2141 lval->ref->u.ar.dimen = lval->rank;
2142 lval->ref->u.ar.where = sym->declared_at;
2143 lval->ref->u.ar.as = sym->as;
2150 /************** Symbol table management subroutines ****************/
2152 /* Basic details: Fortran 95 requires a potentially unlimited number
2153 of distinct namespaces when compiling a program unit. This case
2154 occurs during a compilation of internal subprograms because all of
2155 the internal subprograms must be read before we can start
2156 generating code for the host.
2158 Given the tricky nature of the Fortran grammar, we must be able to
2159 undo changes made to a symbol table if the current interpretation
2160 of a statement is found to be incorrect. Whenever a symbol is
2161 looked up, we make a copy of it and link to it. All of these
2162 symbols are kept in a singly linked list so that we can commit or
2163 undo the changes at a later time.
2165 A symtree may point to a symbol node outside of its namespace. In
2166 this case, that symbol has been used as a host associated variable
2167 at some previous time. */
2169 /* Allocate a new namespace structure. Copies the implicit types from
2170 PARENT if PARENT_TYPES is set. */
2173 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2177 gfc_intrinsic_op in;
2180 ns = XCNEW (gfc_namespace);
2181 ns->sym_root = NULL;
2182 ns->uop_root = NULL;
2183 ns->finalizers = NULL;
2184 ns->default_access = ACCESS_UNKNOWN;
2185 ns->parent = parent;
2187 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2188 ns->operator_access[in] = ACCESS_UNKNOWN;
2190 /* Initialize default implicit types. */
2191 for (i = 'a'; i <= 'z'; i++)
2193 ns->set_flag[i - 'a'] = 0;
2194 ts = &ns->default_type[i - 'a'];
2196 if (parent_types && ns->parent != NULL)
2198 /* Copy parent settings. */
2199 *ts = ns->parent->default_type[i - 'a'];
2203 if (gfc_option.flag_implicit_none != 0)
2209 if ('i' <= i && i <= 'n')
2211 ts->type = BT_INTEGER;
2212 ts->kind = gfc_default_integer_kind;
2217 ts->kind = gfc_default_real_kind;
2227 /* Comparison function for symtree nodes. */
2230 compare_symtree (void *_st1, void *_st2)
2232 gfc_symtree *st1, *st2;
2234 st1 = (gfc_symtree *) _st1;
2235 st2 = (gfc_symtree *) _st2;
2237 return strcmp (st1->name, st2->name);
2241 /* Allocate a new symtree node and associate it with the new symbol. */
2244 gfc_new_symtree (gfc_symtree **root, const char *name)
2248 st = XCNEW (gfc_symtree);
2249 st->name = gfc_get_string (name);
2250 st->typebound = NULL;
2252 gfc_insert_bbt (root, st, compare_symtree);
2257 /* Delete a symbol from the tree. Does not free the symbol itself! */
2260 gfc_delete_symtree (gfc_symtree **root, const char *name)
2262 gfc_symtree st, *st0;
2264 st0 = gfc_find_symtree (*root, name);
2266 st.name = gfc_get_string (name);
2267 gfc_delete_bbt (root, &st, compare_symtree);
2273 /* Given a root symtree node and a name, try to find the symbol within
2274 the namespace. Returns NULL if the symbol is not found. */
2277 gfc_find_symtree (gfc_symtree *st, const char *name)
2283 c = strcmp (name, st->name);
2287 st = (c < 0) ? st->left : st->right;
2294 /* Return a symtree node with a name that is guaranteed to be unique
2295 within the namespace and corresponds to an illegal fortran name. */
2298 gfc_get_unique_symtree (gfc_namespace *ns)
2300 char name[GFC_MAX_SYMBOL_LEN + 1];
2301 static int serial = 0;
2303 sprintf (name, "@%d", serial++);
2304 return gfc_new_symtree (&ns->sym_root, name);
2308 /* Given a name find a user operator node, creating it if it doesn't
2309 exist. These are much simpler than symbols because they can't be
2310 ambiguous with one another. */
2313 gfc_get_uop (const char *name)
2318 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2322 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2324 uop = st->n.uop = XCNEW (gfc_user_op);
2325 uop->name = gfc_get_string (name);
2326 uop->access = ACCESS_UNKNOWN;
2327 uop->ns = gfc_current_ns;
2333 /* Given a name find the user operator node. Returns NULL if it does
2337 gfc_find_uop (const char *name, gfc_namespace *ns)
2342 ns = gfc_current_ns;
2344 st = gfc_find_symtree (ns->uop_root, name);
2345 return (st == NULL) ? NULL : st->n.uop;
2349 /* Remove a gfc_symbol structure and everything it points to. */
2352 gfc_free_symbol (gfc_symbol *sym)
2358 gfc_free_array_spec (sym->as);
2360 free_components (sym->components);
2362 gfc_free_expr (sym->value);
2364 gfc_free_namelist (sym->namelist);
2366 gfc_free_namespace (sym->formal_ns);
2368 if (!sym->attr.generic_copy)
2369 gfc_free_interface (sym->generic);
2371 gfc_free_formal_arglist (sym->formal);
2373 gfc_free_namespace (sym->f2k_derived);
2379 /* Allocate and initialize a new symbol node. */
2382 gfc_new_symbol (const char *name, gfc_namespace *ns)
2386 p = XCNEW (gfc_symbol);
2388 gfc_clear_ts (&p->ts);
2389 gfc_clear_attr (&p->attr);
2392 p->declared_at = gfc_current_locus;
2394 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2395 gfc_internal_error ("new_symbol(): Symbol name too long");
2397 p->name = gfc_get_string (name);
2399 /* Make sure flags for symbol being C bound are clear initially. */
2400 p->attr.is_bind_c = 0;
2401 p->attr.is_iso_c = 0;
2402 /* Make sure the binding label field has a Nul char to start. */
2403 p->binding_label[0] = '\0';
2405 /* Clear the ptrs we may need. */
2406 p->common_block = NULL;
2407 p->f2k_derived = NULL;
2413 /* Generate an error if a symbol is ambiguous. */
2416 ambiguous_symbol (const char *name, gfc_symtree *st)
2419 if (st->n.sym->module)
2420 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2421 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2423 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2424 "from current program unit", name, st->n.sym->name);
2428 /* Search for a symtree starting in the current namespace, resorting to
2429 any parent namespaces if requested by a nonzero parent_flag.
2430 Returns nonzero if the name is ambiguous. */
2433 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2434 gfc_symtree **result)
2439 ns = gfc_current_ns;
2443 st = gfc_find_symtree (ns->sym_root, name);
2447 /* Ambiguous generic interfaces are permitted, as long
2448 as the specific interfaces are different. */
2449 if (st->ambiguous && !st->n.sym->attr.generic)
2451 ambiguous_symbol (name, st);
2470 /* Same, but returns the symbol instead. */
2473 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2474 gfc_symbol **result)
2479 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2484 *result = st->n.sym;
2490 /* Save symbol with the information necessary to back it out. */
2493 save_symbol_data (gfc_symbol *sym)
2496 if (sym->gfc_new || sym->old_symbol != NULL)
2499 sym->old_symbol = XCNEW (gfc_symbol);
2500 *(sym->old_symbol) = *sym;
2502 sym->tlink = changed_syms;
2507 /* Given a name, find a symbol, or create it if it does not exist yet
2508 in the current namespace. If the symbol is found we make sure that
2511 The integer return code indicates
2513 1 The symbol name was ambiguous
2514 2 The name meant to be established was already host associated.
2516 So if the return value is nonzero, then an error was issued. */
2519 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
2524 /* This doesn't usually happen during resolution. */
2526 ns = gfc_current_ns;
2528 /* Try to find the symbol in ns. */
2529 st = gfc_find_symtree (ns->sym_root, name);
2533 /* If not there, create a new symbol. */
2534 p = gfc_new_symbol (name, ns);
2536 /* Add to the list of tentative symbols. */
2537 p->old_symbol = NULL;
2538 p->tlink = changed_syms;
2543 st = gfc_new_symtree (&ns->sym_root, name);
2550 /* Make sure the existing symbol is OK. Ambiguous
2551 generic interfaces are permitted, as long as the
2552 specific interfaces are different. */
2553 if (st->ambiguous && !st->n.sym->attr.generic)
2555 ambiguous_symbol (name, st);
2561 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2563 && ns->proc_name->attr.if_source == IFSRC_IFBODY
2564 && (ns->has_import_set || p->attr.imported)))
2566 /* Symbol is from another namespace. */
2567 gfc_error ("Symbol '%s' at %C has already been host associated",
2574 /* Copy in case this symbol is changed. */
2575 save_symbol_data (p);
2584 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2589 i = gfc_get_sym_tree (name, ns, &st);
2594 *result = st->n.sym;
2601 /* Subroutine that searches for a symbol, creating it if it doesn't
2602 exist, but tries to host-associate the symbol if possible. */
2605 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2610 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2613 save_symbol_data (st->n.sym);
2618 if (gfc_current_ns->parent != NULL)
2620 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2631 return gfc_get_sym_tree (name, gfc_current_ns, result);
2636 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2641 i = gfc_get_ha_sym_tree (name, &st);
2644 *result = st->n.sym;
2651 /* Return true if both symbols could refer to the same data object. Does
2652 not take account of aliasing due to equivalence statements. */
2655 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2657 /* Aliasing isn't possible if the symbols have different base types. */
2658 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2661 /* Pointers can point to other pointers, target objects and allocatable
2662 objects. Two allocatable objects cannot share the same storage. */
2663 if (lsym->attr.pointer
2664 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2666 if (lsym->attr.target && rsym->attr.pointer)
2668 if (lsym->attr.allocatable && rsym->attr.pointer)
2675 /* Undoes all the changes made to symbols in the current statement.
2676 This subroutine is made simpler due to the fact that attributes are
2677 never removed once added. */
2680 gfc_undo_symbols (void)
2682 gfc_symbol *p, *q, *old;
2684 for (p = changed_syms; p; p = q)
2690 /* Symbol was new. */
2691 if (p->attr.in_common && p->common_block->head)
2693 /* If the symbol was added to any common block, it
2694 needs to be removed to stop the resolver looking
2695 for a (possibly) dead symbol. */
2697 if (p->common_block->head == p)
2698 p->common_block->head = p->common_next;
2701 gfc_symbol *cparent, *csym;
2703 cparent = p->common_block->head;
2704 csym = cparent->common_next;
2709 csym = csym->common_next;
2712 gcc_assert(cparent->common_next == p);
2714 cparent->common_next = csym->common_next;
2718 gfc_delete_symtree (&p->ns->sym_root, p->name);
2722 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2724 gfc_free_symbol (p);
2728 /* Restore previous state of symbol. Just copy simple stuff. */
2730 old = p->old_symbol;
2732 p->ts.type = old->ts.type;
2733 p->ts.kind = old->ts.kind;
2735 p->attr = old->attr;
2737 if (p->value != old->value)
2739 gfc_free_expr (old->value);
2743 if (p->as != old->as)
2746 gfc_free_array_spec (p->as);
2750 p->generic = old->generic;
2751 p->component_access = old->component_access;
2753 if (p->namelist != NULL && old->namelist == NULL)
2755 gfc_free_namelist (p->namelist);
2760 if (p->namelist_tail != old->namelist_tail)
2762 gfc_free_namelist (old->namelist_tail);
2763 old->namelist_tail->next = NULL;
2767 p->namelist_tail = old->namelist_tail;
2769 if (p->formal != old->formal)
2771 gfc_free_formal_arglist (p->formal);
2772 p->formal = old->formal;
2775 gfc_free (p->old_symbol);
2776 p->old_symbol = NULL;
2780 changed_syms = NULL;
2784 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2785 components of old_symbol that might need deallocation are the "allocatables"
2786 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2787 namelist_tail. In case these differ between old_symbol and sym, it's just
2788 because sym->namelist has gotten a few more items. */
2791 free_old_symbol (gfc_symbol *sym)
2794 if (sym->old_symbol == NULL)
2797 if (sym->old_symbol->as != sym->as)
2798 gfc_free_array_spec (sym->old_symbol->as);
2800 if (sym->old_symbol->value != sym->value)
2801 gfc_free_expr (sym->old_symbol->value);
2803 if (sym->old_symbol->formal != sym->formal)
2804 gfc_free_formal_arglist (sym->old_symbol->formal);
2806 gfc_free (sym->old_symbol);
2807 sym->old_symbol = NULL;
2811 /* Makes the changes made in the current statement permanent-- gets
2812 rid of undo information. */
2815 gfc_commit_symbols (void)
2819 for (p = changed_syms; p; p = q)
2825 free_old_symbol (p);
2827 changed_syms = NULL;
2831 /* Makes the changes made in one symbol permanent -- gets rid of undo
2835 gfc_commit_symbol (gfc_symbol *sym)
2839 if (changed_syms == sym)
2840 changed_syms = sym->tlink;
2843 for (p = changed_syms; p; p = p->tlink)
2844 if (p->tlink == sym)
2846 p->tlink = sym->tlink;
2855 free_old_symbol (sym);
2859 /* Recursive function that deletes an entire tree and all the common
2860 head structures it points to. */
2863 free_common_tree (gfc_symtree * common_tree)
2865 if (common_tree == NULL)
2868 free_common_tree (common_tree->left);
2869 free_common_tree (common_tree->right);
2871 gfc_free (common_tree);
2875 /* Recursive function that deletes an entire tree and all the user
2876 operator nodes that it contains. */
2879 free_uop_tree (gfc_symtree *uop_tree)
2882 if (uop_tree == NULL)
2885 free_uop_tree (uop_tree->left);
2886 free_uop_tree (uop_tree->right);
2888 gfc_free_interface (uop_tree->n.uop->op);
2890 gfc_free (uop_tree->n.uop);
2891 gfc_free (uop_tree);
2895 /* Recursive function that deletes an entire tree and all the symbols
2896 that it contains. */
2899 free_sym_tree (gfc_symtree *sym_tree)
2904 if (sym_tree == NULL)
2907 free_sym_tree (sym_tree->left);
2908 free_sym_tree (sym_tree->right);
2910 sym = sym_tree->n.sym;
2914 gfc_internal_error ("free_sym_tree(): Negative refs");
2916 if (sym->formal_ns != NULL && sym->refs == 1)
2918 /* As formal_ns contains a reference to sym, delete formal_ns just
2919 before the deletion of sym. */
2920 ns = sym->formal_ns;
2921 sym->formal_ns = NULL;
2922 gfc_free_namespace (ns);
2924 else if (sym->refs == 0)
2926 /* Go ahead and delete the symbol. */
2927 gfc_free_symbol (sym);
2930 gfc_free (sym_tree);
2934 /* Free the derived type list. */
2937 gfc_free_dt_list (void)
2939 gfc_dt_list *dt, *n;
2941 for (dt = gfc_derived_types; dt; dt = n)
2947 gfc_derived_types = NULL;
2951 /* Free the gfc_equiv_info's. */
2954 gfc_free_equiv_infos (gfc_equiv_info *s)
2958 gfc_free_equiv_infos (s->next);
2963 /* Free the gfc_equiv_lists. */
2966 gfc_free_equiv_lists (gfc_equiv_list *l)
2970 gfc_free_equiv_lists (l->next);
2971 gfc_free_equiv_infos (l->equiv);
2976 /* Free a finalizer procedure list. */
2979 gfc_free_finalizer (gfc_finalizer* el)
2985 --el->proc_sym->refs;
2986 if (!el->proc_sym->refs)
2987 gfc_free_symbol (el->proc_sym);
2995 gfc_free_finalizer_list (gfc_finalizer* list)
2999 gfc_finalizer* current = list;
3001 gfc_free_finalizer (current);
3006 /* Free the charlen list from cl to end (end is not freed).
3007 Free the whole list if end is NULL. */
3009 void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3013 for (; cl != end; cl = cl2)
3018 gfc_free_expr (cl->length);
3024 /* Free a namespace structure and everything below it. Interface
3025 lists associated with intrinsic operators are not freed. These are
3026 taken care of when a specific name is freed. */
3029 gfc_free_namespace (gfc_namespace *ns)
3031 gfc_namespace *p, *q;
3040 gcc_assert (ns->refs == 0);
3042 gfc_free_statements (ns->code);
3044 free_sym_tree (ns->sym_root);
3045 free_uop_tree (ns->uop_root);
3046 free_common_tree (ns->common_root);
3047 gfc_free_finalizer_list (ns->finalizers);
3048 gfc_free_charlen (ns->cl_list, NULL);
3049 free_st_labels (ns->st_labels);
3051 gfc_free_equiv (ns->equiv);
3052 gfc_free_equiv_lists (ns->equiv_lists);
3053 gfc_free_use_stmts (ns->use_stmts);
3055 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3056 gfc_free_interface (ns->op[i]);
3058 gfc_free_data (ns->data);
3062 /* Recursively free any contained namespaces. */
3067 gfc_free_namespace (q);
3073 gfc_symbol_init_2 (void)
3076 gfc_current_ns = gfc_get_namespace (NULL, 0);
3081 gfc_symbol_done_2 (void)
3084 gfc_free_namespace (gfc_current_ns);
3085 gfc_current_ns = NULL;
3086 gfc_free_dt_list ();
3090 /* Clear mark bits from symbol nodes associated with a symtree node. */
3093 clear_sym_mark (gfc_symtree *st)
3096 st->n.sym->mark = 0;
3100 /* Recursively traverse the symtree nodes. */
3103 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
3108 gfc_traverse_symtree (st->left, func);
3110 gfc_traverse_symtree (st->right, func);
3114 /* Recursive namespace traversal function. */
3117 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
3123 traverse_ns (st->left, func);
3125 if (st->n.sym->mark == 0)
3126 (*func) (st->n.sym);
3127 st->n.sym->mark = 1;
3129 traverse_ns (st->right, func);
3133 /* Call a given function for all symbols in the namespace. We take
3134 care that each gfc_symbol node is called exactly once. */
3137 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3140 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3142 traverse_ns (ns->sym_root, func);
3146 /* Return TRUE when name is the name of an intrinsic type. */
3149 gfc_is_intrinsic_typename (const char *name)
3151 if (strcmp (name, "integer") == 0
3152 || strcmp (name, "real") == 0
3153 || strcmp (name, "character") == 0
3154 || strcmp (name, "logical") == 0
3155 || strcmp (name, "complex") == 0
3156 || strcmp (name, "doubleprecision") == 0
3157 || strcmp (name, "doublecomplex") == 0)
3164 /* Return TRUE if the symbol is an automatic variable. */
3167 gfc_is_var_automatic (gfc_symbol *sym)
3169 /* Pointer and allocatable variables are never automatic. */
3170 if (sym->attr.pointer || sym->attr.allocatable)
3172 /* Check for arrays with non-constant size. */
3173 if (sym->attr.dimension && sym->as
3174 && !gfc_is_compile_time_shape (sym->as))
3176 /* Check for non-constant length character variables. */
3177 if (sym->ts.type == BT_CHARACTER
3179 && !gfc_is_constant_expr (sym->ts.cl->length))
3184 /* Given a symbol, mark it as SAVEd if it is allowed. */
3187 save_symbol (gfc_symbol *sym)
3190 if (sym->attr.use_assoc)
3193 if (sym->attr.in_common
3195 || sym->attr.flavor != FL_VARIABLE)
3197 /* Automatic objects are not saved. */
3198 if (gfc_is_var_automatic (sym))
3200 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3204 /* Mark those symbols which can be SAVEd as such. */
3207 gfc_save_all (gfc_namespace *ns)
3209 gfc_traverse_ns (ns, save_symbol);
3214 /* Make sure that no changes to symbols are pending. */
3217 gfc_symbol_state(void) {
3219 if (changed_syms != NULL)
3220 gfc_internal_error("Symbol changes still pending!");
3225 /************** Global symbol handling ************/
3228 /* Search a tree for the global symbol. */
3231 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3240 c = strcmp (name, symbol->name);
3244 symbol = (c < 0) ? symbol->left : symbol->right;
3251 /* Compare two global symbols. Used for managing the BB tree. */
3254 gsym_compare (void *_s1, void *_s2)
3256 gfc_gsymbol *s1, *s2;
3258 s1 = (gfc_gsymbol *) _s1;
3259 s2 = (gfc_gsymbol *) _s2;
3260 return strcmp (s1->name, s2->name);
3264 /* Get a global symbol, creating it if it doesn't exist. */
3267 gfc_get_gsymbol (const char *name)
3271 s = gfc_find_gsymbol (gfc_gsym_root, name);
3275 s = XCNEW (gfc_gsymbol);
3276 s->type = GSYM_UNKNOWN;
3277 s->name = gfc_get_string (name);
3279 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3286 get_iso_c_binding_dt (int sym_id)
3288 gfc_dt_list *dt_list;
3290 dt_list = gfc_derived_types;
3292 /* Loop through the derived types in the name list, searching for
3293 the desired symbol from iso_c_binding. Search the parent namespaces
3294 if necessary and requested to (parent_flag). */
3295 while (dt_list != NULL)
3297 if (dt_list->derived->from_intmod != INTMOD_NONE
3298 && dt_list->derived->intmod_sym_id == sym_id)
3299 return dt_list->derived;
3301 dt_list = dt_list->next;
3308 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3309 with C. This is necessary for any derived type that is BIND(C) and for
3310 derived types that are parameters to functions that are BIND(C). All
3311 fields of the derived type are required to be interoperable, and are tested
3312 for such. If an error occurs, the errors are reported here, allowing for
3313 multiple errors to be handled for a single derived type. */
3316 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3318 gfc_component *curr_comp = NULL;
3319 gfc_try is_c_interop = FAILURE;
3320 gfc_try retval = SUCCESS;
3322 if (derived_sym == NULL)
3323 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3324 "unexpectedly NULL");
3326 /* If we've already looked at this derived symbol, do not look at it again
3327 so we don't repeat warnings/errors. */
3328 if (derived_sym->ts.is_c_interop)
3331 /* The derived type must have the BIND attribute to be interoperable
3332 J3/04-007, Section 15.2.3. */
3333 if (derived_sym->attr.is_bind_c != 1)
3335 derived_sym->ts.is_c_interop = 0;
3336 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3337 "attribute to be C interoperable", derived_sym->name,
3338 &(derived_sym->declared_at));
3342 curr_comp = derived_sym->components;
3344 /* TODO: is this really an error? */
3345 if (curr_comp == NULL)
3347 gfc_error ("Derived type '%s' at %L is empty",
3348 derived_sym->name, &(derived_sym->declared_at));
3352 /* Initialize the derived type as being C interoperable.
3353 If we find an error in the components, this will be set false. */
3354 derived_sym->ts.is_c_interop = 1;
3356 /* Loop through the list of components to verify that the kind of
3357 each is a C interoperable type. */
3360 /* The components cannot be pointers (fortran sense).
3361 J3/04-007, Section 15.2.3, C1505. */
3362 if (curr_comp->attr.pointer != 0)
3364 gfc_error ("Component '%s' at %L cannot have the "
3365 "POINTER 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 /* The components cannot be allocatable.
3373 J3/04-007, Section 15.2.3, C1505. */
3374 if (curr_comp->attr.allocatable != 0)
3376 gfc_error ("Component '%s' at %L cannot have the "
3377 "ALLOCATABLE attribute because it is a member "
3378 "of the BIND(C) derived type '%s' at %L",
3379 curr_comp->name, &(curr_comp->loc),
3380 derived_sym->name, &(derived_sym->declared_at));
3384 /* BIND(C) derived types must have interoperable components. */
3385 if (curr_comp->ts.type == BT_DERIVED
3386 && curr_comp->ts.derived->ts.is_iso_c != 1
3387 && curr_comp->ts.derived != derived_sym)
3389 /* This should be allowed; the draft says a derived-type can not
3390 have type parameters if it is has the BIND attribute. Type
3391 parameters seem to be for making parameterized derived types.
3392 There's no need to verify the type if it is c_ptr/c_funptr. */
3393 retval = verify_bind_c_derived_type (curr_comp->ts.derived);
3397 /* Grab the typespec for the given component and test the kind. */
3398 is_c_interop = verify_c_interop (&(curr_comp->ts), curr_comp->name,
3401 if (is_c_interop != SUCCESS)
3403 /* Report warning and continue since not fatal. The
3404 draft does specify a constraint that requires all fields
3405 to interoperate, but if the user says real(4), etc., it
3406 may interoperate with *something* in C, but the compiler
3407 most likely won't know exactly what. Further, it may not
3408 interoperate with the same data type(s) in C if the user
3409 recompiles with different flags (e.g., -m32 and -m64 on
3410 x86_64 and using integer(4) to claim interop with a
3412 if (derived_sym->attr.is_bind_c == 1)
3413 /* If the derived type is bind(c), all fields must be
3415 gfc_warning ("Component '%s' in derived type '%s' at %L "
3416 "may not be C interoperable, even though "
3417 "derived type '%s' is BIND(C)",
3418 curr_comp->name, derived_sym->name,
3419 &(curr_comp->loc), derived_sym->name);
3421 /* If derived type is param to bind(c) routine, or to one
3422 of the iso_c_binding procs, it must be interoperable, so
3423 all fields must interop too. */
3424 gfc_warning ("Component '%s' in derived type '%s' at %L "
3425 "may not be C interoperable",
3426 curr_comp->name, derived_sym->name,
3431 curr_comp = curr_comp->next;
3432 } while (curr_comp != NULL);
3435 /* Make sure we don't have conflicts with the attributes. */
3436 if (derived_sym->attr.access == ACCESS_PRIVATE)
3438 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3439 "PRIVATE and BIND(C) attributes", derived_sym->name,
3440 &(derived_sym->declared_at));
3444 if (derived_sym->attr.sequence != 0)
3446 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3447 "attribute because it is BIND(C)", derived_sym->name,
3448 &(derived_sym->declared_at));
3452 /* Mark the derived type as not being C interoperable if we found an
3453 error. If there were only warnings, proceed with the assumption
3454 it's interoperable. */
3455 if (retval == FAILURE)
3456 derived_sym->ts.is_c_interop = 0;
3462 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3465 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3466 const char *module_name)
3468 gfc_symtree *tmp_symtree;
3469 gfc_symbol *tmp_sym;
3471 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3473 if (tmp_symtree != NULL)
3474 tmp_sym = tmp_symtree->n.sym;
3478 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3479 "create symbol for %s", ptr_name);
3482 /* Set up the symbol's important fields. Save attr required so we can
3483 initialize the ptr to NULL. */
3484 tmp_sym->attr.save = SAVE_EXPLICIT;
3485 tmp_sym->ts.is_c_interop = 1;
3486 tmp_sym->attr.is_c_interop = 1;
3487 tmp_sym->ts.is_iso_c = 1;
3488 tmp_sym->ts.type = BT_DERIVED;
3490 /* The c_ptr and c_funptr derived types will provide the
3491 definition for c_null_ptr and c_null_funptr, respectively. */
3492 if (ptr_id == ISOCBINDING_NULL_PTR)
3493 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3495 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3496 if (tmp_sym->ts.derived == NULL)
3498 /* This can occur if the user forgot to declare c_ptr or
3499 c_funptr and they're trying to use one of the procedures
3500 that has arg(s) of the missing type. In this case, a
3501 regular version of the thing should have been put in the
3503 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3504 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3505 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3506 ? "_gfortran_iso_c_binding_c_ptr"
3507 : "_gfortran_iso_c_binding_c_funptr"));
3509 tmp_sym->ts.derived =
3510 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3511 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3514 /* Module name is some mangled version of iso_c_binding. */
3515 tmp_sym->module = gfc_get_string (module_name);
3517 /* Say it's from the iso_c_binding module. */
3518 tmp_sym->attr.is_iso_c = 1;
3520 tmp_sym->attr.use_assoc = 1;
3521 tmp_sym->attr.is_bind_c = 1;
3522 /* Set the binding_label. */
3523 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3525 /* Set the c_address field of c_null_ptr and c_null_funptr to
3526 the value of NULL. */
3527 tmp_sym->value = gfc_get_expr ();
3528 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3529 tmp_sym->value->ts.type = BT_DERIVED;
3530 tmp_sym->value->ts.derived = tmp_sym->ts.derived;
3531 /* Create a constructor with no expr, that way we can recognize if the user
3532 tries to call the structure constructor for one of the iso_c_binding
3533 derived types during resolution (resolve_structure_cons). */
3534 tmp_sym->value->value.constructor = gfc_get_constructor ();
3535 /* Must declare c_null_ptr and c_null_funptr as having the
3536 PARAMETER attribute so they can be used in init expressions. */
3537 tmp_sym->attr.flavor = FL_PARAMETER;
3543 /* Add a formal argument, gfc_formal_arglist, to the
3544 end of the given list of arguments. Set the reference to the
3545 provided symbol, param_sym, in the argument. */
3548 add_formal_arg (gfc_formal_arglist **head,
3549 gfc_formal_arglist **tail,
3550 gfc_formal_arglist *formal_arg,
3551 gfc_symbol *param_sym)
3553 /* Put in list, either as first arg or at the tail (curr arg). */
3555 *head = *tail = formal_arg;
3558 (*tail)->next = formal_arg;
3559 (*tail) = formal_arg;
3562 (*tail)->sym = param_sym;
3563 (*tail)->next = NULL;
3569 /* Generates a symbol representing the CPTR argument to an
3570 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3571 CPTR and add it to the provided argument list. */
3574 gen_cptr_param (gfc_formal_arglist **head,
3575 gfc_formal_arglist **tail,
3576 const char *module_name,
3577 gfc_namespace *ns, const char *c_ptr_name,
3580 gfc_symbol *param_sym = NULL;
3581 gfc_symbol *c_ptr_sym = NULL;
3582 gfc_symtree *param_symtree = NULL;
3583 gfc_formal_arglist *formal_arg = NULL;
3584 const char *c_ptr_in;
3585 const char *c_ptr_type = NULL;
3587 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3588 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3590 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3592 if(c_ptr_name == NULL)
3593 c_ptr_in = "gfc_cptr__";
3595 c_ptr_in = c_ptr_name;
3596 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree);
3597 if (param_symtree != NULL)
3598 param_sym = param_symtree->n.sym;
3600 gfc_internal_error ("gen_cptr_param(): Unable to "
3601 "create symbol for %s", c_ptr_in);
3603 /* Set up the appropriate fields for the new c_ptr param sym. */
3605 param_sym->attr.flavor = FL_DERIVED;
3606 param_sym->ts.type = BT_DERIVED;
3607 param_sym->attr.intent = INTENT_IN;
3608 param_sym->attr.dummy = 1;
3610 /* This will pass the ptr to the iso_c routines as a (void *). */
3611 param_sym->attr.value = 1;
3612 param_sym->attr.use_assoc = 1;
3614 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3616 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3617 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3619 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3620 if (c_ptr_sym == NULL)
3622 /* This can happen if the user did not define c_ptr but they are
3623 trying to use one of the iso_c_binding functions that need it. */
3624 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3625 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3626 (const char *)c_ptr_type);
3628 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3629 (const char *)c_ptr_type);
3631 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3634 param_sym->ts.derived = c_ptr_sym;
3635 param_sym->module = gfc_get_string (module_name);
3637 /* Make new formal arg. */
3638 formal_arg = gfc_get_formal_arglist ();
3639 /* Add arg to list of formal args (the CPTR arg). */
3640 add_formal_arg (head, tail, formal_arg, param_sym);
3644 /* Generates a symbol representing the FPTR argument to an
3645 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3646 FPTR and add it to the provided argument list. */
3649 gen_fptr_param (gfc_formal_arglist **head,
3650 gfc_formal_arglist **tail,
3651 const char *module_name,
3652 gfc_namespace *ns, const char *f_ptr_name, int proc)
3654 gfc_symbol *param_sym = NULL;
3655 gfc_symtree *param_symtree = NULL;
3656 gfc_formal_arglist *formal_arg = NULL;
3657 const char *f_ptr_out = "gfc_fptr__";
3659 if (f_ptr_name != NULL)
3660 f_ptr_out = f_ptr_name;
3662 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree);
3663 if (param_symtree != NULL)
3664 param_sym = param_symtree->n.sym;
3666 gfc_internal_error ("generateFPtrParam(): Unable to "
3667 "create symbol for %s", f_ptr_out);
3669 /* Set up the necessary fields for the fptr output param sym. */
3672 param_sym->attr.proc_pointer = 1;
3674 param_sym->attr.pointer = 1;
3675 param_sym->attr.dummy = 1;
3676 param_sym->attr.use_assoc = 1;
3678 /* ISO C Binding type to allow any pointer type as actual param. */
3679 param_sym->ts.type = BT_VOID;
3680 param_sym->module = gfc_get_string (module_name);
3683 formal_arg = gfc_get_formal_arglist ();
3684 /* Add arg to list of formal args. */
3685 add_formal_arg (head, tail, formal_arg, param_sym);
3689 /* Generates a symbol representing the optional SHAPE argument for the
3690 iso_c_binding c_f_pointer() procedure. Also, create a
3691 gfc_formal_arglist for the SHAPE and add it to the provided
3695 gen_shape_param (gfc_formal_arglist **head,
3696 gfc_formal_arglist **tail,
3697 const char *module_name,
3698 gfc_namespace *ns, const char *shape_param_name)
3700 gfc_symbol *param_sym = NULL;
3701 gfc_symtree *param_symtree = NULL;
3702 gfc_formal_arglist *formal_arg = NULL;
3703 const char *shape_param = "gfc_shape_array__";
3706 if (shape_param_name != NULL)
3707 shape_param = shape_param_name;
3709 gfc_get_sym_tree (shape_param, ns, ¶m_symtree);
3710 if (param_symtree != NULL)
3711 param_sym = param_symtree->n.sym;
3713 gfc_internal_error ("generateShapeParam(): Unable to "
3714 "create symbol for %s", shape_param);
3716 /* Set up the necessary fields for the shape input param sym. */
3718 param_sym->attr.dummy = 1;
3719 param_sym->attr.use_assoc = 1;
3721 /* Integer array, rank 1, describing the shape of the object. Make it's
3722 type BT_VOID initially so we can accept any type/kind combination of
3723 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3724 of BT_INTEGER type. */
3725 param_sym->ts.type = BT_VOID;
3727 /* Initialize the kind to default integer. However, it will be overridden
3728 during resolution to match the kind of the SHAPE parameter given as
3729 the actual argument (to allow for any valid integer kind). */
3730 param_sym->ts.kind = gfc_default_integer_kind;
3731 param_sym->as = gfc_get_array_spec ();
3733 /* Clear out the dimension info for the array. */
3734 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3736 param_sym->as->lower[i] = NULL;
3737 param_sym->as->upper[i] = NULL;
3739 param_sym->as->rank = 1;
3740 param_sym->as->lower[0] = gfc_int_expr (1);
3742 /* The extent is unknown until we get it. The length give us
3743 the rank the incoming pointer. */
3744 param_sym->as->type = AS_ASSUMED_SHAPE;
3746 /* The arg is also optional; it is required iff the second arg
3747 (fptr) is to an array, otherwise, it's ignored. */
3748 param_sym->attr.optional = 1;
3749 param_sym->attr.intent = INTENT_IN;
3750 param_sym->attr.dimension = 1;
3751 param_sym->module = gfc_get_string (module_name);
3754 formal_arg = gfc_get_formal_arglist ();
3755 /* Add arg to list of formal args. */
3756 add_formal_arg (head, tail, formal_arg, param_sym);
3759 /* Add a procedure interface to the given symbol (i.e., store a
3760 reference to the list of formal arguments). */
3763 add_proc_interface (gfc_symbol *sym, ifsrc source,
3764 gfc_formal_arglist *formal)
3767 sym->formal = formal;
3768 sym->attr.if_source = source;
3771 /* Copy the formal args from an existing symbol, src, into a new
3772 symbol, dest. New formal args are created, and the description of
3773 each arg is set according to the existing ones. This function is
3774 used when creating procedure declaration variables from a procedure
3775 declaration statement (see match_proc_decl()) to create the formal
3776 args based on the args of a given named interface. */
3779 copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
3781 gfc_formal_arglist *head = NULL;
3782 gfc_formal_arglist *tail = NULL;
3783 gfc_formal_arglist *formal_arg = NULL;
3784 gfc_formal_arglist *curr_arg = NULL;
3785 gfc_formal_arglist *formal_prev = NULL;
3786 /* Save current namespace so we can change it for formal args. */
3787 gfc_namespace *parent_ns = gfc_current_ns;
3789 /* Create a new namespace, which will be the formal ns (namespace
3790 of the formal args). */
3791 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3792 gfc_current_ns->proc_name = dest;
3794 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3796 formal_arg = gfc_get_formal_arglist ();
3797 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
3799 /* May need to copy more info for the symbol. */
3800 formal_arg->sym->attr = curr_arg->sym->attr;
3801 formal_arg->sym->ts = curr_arg->sym->ts;
3802 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
3803 copy_formal_args (formal_arg->sym, curr_arg->sym);
3805 /* If this isn't the first arg, set up the next ptr. For the
3806 last arg built, the formal_arg->next will never get set to
3807 anything other than NULL. */
3808 if (formal_prev != NULL)
3809 formal_prev->next = formal_arg;
3811 formal_arg->next = NULL;
3813 formal_prev = formal_arg;
3815 /* Add arg to list of formal args. */
3816 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3819 /* Add the interface to the symbol. */
3820 add_proc_interface (dest, IFSRC_DECL, head);
3822 /* Store the formal namespace information. */
3823 if (dest->formal != NULL)
3824 /* The current ns should be that for the dest proc. */
3825 dest->formal_ns = gfc_current_ns;
3826 /* Restore the current namespace to what it was on entry. */
3827 gfc_current_ns = parent_ns;
3830 /* Builds the parameter list for the iso_c_binding procedure
3831 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3832 generic version of either the c_f_pointer or c_f_procpointer
3833 functions. The new_proc_sym represents a "resolved" version of the
3834 symbol. The functions are resolved to match the types of their
3835 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3836 something similar to c_f_pointer_i4 if the type of data object fptr
3837 pointed to was a default integer. The actual name of the resolved
3838 procedure symbol is further mangled with the module name, etc., but
3839 the idea holds true. */
3842 build_formal_args (gfc_symbol *new_proc_sym,
3843 gfc_symbol *old_sym, int add_optional_arg)
3845 gfc_formal_arglist *head = NULL, *tail = NULL;
3846 gfc_namespace *parent_ns = NULL;
3848 parent_ns = gfc_current_ns;
3849 /* Create a new namespace, which will be the formal ns (namespace
3850 of the formal args). */
3851 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
3852 gfc_current_ns->proc_name = new_proc_sym;
3854 /* Generate the params. */
3855 if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
3857 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3858 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3859 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3860 gfc_current_ns, "fptr", 1);
3862 else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3864 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3865 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3866 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3867 gfc_current_ns, "fptr", 0);
3868 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3869 gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
3870 gfc_current_ns, "shape");
3873 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3875 /* c_associated has one required arg and one optional; both
3877 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3878 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
3879 if (add_optional_arg)
3881 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3882 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
3883 /* The last param is optional so mark it as such. */
3884 tail->sym->attr.optional = 1;
3888 /* Add the interface (store formal args to new_proc_sym). */
3889 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
3891 /* Set up the formal_ns pointer to the one created for the
3892 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3893 new_proc_sym->formal_ns = gfc_current_ns;
3895 gfc_current_ns = parent_ns;
3899 std_for_isocbinding_symbol (int id)
3903 #define NAMED_INTCST(a,b,c,d) \
3906 #include "iso-c-binding.def"
3909 return GFC_STD_F2003;
3913 /* Generate the given set of C interoperable kind objects, or all
3914 interoperable kinds. This function will only be given kind objects
3915 for valid iso_c_binding defined types because this is verified when
3916 the 'use' statement is parsed. If the user gives an 'only' clause,
3917 the specific kinds are looked up; if they don't exist, an error is
3918 reported. If the user does not give an 'only' clause, all
3919 iso_c_binding symbols are generated. If a list of specific kinds
3920 is given, it must have a NULL in the first empty spot to mark the
3925 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
3926 const char *local_name)
3928 const char *const name = (local_name && local_name[0]) ? local_name
3929 : c_interop_kinds_table[s].name;
3930 gfc_symtree *tmp_symtree = NULL;
3931 gfc_symbol *tmp_sym = NULL;
3932 gfc_dt_list **dt_list_ptr = NULL;
3933 gfc_component *tmp_comp = NULL;
3934 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
3937 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
3939 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
3941 /* Already exists in this scope so don't re-add it.
3942 TODO: we should probably check that it's really the same symbol. */
3943 if (tmp_symtree != NULL)
3946 /* Create the sym tree in the current ns. */
3947 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
3949 tmp_sym = tmp_symtree->n.sym;
3951 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3954 /* Say what module this symbol belongs to. */
3955 tmp_sym->module = gfc_get_string (mod_name);
3956 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
3957 tmp_sym->intmod_sym_id = s;
3962 #define NAMED_INTCST(a,b,c,d) case a :
3963 #define NAMED_REALCST(a,b,c) case a :
3964 #define NAMED_CMPXCST(a,b,c) case a :
3965 #define NAMED_LOGCST(a,b,c) case a :
3966 #define NAMED_CHARKNDCST(a,b,c) case a :
3967 #include "iso-c-binding.def"
3969 tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
3971 /* Initialize an integer constant expression node. */
3972 tmp_sym->attr.flavor = FL_PARAMETER;
3973 tmp_sym->ts.type = BT_INTEGER;
3974 tmp_sym->ts.kind = gfc_default_integer_kind;
3976 /* Mark this type as a C interoperable one. */
3977 tmp_sym->ts.is_c_interop = 1;
3978 tmp_sym->ts.is_iso_c = 1;
3979 tmp_sym->value->ts.is_c_interop = 1;
3980 tmp_sym->value->ts.is_iso_c = 1;
3981 tmp_sym->attr.is_c_interop = 1;
3983 /* Tell what f90 type this c interop kind is valid. */
3984 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
3986 /* Say it's from the iso_c_binding module. */
3987 tmp_sym->attr.is_iso_c = 1;
3989 /* Make it use associated. */
3990 tmp_sym->attr.use_assoc = 1;
3994 #define NAMED_CHARCST(a,b,c) case a :
3995 #include "iso-c-binding.def"
3997 /* Initialize an integer constant expression node for the
3998 length of the character. */
3999 tmp_sym->value = gfc_get_expr ();
4000 tmp_sym->value->expr_type = EXPR_CONSTANT;
4001 tmp_sym->value->ts.type = BT_CHARACTER;
4002 tmp_sym->value->ts.kind = gfc_default_character_kind;
4003 tmp_sym->value->where = gfc_current_locus;
4004 tmp_sym->value->ts.is_c_interop = 1;
4005 tmp_sym->value->ts.is_iso_c = 1;
4006 tmp_sym->value->value.character.length = 1;
4007 tmp_sym->value->value.character.string = gfc_get_wide_string (2);
4008 tmp_sym->value->value.character.string[0]
4009 = (gfc_char_t) c_interop_kinds_table[s].value;
4010 tmp_sym->value->value.character.string[1] = '\0';
4011 tmp_sym->ts.cl = gfc_get_charlen ();
4012 tmp_sym->ts.cl->length = gfc_int_expr (1);
4014 /* May not need this in both attr and ts, but do need in
4015 attr for writing module file. */
4016 tmp_sym->attr.is_c_interop = 1;
4018 tmp_sym->attr.flavor = FL_PARAMETER;
4019 tmp_sym->ts.type = BT_CHARACTER;
4021 /* Need to set it to the C_CHAR kind. */
4022 tmp_sym->ts.kind = gfc_default_character_kind;
4024 /* Mark this type as a C interoperable one. */
4025 tmp_sym->ts.is_c_interop = 1;
4026 tmp_sym->ts.is_iso_c = 1;
4028 /* Tell what f90 type this c interop kind is valid. */
4029 tmp_sym->ts.f90_type = BT_CHARACTER;
4031 /* Say it's from the iso_c_binding module. */
4032 tmp_sym->attr.is_iso_c = 1;
4034 /* Make it use associated. */
4035 tmp_sym->attr.use_assoc = 1;
4038 case ISOCBINDING_PTR:
4039 case ISOCBINDING_FUNPTR:
4041 /* Initialize an integer constant expression node. */
4042 tmp_sym->attr.flavor = FL_DERIVED;
4043 tmp_sym->ts.is_c_interop = 1;
4044 tmp_sym->attr.is_c_interop = 1;
4045 tmp_sym->attr.is_iso_c = 1;
4046 tmp_sym->ts.is_iso_c = 1;
4047 tmp_sym->ts.type = BT_DERIVED;
4049 /* A derived type must have the bind attribute to be
4050 interoperable (J3/04-007, Section 15.2.3), even though
4051 the binding label is not used. */
4052 tmp_sym->attr.is_bind_c = 1;
4054 tmp_sym->attr.referenced = 1;
4056 tmp_sym->ts.derived = tmp_sym;
4058 /* Add the symbol created for the derived type to the current ns. */
4059 dt_list_ptr = &(gfc_derived_types);
4060 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4061 dt_list_ptr = &((*dt_list_ptr)->next);
4063 /* There is already at least one derived type in the list, so append
4064 the one we're currently building for c_ptr or c_funptr. */
4065 if (*dt_list_ptr != NULL)
4066 dt_list_ptr = &((*dt_list_ptr)->next);
4067 (*dt_list_ptr) = gfc_get_dt_list ();
4068 (*dt_list_ptr)->derived = tmp_sym;
4069 (*dt_list_ptr)->next = NULL;
4071 /* Set up the component of the derived type, which will be
4072 an integer with kind equal to c_ptr_size. Mangle the name of
4073 the field for the c_address to prevent the curious user from
4074 trying to access it from Fortran. */
4075 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
4076 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
4077 if (tmp_comp == NULL)
4078 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4079 "create component for c_address");
4081 tmp_comp->ts.type = BT_INTEGER;
4083 /* Set this because the module will need to read/write this field. */
4084 tmp_comp->ts.f90_type = BT_INTEGER;
4086 /* The kinds for c_ptr and c_funptr are the same. */
4087 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4088 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4090 tmp_comp->attr.pointer = 0;
4091 tmp_comp->attr.dimension = 0;
4093 /* Mark the component as C interoperable. */
4094 tmp_comp->ts.is_c_interop = 1;
4096 /* Make it use associated (iso_c_binding module). */
4097 tmp_sym->attr.use_assoc = 1;
4100 case ISOCBINDING_NULL_PTR:
4101 case ISOCBINDING_NULL_FUNPTR:
4102 gen_special_c_interop_ptr (s, name, mod_name);
4105 case ISOCBINDING_F_POINTER:
4106 case ISOCBINDING_ASSOCIATED:
4107 case ISOCBINDING_LOC:
4108 case ISOCBINDING_FUNLOC:
4109 case ISOCBINDING_F_PROCPOINTER:
4111 tmp_sym->attr.proc = PROC_MODULE;
4113 /* Use the procedure's name as it is in the iso_c_binding module for
4114 setting the binding label in case the user renamed the symbol. */
4115 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
4116 c_interop_kinds_table[s].name);
4117 tmp_sym->attr.is_iso_c = 1;
4118 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4119 tmp_sym->attr.subroutine = 1;
4122 /* TODO! This needs to be finished more for the expr of the
4123 function or something!
4124 This may not need to be here, because trying to do c_loc
4126 if (s == ISOCBINDING_ASSOCIATED)
4128 tmp_sym->attr.function = 1;
4129 tmp_sym->ts.type = BT_LOGICAL;
4130 tmp_sym->ts.kind = gfc_default_logical_kind;
4131 tmp_sym->result = tmp_sym;
4135 /* Here, we're taking the simple approach. We're defining
4136 c_loc as an external identifier so the compiler will put
4137 what we expect on the stack for the address we want the
4139 tmp_sym->ts.type = BT_DERIVED;
4140 if (s == ISOCBINDING_LOC)
4141 tmp_sym->ts.derived =
4142 get_iso_c_binding_dt (ISOCBINDING_PTR);
4144 tmp_sym->ts.derived =
4145 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4147 if (tmp_sym->ts.derived == NULL)
4149 /* Create the necessary derived type so we can continue
4150 processing the file. */
4151 generate_isocbinding_symbol
4152 (mod_name, s == ISOCBINDING_FUNLOC
4153 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4154 (const char *)(s == ISOCBINDING_FUNLOC
4155 ? "_gfortran_iso_c_binding_c_funptr"
4156 : "_gfortran_iso_c_binding_c_ptr"));
4157 tmp_sym->ts.derived =
4158 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4159 ? ISOCBINDING_FUNPTR
4163 /* The function result is itself (no result clause). */
4164 tmp_sym->result = tmp_sym;
4165 tmp_sym->attr.external = 1;
4166 tmp_sym->attr.use_assoc = 0;
4167 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4168 tmp_sym->attr.proc = PROC_UNKNOWN;
4172 tmp_sym->attr.flavor = FL_PROCEDURE;
4173 tmp_sym->attr.contained = 0;
4175 /* Try using this builder routine, with the new and old symbols
4176 both being the generic iso_c proc sym being created. This
4177 will create the formal args (and the new namespace for them).
4178 Don't build an arg list for c_loc because we're going to treat
4179 c_loc as an external procedure. */
4180 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4181 /* The 1 says to add any optional args, if applicable. */
4182 build_formal_args (tmp_sym, tmp_sym, 1);
4184 /* Set this after setting up the symbol, to prevent error messages. */
4185 tmp_sym->attr.use_assoc = 1;
4187 /* This symbol will not be referenced directly. It will be
4188 resolved to the implementation for the given f90 kind. */
4189 tmp_sym->attr.referenced = 0;
4199 /* Creates a new symbol based off of an old iso_c symbol, with a new
4200 binding label. This function can be used to create a new,
4201 resolved, version of a procedure symbol for c_f_pointer or
4202 c_f_procpointer that is based on the generic symbols. A new
4203 parameter list is created for the new symbol using
4204 build_formal_args(). The add_optional_flag specifies whether the
4205 to add the optional SHAPE argument. The new symbol is
4209 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4210 char *new_binding_label, int add_optional_arg)
4212 gfc_symtree *new_symtree = NULL;
4214 /* See if we have a symbol by that name already available, looking
4215 through any parent namespaces. */
4216 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4217 if (new_symtree != NULL)
4218 /* Return the existing symbol. */
4219 return new_symtree->n.sym;
4221 /* Create the symtree/symbol, with attempted host association. */
4222 gfc_get_ha_sym_tree (new_name, &new_symtree);
4223 if (new_symtree == NULL)
4224 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4225 "symtree for '%s'", new_name);
4227 /* Now fill in the fields of the resolved symbol with the old sym. */
4228 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4229 new_symtree->n.sym->attr = old_sym->attr;
4230 new_symtree->n.sym->ts = old_sym->ts;
4231 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4232 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4233 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4234 /* Build the formal arg list. */
4235 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4237 gfc_commit_symbol (new_symtree->n.sym);
4239 return new_symtree->n.sym;
4243 /* Check that a symbol is already typed. If strict is not set, an untyped
4244 symbol is acceptable for non-standard-conforming mode. */
4247 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4248 bool strict, locus where)
4252 if (gfc_matching_prefix)
4255 /* Check for the type and try to give it an implicit one. */
4256 if (sym->ts.type == BT_UNKNOWN
4257 && gfc_set_default_type (sym, 0, ns) == FAILURE)
4261 gfc_error ("Symbol '%s' is used before it is typed at %L",
4266 if (gfc_notify_std (GFC_STD_GNU,
4267 "Extension: Symbol '%s' is used before"
4268 " it is typed at %L", sym->name, &where) == FAILURE)
4272 /* Everything is ok. */
4277 /* Get the super-type of a given derived type. */
4280 gfc_get_derived_super_type (gfc_symbol* derived)
4282 if (!derived->attr.extension)
4285 gcc_assert (derived->components);
4286 gcc_assert (derived->components->ts.type == BT_DERIVED);
4287 gcc_assert (derived->components->ts.derived);
4289 return derived->components->ts.derived;
4293 /* Find a type-bound procedure by name for a derived-type (looking recursively
4294 through the super-types). */
4297 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
4298 const char* name, bool noaccess)
4302 /* Set default to failure. */
4306 /* Try to find it in the current type's namespace. */
4307 gcc_assert (derived->f2k_derived);
4308 res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
4309 if (res && res->typebound)
4315 if (!noaccess && derived->attr.use_assoc
4316 && res->typebound->access == ACCESS_PRIVATE)
4318 gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
4326 /* Otherwise, recurse on parent type if derived is an extension. */
4327 if (derived->attr.extension)
4329 gfc_symbol* super_type;
4330 super_type = gfc_get_derived_super_type (derived);
4331 gcc_assert (super_type);
4332 return gfc_find_typebound_proc (super_type, t, name, noaccess);
4335 /* Nothing found. */