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/>. */
30 /* Strings for all symbol attributes. We use these for dumping the
31 parse tree, in error messages, and also when reading and writing
34 const mstring flavors[] =
36 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
37 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
38 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
39 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
40 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
44 const mstring procedures[] =
46 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
47 minit ("MODULE-PROC", PROC_MODULE),
48 minit ("INTERNAL-PROC", PROC_INTERNAL),
49 minit ("DUMMY-PROC", PROC_DUMMY),
50 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
51 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
52 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
56 const mstring intents[] =
58 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
59 minit ("IN", INTENT_IN),
60 minit ("OUT", INTENT_OUT),
61 minit ("INOUT", INTENT_INOUT),
65 const mstring access_types[] =
67 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
68 minit ("PUBLIC", ACCESS_PUBLIC),
69 minit ("PRIVATE", ACCESS_PRIVATE),
73 const mstring ifsrc_types[] =
75 minit ("UNKNOWN", IFSRC_UNKNOWN),
76 minit ("DECL", IFSRC_DECL),
77 minit ("BODY", IFSRC_IFBODY),
78 minit ("USAGE", IFSRC_USAGE)
81 const mstring save_status[] =
83 minit ("UNKNOWN", SAVE_NONE),
84 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
85 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
88 /* This is to make sure the backend generates setup code in the correct
91 static int next_dummy_order = 1;
94 gfc_namespace *gfc_current_ns;
96 gfc_gsymbol *gfc_gsym_root = NULL;
98 static gfc_symbol *changed_syms = NULL;
100 gfc_dt_list *gfc_derived_types;
103 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
105 /* The following static variable indicates whether a particular element has
106 been explicitly set or not. */
108 static int new_flag[GFC_LETTERS];
111 /* Handle a correctly parsed IMPLICIT NONE. */
114 gfc_set_implicit_none (void)
118 if (gfc_current_ns->seen_implicit_none)
120 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
124 gfc_current_ns->seen_implicit_none = 1;
126 for (i = 0; i < GFC_LETTERS; i++)
128 gfc_clear_ts (&gfc_current_ns->default_type[i]);
129 gfc_current_ns->set_flag[i] = 1;
134 /* Reset the implicit range flags. */
137 gfc_clear_new_implicit (void)
141 for (i = 0; i < GFC_LETTERS; i++)
146 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
149 gfc_add_new_implicit_range (int c1, int c2)
156 for (i = c1; i <= c2; i++)
160 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
172 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
173 the new implicit types back into the existing types will work. */
176 gfc_merge_new_implicit (gfc_typespec *ts)
180 if (gfc_current_ns->seen_implicit_none)
182 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
186 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",
197 gfc_current_ns->default_type[i] = *ts;
198 gfc_current_ns->set_flag[i] = 1;
205 /* Given a symbol, return a pointer to the typespec for its default type. */
208 gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
212 letter = sym->name[0];
214 if (gfc_option.flag_allow_leading_underscore && letter == '_')
215 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
216 "gfortran developers, and should not be used for "
217 "implicitly typed variables");
219 if (letter < 'a' || letter > 'z')
220 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
225 return &ns->default_type[letter - 'a'];
229 /* Given a pointer to a symbol, set its type according to the first
230 letter of its name. Fails if the letter in question has no default
234 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
238 if (sym->ts.type != BT_UNKNOWN)
239 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
241 ts = gfc_get_default_type (sym, ns);
243 if (ts->type == BT_UNKNOWN)
245 if (error_flag && !sym->attr.untyped)
247 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
248 sym->name, &sym->declared_at);
249 sym->attr.untyped = 1; /* Ensure we only give an error once. */
256 sym->attr.implicit_type = 1;
258 if (sym->attr.is_bind_c == 1)
260 /* BIND(C) variables should not be implicitly declared. */
261 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
262 "not be C interoperable", sym->name, &sym->declared_at);
263 sym->ts.f90_type = sym->ts.type;
266 if (sym->attr.dummy != 0)
268 if (sym->ns->proc_name != NULL
269 && (sym->ns->proc_name->attr.subroutine != 0
270 || sym->ns->proc_name->attr.function != 0)
271 && sym->ns->proc_name->attr.is_bind_c != 0)
273 /* Dummy args to a BIND(C) routine may not be interoperable if
274 they are implicitly typed. */
275 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
276 "be C interoperable but it is a dummy argument to "
277 "the BIND(C) procedure '%s' at %L", sym->name,
278 &(sym->declared_at), sym->ns->proc_name->name,
279 &(sym->ns->proc_name->declared_at));
280 sym->ts.f90_type = sym->ts.type;
288 /* This function is called from parse.c(parse_progunit) to check the
289 type of the function is not implicitly typed in the host namespace
290 and to implicitly type the function result, if necessary. */
293 gfc_check_function_type (gfc_namespace *ns)
295 gfc_symbol *proc = ns->proc_name;
297 if (!proc->attr.contained || proc->result->attr.implicit_type)
300 if (proc->result->ts.type == BT_UNKNOWN)
302 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
305 if (proc->result != proc)
307 proc->ts = proc->result->ts;
308 proc->as = gfc_copy_array_spec (proc->result->as);
309 proc->attr.dimension = proc->result->attr.dimension;
310 proc->attr.pointer = proc->result->attr.pointer;
311 proc->attr.allocatable = proc->result->attr.allocatable;
316 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
317 proc->result->name, &proc->result->declared_at);
318 proc->result->attr.untyped = 1;
324 /******************** Symbol attribute stuff *********************/
326 /* This is a generic conflict-checker. We do this to avoid having a
327 single conflict in two places. */
329 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
330 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
331 #define conf_std(a, b, std) if (attr->a && attr->b)\
340 check_conflict (symbol_attribute *attr, const char *name, locus *where)
342 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
343 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
344 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
345 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
346 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
347 *privat = "PRIVATE", *recursive = "RECURSIVE",
348 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
349 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
350 *function = "FUNCTION", *subroutine = "SUBROUTINE",
351 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
352 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
353 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
354 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
355 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
356 static const char *threadprivate = "THREADPRIVATE";
362 where = &gfc_current_locus;
364 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
368 standard = GFC_STD_F2003;
372 /* Check for attributes not allowed in a BLOCK DATA. */
373 if (gfc_current_state () == COMP_BLOCK_DATA)
377 if (attr->in_namelist)
379 if (attr->allocatable)
385 if (attr->access == ACCESS_PRIVATE)
387 if (attr->access == ACCESS_PUBLIC)
389 if (attr->intent != INTENT_UNKNOWN)
395 ("%s attribute not allowed in BLOCK DATA program unit at %L",
401 if (attr->save == SAVE_EXPLICIT)
404 conf (in_common, save);
407 switch (attr->flavor)
415 a1 = gfc_code2string (flavors, attr->flavor);
420 /* Conflicts between SAVE and PROCEDURE will be checked at
421 resolution stage, see "resolve_fl_procedure". */
430 conf (dummy, intrinsic);
431 conf (dummy, threadprivate);
432 conf (pointer, target);
433 conf (pointer, intrinsic);
434 conf (pointer, elemental);
435 conf (allocatable, elemental);
437 conf (target, external);
438 conf (target, intrinsic);
440 if (!attr->if_source)
441 conf (external, dimension); /* See Fortran 95's R504. */
443 conf (external, intrinsic);
444 conf (entry, intrinsic);
446 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
448 conf (external, subroutine);
449 conf (external, function);
452 conf (allocatable, pointer);
453 conf_std (allocatable, dummy, GFC_STD_F2003);
454 conf_std (allocatable, function, GFC_STD_F2003);
455 conf_std (allocatable, result, GFC_STD_F2003);
456 conf (elemental, recursive);
458 conf (in_common, dummy);
459 conf (in_common, allocatable);
460 conf (in_common, result);
462 conf (dummy, result);
464 conf (in_equivalence, use_assoc);
465 conf (in_equivalence, dummy);
466 conf (in_equivalence, target);
467 conf (in_equivalence, pointer);
468 conf (in_equivalence, function);
469 conf (in_equivalence, result);
470 conf (in_equivalence, entry);
471 conf (in_equivalence, allocatable);
472 conf (in_equivalence, threadprivate);
474 conf (in_namelist, pointer);
475 conf (in_namelist, allocatable);
477 conf (entry, result);
479 conf (function, subroutine);
481 if (!function && !subroutine)
482 conf (is_bind_c, dummy);
484 conf (is_bind_c, cray_pointer);
485 conf (is_bind_c, cray_pointee);
486 conf (is_bind_c, allocatable);
487 conf (is_bind_c, elemental);
489 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
490 Parameter conflict caught below. Also, value cannot be specified
491 for a dummy procedure. */
493 /* Cray pointer/pointee conflicts. */
494 conf (cray_pointer, cray_pointee);
495 conf (cray_pointer, dimension);
496 conf (cray_pointer, pointer);
497 conf (cray_pointer, target);
498 conf (cray_pointer, allocatable);
499 conf (cray_pointer, external);
500 conf (cray_pointer, intrinsic);
501 conf (cray_pointer, in_namelist);
502 conf (cray_pointer, function);
503 conf (cray_pointer, subroutine);
504 conf (cray_pointer, entry);
506 conf (cray_pointee, allocatable);
507 conf (cray_pointee, intent);
508 conf (cray_pointee, optional);
509 conf (cray_pointee, dummy);
510 conf (cray_pointee, target);
511 conf (cray_pointee, intrinsic);
512 conf (cray_pointee, pointer);
513 conf (cray_pointee, entry);
514 conf (cray_pointee, in_common);
515 conf (cray_pointee, in_equivalence);
516 conf (cray_pointee, threadprivate);
519 conf (data, function);
521 conf (data, allocatable);
522 conf (data, use_assoc);
524 conf (value, pointer)
525 conf (value, allocatable)
526 conf (value, subroutine)
527 conf (value, function)
528 conf (value, volatile_)
529 conf (value, dimension)
530 conf (value, external)
533 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
536 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
540 conf (is_protected, intrinsic)
541 conf (is_protected, external)
542 conf (is_protected, in_common)
544 conf (volatile_, intrinsic)
545 conf (volatile_, external)
547 if (attr->volatile_ && attr->intent == INTENT_IN)
554 conf (procedure, allocatable)
555 conf (procedure, dimension)
556 conf (procedure, intrinsic)
557 conf (procedure, is_protected)
558 conf (procedure, target)
559 conf (procedure, value)
560 conf (procedure, volatile_)
561 conf (procedure, entry)
563 a1 = gfc_code2string (flavors, attr->flavor);
565 if (attr->in_namelist
566 && attr->flavor != FL_VARIABLE
567 && attr->flavor != FL_PROCEDURE
568 && attr->flavor != FL_UNKNOWN)
574 switch (attr->flavor)
584 conf2 (is_protected);
594 conf2 (threadprivate);
596 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
598 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
599 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
606 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
617 /* Conflicts with INTENT will be checked at resolution stage,
618 see "resolve_fl_procedure". */
620 if (attr->subroutine)
628 conf2 (threadprivate);
633 case PROC_ST_FUNCTION:
645 conf2 (threadprivate);
665 conf2 (threadprivate);
667 if (attr->intent != INTENT_UNKNOWN)
683 conf2 (is_protected);
689 conf2 (threadprivate);
702 gfc_error ("%s attribute conflicts with %s attribute at %L",
705 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
706 a1, a2, name, where);
713 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
714 "with %s attribute at %L", a1, a2,
719 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
720 "with %s attribute in '%s' at %L",
721 a1, a2, name, where);
730 /* Mark a symbol as referenced. */
733 gfc_set_sym_referenced (gfc_symbol *sym)
736 if (sym->attr.referenced)
739 sym->attr.referenced = 1;
741 /* Remember which order dummy variables are accessed in. */
743 sym->dummy_order = next_dummy_order++;
747 /* Common subroutine called by attribute changing subroutines in order
748 to prevent them from changing a symbol that has been
749 use-associated. Returns zero if it is OK to change the symbol,
753 check_used (symbol_attribute *attr, const char *name, locus *where)
756 if (attr->use_assoc == 0)
760 where = &gfc_current_locus;
763 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
766 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
773 /* Generate an error because of a duplicate attribute. */
776 duplicate_attr (const char *attr, locus *where)
780 where = &gfc_current_locus;
782 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
786 /* Called from decl.c (attr_decl1) to check attributes, when declared
790 gfc_add_attribute (symbol_attribute *attr, locus *where)
793 if (check_used (attr, NULL, where))
796 return check_conflict (attr, NULL, where);
800 gfc_add_allocatable (symbol_attribute *attr, locus *where)
803 if (check_used (attr, NULL, where))
806 if (attr->allocatable)
808 duplicate_attr ("ALLOCATABLE", where);
812 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
813 && gfc_find_state (COMP_INTERFACE) == FAILURE)
815 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
820 attr->allocatable = 1;
821 return check_conflict (attr, NULL, where);
826 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
829 if (check_used (attr, name, where))
834 duplicate_attr ("DIMENSION", where);
838 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
839 && gfc_find_state (COMP_INTERFACE) == FAILURE)
841 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
842 "at %L", name, where);
847 return check_conflict (attr, name, where);
852 gfc_add_external (symbol_attribute *attr, locus *where)
855 if (check_used (attr, NULL, where))
860 duplicate_attr ("EXTERNAL", where);
864 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
867 attr->proc_pointer = 1;
872 return check_conflict (attr, NULL, where);
877 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
880 if (check_used (attr, NULL, where))
885 duplicate_attr ("INTRINSIC", where);
891 return check_conflict (attr, NULL, where);
896 gfc_add_optional (symbol_attribute *attr, locus *where)
899 if (check_used (attr, NULL, where))
904 duplicate_attr ("OPTIONAL", where);
909 return check_conflict (attr, NULL, where);
914 gfc_add_pointer (symbol_attribute *attr, locus *where)
917 if (check_used (attr, NULL, where))
920 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
921 && gfc_find_state (COMP_INTERFACE) == FAILURE))
923 duplicate_attr ("POINTER", where);
927 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
928 || (attr->if_source == IFSRC_IFBODY
929 && gfc_find_state (COMP_INTERFACE) == FAILURE))
930 attr->proc_pointer = 1;
934 return check_conflict (attr, NULL, where);
939 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
942 if (check_used (attr, NULL, where))
945 attr->cray_pointer = 1;
946 return check_conflict (attr, NULL, where);
951 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
954 if (check_used (attr, NULL, where))
957 if (attr->cray_pointee)
959 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
960 " statements", where);
964 attr->cray_pointee = 1;
965 return check_conflict (attr, NULL, where);
970 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
972 if (check_used (attr, name, where))
975 if (attr->is_protected)
977 if (gfc_notify_std (GFC_STD_LEGACY,
978 "Duplicate PROTECTED attribute specified at %L",
984 attr->is_protected = 1;
985 return check_conflict (attr, name, where);
990 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
993 if (check_used (attr, name, where))
997 return check_conflict (attr, name, where);
1002 gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
1005 if (check_used (attr, name, where))
1008 if (gfc_pure (NULL))
1011 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1016 if (attr->save == SAVE_EXPLICIT)
1018 if (gfc_notify_std (GFC_STD_LEGACY,
1019 "Duplicate SAVE attribute specified at %L",
1025 attr->save = SAVE_EXPLICIT;
1026 return check_conflict (attr, name, where);
1031 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1034 if (check_used (attr, name, where))
1039 if (gfc_notify_std (GFC_STD_LEGACY,
1040 "Duplicate VALUE attribute specified at %L",
1047 return check_conflict (attr, name, where);
1052 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1054 /* No check_used needed as 11.2.1 of the F2003 standard allows
1055 that the local identifier made accessible by a use statement can be
1056 given a VOLATILE attribute. */
1058 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1059 if (gfc_notify_std (GFC_STD_LEGACY,
1060 "Duplicate VOLATILE attribute specified at %L", where)
1064 attr->volatile_ = 1;
1065 attr->volatile_ns = gfc_current_ns;
1066 return check_conflict (attr, name, where);
1071 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1074 if (check_used (attr, name, where))
1077 if (attr->threadprivate)
1079 duplicate_attr ("THREADPRIVATE", where);
1083 attr->threadprivate = 1;
1084 return check_conflict (attr, name, where);
1089 gfc_add_target (symbol_attribute *attr, locus *where)
1092 if (check_used (attr, NULL, where))
1097 duplicate_attr ("TARGET", where);
1102 return check_conflict (attr, NULL, where);
1107 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1110 if (check_used (attr, name, where))
1113 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1115 return check_conflict (attr, name, where);
1120 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1123 if (check_used (attr, name, where))
1126 /* Duplicate attribute already checked for. */
1127 attr->in_common = 1;
1128 if (check_conflict (attr, name, where) == FAILURE)
1131 if (attr->flavor == FL_VARIABLE)
1134 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1139 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1142 /* Duplicate attribute already checked for. */
1143 attr->in_equivalence = 1;
1144 if (check_conflict (attr, name, where) == FAILURE)
1147 if (attr->flavor == FL_VARIABLE)
1150 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1155 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1158 if (check_used (attr, name, where))
1162 return check_conflict (attr, name, where);
1167 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1170 attr->in_namelist = 1;
1171 return check_conflict (attr, name, where);
1176 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1179 if (check_used (attr, name, where))
1183 return check_conflict (attr, name, where);
1188 gfc_add_elemental (symbol_attribute *attr, locus *where)
1191 if (check_used (attr, NULL, where))
1194 if (attr->elemental)
1196 duplicate_attr ("ELEMENTAL", where);
1200 attr->elemental = 1;
1201 return check_conflict (attr, NULL, where);
1206 gfc_add_pure (symbol_attribute *attr, locus *where)
1209 if (check_used (attr, NULL, where))
1214 duplicate_attr ("PURE", where);
1219 return check_conflict (attr, NULL, where);
1224 gfc_add_recursive (symbol_attribute *attr, locus *where)
1227 if (check_used (attr, NULL, where))
1230 if (attr->recursive)
1232 duplicate_attr ("RECURSIVE", where);
1236 attr->recursive = 1;
1237 return check_conflict (attr, NULL, where);
1242 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1245 if (check_used (attr, name, where))
1250 duplicate_attr ("ENTRY", where);
1255 return check_conflict (attr, name, where);
1260 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1263 if (attr->flavor != FL_PROCEDURE
1264 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1268 return check_conflict (attr, name, where);
1273 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1276 if (attr->flavor != FL_PROCEDURE
1277 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1280 attr->subroutine = 1;
1281 return check_conflict (attr, name, where);
1286 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1289 if (attr->flavor != FL_PROCEDURE
1290 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1294 return check_conflict (attr, name, where);
1299 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1302 if (check_used (attr, NULL, where))
1305 if (attr->flavor != FL_PROCEDURE
1306 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1309 if (attr->procedure)
1311 duplicate_attr ("PROCEDURE", where);
1315 attr->procedure = 1;
1317 return check_conflict (attr, NULL, where);
1321 /* Flavors are special because some flavors are not what Fortran
1322 considers attributes and can be reaffirmed multiple times. */
1325 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1329 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1330 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1331 || f == FL_NAMELIST) && check_used (attr, name, where))
1334 if (attr->flavor == f && f == FL_VARIABLE)
1337 if (attr->flavor != FL_UNKNOWN)
1340 where = &gfc_current_locus;
1343 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1344 gfc_code2string (flavors, attr->flavor), name,
1345 gfc_code2string (flavors, f), where);
1347 gfc_error ("%s attribute conflicts with %s attribute at %L",
1348 gfc_code2string (flavors, attr->flavor),
1349 gfc_code2string (flavors, f), where);
1356 return check_conflict (attr, name, where);
1361 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1362 const char *name, locus *where)
1365 if (check_used (attr, name, where))
1368 if (attr->flavor != FL_PROCEDURE
1369 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1373 where = &gfc_current_locus;
1375 if (attr->proc != PROC_UNKNOWN)
1377 gfc_error ("%s procedure at %L is already declared as %s procedure",
1378 gfc_code2string (procedures, t), where,
1379 gfc_code2string (procedures, attr->proc));
1386 /* Statement functions are always scalar and functions. */
1387 if (t == PROC_ST_FUNCTION
1388 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1389 || attr->dimension))
1392 return check_conflict (attr, name, where);
1397 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1400 if (check_used (attr, NULL, where))
1403 if (attr->intent == INTENT_UNKNOWN)
1405 attr->intent = intent;
1406 return check_conflict (attr, NULL, where);
1410 where = &gfc_current_locus;
1412 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1413 gfc_intent_string (attr->intent),
1414 gfc_intent_string (intent), where);
1420 /* No checks for use-association in public and private statements. */
1423 gfc_add_access (symbol_attribute *attr, gfc_access access,
1424 const char *name, locus *where)
1427 if (attr->access == ACCESS_UNKNOWN)
1429 attr->access = access;
1430 return check_conflict (attr, name, where);
1434 where = &gfc_current_locus;
1435 gfc_error ("ACCESS specification at %L was already specified", where);
1441 /* Set the is_bind_c field for the given symbol_attribute. */
1444 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1445 int is_proc_lang_bind_spec)
1448 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1449 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1450 "variables or common blocks", where);
1451 else if (attr->is_bind_c)
1452 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1454 attr->is_bind_c = 1;
1457 where = &gfc_current_locus;
1459 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1463 return check_conflict (attr, name, where);
1467 /* Set the extension field for the given symbol_attribute. */
1470 gfc_add_extension (symbol_attribute *attr, locus *where)
1473 where = &gfc_current_locus;
1475 if (attr->extension)
1476 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1478 attr->extension = 1;
1480 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
1489 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1490 gfc_formal_arglist * formal, locus *where)
1493 if (check_used (&sym->attr, sym->name, where))
1497 where = &gfc_current_locus;
1499 if (sym->attr.if_source != IFSRC_UNKNOWN
1500 && sym->attr.if_source != IFSRC_DECL)
1502 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1507 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1509 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1510 "body", sym->name, where);
1514 sym->formal = formal;
1515 sym->attr.if_source = source;
1521 /* Add a type to a symbol. */
1524 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1529 where = &gfc_current_locus;
1531 if (sym->ts.type != BT_UNKNOWN)
1533 const char *msg = "Symbol '%s' at %L already has basic type of %s";
1534 if (!(sym->ts.type == ts->type
1535 && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
1536 || gfc_notification_std (GFC_STD_GNU) == ERROR
1539 gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1542 else if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
1543 gfc_basic_typename (sym->ts.type)) == FAILURE)
1547 flavor = sym->attr.flavor;
1549 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1550 || flavor == FL_LABEL
1551 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1552 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1554 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1563 /* Clears all attributes. */
1566 gfc_clear_attr (symbol_attribute *attr)
1568 memset (attr, 0, sizeof (symbol_attribute));
1572 /* Check for missing attributes in the new symbol. Currently does
1573 nothing, but it's not clear that it is unnecessary yet. */
1576 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1577 locus *where ATTRIBUTE_UNUSED)
1584 /* Copy an attribute to a symbol attribute, bit by bit. Some
1585 attributes have a lot of side-effects but cannot be present given
1586 where we are called from, so we ignore some bits. */
1589 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1591 int is_proc_lang_bind_spec;
1593 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1596 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1598 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1600 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1602 if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1604 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1606 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1608 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1610 if (src->threadprivate
1611 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1613 if (src->target && gfc_add_target (dest, where) == FAILURE)
1615 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1617 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1622 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1625 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1628 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1630 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1632 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1635 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1637 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1639 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1641 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1644 if (src->flavor != FL_UNKNOWN
1645 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1648 if (src->intent != INTENT_UNKNOWN
1649 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1652 if (src->access != ACCESS_UNKNOWN
1653 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1656 if (gfc_missing_attr (dest, where) == FAILURE)
1659 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1661 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1664 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1666 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1670 if (src->is_c_interop)
1671 dest->is_c_interop = 1;
1675 if (src->external && gfc_add_external (dest, where) == FAILURE)
1677 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1679 if (src->proc_pointer)
1680 dest->proc_pointer = 1;
1689 /************** Component name management ************/
1691 /* Component names of a derived type form their own little namespaces
1692 that are separate from all other spaces. The space is composed of
1693 a singly linked list of gfc_component structures whose head is
1694 located in the parent symbol. */
1697 /* Add a component name to a symbol. The call fails if the name is
1698 already present. On success, the component pointer is modified to
1699 point to the additional component structure. */
1702 gfc_add_component (gfc_symbol *sym, const char *name,
1703 gfc_component **component)
1705 gfc_component *p, *tail;
1709 for (p = sym->components; p; p = p->next)
1711 if (strcmp (p->name, name) == 0)
1713 gfc_error ("Component '%s' at %C already declared at %L",
1721 if (sym->attr.extension
1722 && gfc_find_component (sym->components->ts.derived, name))
1724 gfc_error ("Component '%s' at %C already in the parent type "
1725 "at %L", name, &sym->components->ts.derived->declared_at);
1729 /* Allocate a new component. */
1730 p = gfc_get_component ();
1733 sym->components = p;
1737 p->name = gfc_get_string (name);
1738 p->loc = gfc_current_locus;
1745 /* Recursive function to switch derived types of all symbol in a
1749 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1757 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1758 sym->ts.derived = to;
1760 switch_types (st->left, from, to);
1761 switch_types (st->right, from, to);
1765 /* This subroutine is called when a derived type is used in order to
1766 make the final determination about which version to use. The
1767 standard requires that a type be defined before it is 'used', but
1768 such types can appear in IMPLICIT statements before the actual
1769 definition. 'Using' in this context means declaring a variable to
1770 be that type or using the type constructor.
1772 If a type is used and the components haven't been defined, then we
1773 have to have a derived type in a parent unit. We find the node in
1774 the other namespace and point the symtree node in this namespace to
1775 that node. Further reference to this name point to the correct
1776 node. If we can't find the node in a parent namespace, then we have
1779 This subroutine takes a pointer to a symbol node and returns a
1780 pointer to the translated node or NULL for an error. Usually there
1781 is no translation and we return the node we were passed. */
1784 gfc_use_derived (gfc_symbol *sym)
1791 if (sym->components != NULL || sym->attr.zero_comp)
1792 return sym; /* Already defined. */
1794 if (sym->ns->parent == NULL)
1797 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1799 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1803 if (s == NULL || s->attr.flavor != FL_DERIVED)
1806 /* Get rid of symbol sym, translating all references to s. */
1807 for (i = 0; i < GFC_LETTERS; i++)
1809 t = &sym->ns->default_type[i];
1810 if (t->derived == sym)
1814 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1819 /* Unlink from list of modified symbols. */
1820 gfc_commit_symbol (sym);
1822 switch_types (sym->ns->sym_root, sym, s);
1824 /* TODO: Also have to replace sym -> s in other lists like
1825 namelists, common lists and interface lists. */
1826 gfc_free_symbol (sym);
1831 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1837 /* Given a derived type node and a component name, try to locate the
1838 component structure. Returns the NULL pointer if the component is
1839 not found or the components are private. */
1842 gfc_find_component (gfc_symbol *sym, const char *name)
1849 sym = gfc_use_derived (sym);
1854 for (p = sym->components; p; p = p->next)
1855 if (strcmp (p->name, name) == 0)
1859 && sym->attr.extension
1860 && sym->components->ts.type == BT_DERIVED)
1862 p = gfc_find_component (sym->components->ts.derived, name);
1863 /* Do not overwrite the error. */
1869 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1872 else if (sym->attr.use_assoc)
1874 if (p->access == ACCESS_PRIVATE)
1876 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1881 /* If there were components given and all components are private, error
1882 out at this place. */
1883 if (p->access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
1885 gfc_error ("All components of '%s' are PRIVATE in structure"
1886 " constructor at %C", sym->name);
1895 /* Given a symbol, free all of the component structures and everything
1899 free_components (gfc_component *p)
1907 gfc_free_array_spec (p->as);
1908 gfc_free_expr (p->initializer);
1915 /* Set component attributes from a standard symbol attribute structure. */
1918 gfc_set_component_attr (gfc_component *c, symbol_attribute *attr)
1921 c->dimension = attr->dimension;
1922 c->pointer = attr->pointer;
1923 c->allocatable = attr->allocatable;
1924 c->access = attr->access;
1928 /* Get a standard symbol attribute structure given the component
1932 gfc_get_component_attr (symbol_attribute *attr, gfc_component *c)
1935 gfc_clear_attr (attr);
1936 attr->dimension = c->dimension;
1937 attr->pointer = c->pointer;
1938 attr->allocatable = c->allocatable;
1939 attr->access = c->access;
1943 /******************** Statement label management ********************/
1945 /* Comparison function for statement labels, used for managing the
1949 compare_st_labels (void *a1, void *b1)
1951 int a = ((gfc_st_label *) a1)->value;
1952 int b = ((gfc_st_label *) b1)->value;
1958 /* Free a single gfc_st_label structure, making sure the tree is not
1959 messed up. This function is called only when some parse error
1963 gfc_free_st_label (gfc_st_label *label)
1969 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
1971 if (label->format != NULL)
1972 gfc_free_expr (label->format);
1978 /* Free a whole tree of gfc_st_label structures. */
1981 free_st_labels (gfc_st_label *label)
1987 free_st_labels (label->left);
1988 free_st_labels (label->right);
1990 if (label->format != NULL)
1991 gfc_free_expr (label->format);
1996 /* Given a label number, search for and return a pointer to the label
1997 structure, creating it if it does not exist. */
2000 gfc_get_st_label (int labelno)
2004 /* First see if the label is already in this namespace. */
2005 lp = gfc_current_ns->st_labels;
2008 if (lp->value == labelno)
2011 if (lp->value < labelno)
2017 lp = XCNEW (gfc_st_label);
2019 lp->value = labelno;
2020 lp->defined = ST_LABEL_UNKNOWN;
2021 lp->referenced = ST_LABEL_UNKNOWN;
2023 gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
2029 /* Called when a statement with a statement label is about to be
2030 accepted. We add the label to the list of the current namespace,
2031 making sure it hasn't been defined previously and referenced
2035 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2039 labelno = lp->value;
2041 if (lp->defined != ST_LABEL_UNKNOWN)
2042 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2043 &lp->where, label_locus);
2046 lp->where = *label_locus;
2050 case ST_LABEL_FORMAT:
2051 if (lp->referenced == ST_LABEL_TARGET)
2052 gfc_error ("Label %d at %C already referenced as branch target",
2055 lp->defined = ST_LABEL_FORMAT;
2059 case ST_LABEL_TARGET:
2060 if (lp->referenced == ST_LABEL_FORMAT)
2061 gfc_error ("Label %d at %C already referenced as a format label",
2064 lp->defined = ST_LABEL_TARGET;
2069 lp->defined = ST_LABEL_BAD_TARGET;
2070 lp->referenced = ST_LABEL_BAD_TARGET;
2076 /* Reference a label. Given a label and its type, see if that
2077 reference is consistent with what is known about that label,
2078 updating the unknown state. Returns FAILURE if something goes
2082 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2084 gfc_sl_type label_type;
2091 labelno = lp->value;
2093 if (lp->defined != ST_LABEL_UNKNOWN)
2094 label_type = lp->defined;
2097 label_type = lp->referenced;
2098 lp->where = gfc_current_locus;
2101 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2103 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2108 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2109 && type == ST_LABEL_FORMAT)
2111 gfc_error ("Label %d at %C previously used as branch target", labelno);
2116 lp->referenced = type;
2124 /*******A helper function for creating new expressions*************/
2128 gfc_lval_expr_from_sym (gfc_symbol *sym)
2131 lval = gfc_get_expr ();
2132 lval->expr_type = EXPR_VARIABLE;
2133 lval->where = sym->declared_at;
2135 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2137 /* It will always be a full array. */
2138 lval->rank = sym->as ? sym->as->rank : 0;
2141 lval->ref = gfc_get_ref ();
2142 lval->ref->type = REF_ARRAY;
2143 lval->ref->u.ar.type = AR_FULL;
2144 lval->ref->u.ar.dimen = lval->rank;
2145 lval->ref->u.ar.where = sym->declared_at;
2146 lval->ref->u.ar.as = sym->as;
2153 /************** Symbol table management subroutines ****************/
2155 /* Basic details: Fortran 95 requires a potentially unlimited number
2156 of distinct namespaces when compiling a program unit. This case
2157 occurs during a compilation of internal subprograms because all of
2158 the internal subprograms must be read before we can start
2159 generating code for the host.
2161 Given the tricky nature of the Fortran grammar, we must be able to
2162 undo changes made to a symbol table if the current interpretation
2163 of a statement is found to be incorrect. Whenever a symbol is
2164 looked up, we make a copy of it and link to it. All of these
2165 symbols are kept in a singly linked list so that we can commit or
2166 undo the changes at a later time.
2168 A symtree may point to a symbol node outside of its namespace. In
2169 this case, that symbol has been used as a host associated variable
2170 at some previous time. */
2172 /* Allocate a new namespace structure. Copies the implicit types from
2173 PARENT if PARENT_TYPES is set. */
2176 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2180 gfc_intrinsic_op in;
2183 ns = XCNEW (gfc_namespace);
2184 ns->sym_root = NULL;
2185 ns->uop_root = NULL;
2186 ns->finalizers = NULL;
2187 ns->default_access = ACCESS_UNKNOWN;
2188 ns->parent = parent;
2190 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2191 ns->operator_access[in] = ACCESS_UNKNOWN;
2193 /* Initialize default implicit types. */
2194 for (i = 'a'; i <= 'z'; i++)
2196 ns->set_flag[i - 'a'] = 0;
2197 ts = &ns->default_type[i - 'a'];
2199 if (parent_types && ns->parent != NULL)
2201 /* Copy parent settings. */
2202 *ts = ns->parent->default_type[i - 'a'];
2206 if (gfc_option.flag_implicit_none != 0)
2212 if ('i' <= i && i <= 'n')
2214 ts->type = BT_INTEGER;
2215 ts->kind = gfc_default_integer_kind;
2220 ts->kind = gfc_default_real_kind;
2230 /* Comparison function for symtree nodes. */
2233 compare_symtree (void *_st1, void *_st2)
2235 gfc_symtree *st1, *st2;
2237 st1 = (gfc_symtree *) _st1;
2238 st2 = (gfc_symtree *) _st2;
2240 return strcmp (st1->name, st2->name);
2244 /* Allocate a new symtree node and associate it with the new symbol. */
2247 gfc_new_symtree (gfc_symtree **root, const char *name)
2251 st = XCNEW (gfc_symtree);
2252 st->name = gfc_get_string (name);
2254 gfc_insert_bbt (root, st, compare_symtree);
2259 /* Delete a symbol from the tree. Does not free the symbol itself! */
2262 gfc_delete_symtree (gfc_symtree **root, const char *name)
2264 gfc_symtree st, *st0;
2266 st0 = gfc_find_symtree (*root, name);
2268 st.name = gfc_get_string (name);
2269 gfc_delete_bbt (root, &st, compare_symtree);
2275 /* Given a root symtree node and a name, try to find the symbol within
2276 the namespace. Returns NULL if the symbol is not found. */
2279 gfc_find_symtree (gfc_symtree *st, const char *name)
2285 c = strcmp (name, st->name);
2289 st = (c < 0) ? st->left : st->right;
2296 /* Return a symtree node with a name that is guaranteed to be unique
2297 within the namespace and corresponds to an illegal fortran name. */
2300 gfc_get_unique_symtree (gfc_namespace *ns)
2302 char name[GFC_MAX_SYMBOL_LEN + 1];
2303 static int serial = 0;
2305 sprintf (name, "@%d", serial++);
2306 return gfc_new_symtree (&ns->sym_root, name);
2310 /* Given a name find a user operator node, creating it if it doesn't
2311 exist. These are much simpler than symbols because they can't be
2312 ambiguous with one another. */
2315 gfc_get_uop (const char *name)
2320 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2324 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2326 uop = st->n.uop = XCNEW (gfc_user_op);
2327 uop->name = gfc_get_string (name);
2328 uop->access = ACCESS_UNKNOWN;
2329 uop->ns = gfc_current_ns;
2335 /* Given a name find the user operator node. Returns NULL if it does
2339 gfc_find_uop (const char *name, gfc_namespace *ns)
2344 ns = gfc_current_ns;
2346 st = gfc_find_symtree (ns->uop_root, name);
2347 return (st == NULL) ? NULL : st->n.uop;
2351 /* Remove a gfc_symbol structure and everything it points to. */
2354 gfc_free_symbol (gfc_symbol *sym)
2360 gfc_free_array_spec (sym->as);
2362 free_components (sym->components);
2364 gfc_free_expr (sym->value);
2366 gfc_free_namelist (sym->namelist);
2368 gfc_free_namespace (sym->formal_ns);
2370 if (!sym->attr.generic_copy)
2371 gfc_free_interface (sym->generic);
2373 gfc_free_formal_arglist (sym->formal);
2375 gfc_free_namespace (sym->f2k_derived);
2381 /* Allocate and initialize a new symbol node. */
2384 gfc_new_symbol (const char *name, gfc_namespace *ns)
2388 p = XCNEW (gfc_symbol);
2390 gfc_clear_ts (&p->ts);
2391 gfc_clear_attr (&p->attr);
2394 p->declared_at = gfc_current_locus;
2396 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2397 gfc_internal_error ("new_symbol(): Symbol name too long");
2399 p->name = gfc_get_string (name);
2401 /* Make sure flags for symbol being C bound are clear initially. */
2402 p->attr.is_bind_c = 0;
2403 p->attr.is_iso_c = 0;
2404 /* Make sure the binding label field has a Nul char to start. */
2405 p->binding_label[0] = '\0';
2407 /* Clear the ptrs we may need. */
2408 p->common_block = NULL;
2409 p->f2k_derived = NULL;
2415 /* Generate an error if a symbol is ambiguous. */
2418 ambiguous_symbol (const char *name, gfc_symtree *st)
2421 if (st->n.sym->module)
2422 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2423 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2425 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2426 "from current program unit", name, st->n.sym->name);
2430 /* Search for a symtree starting in the current namespace, resorting to
2431 any parent namespaces if requested by a nonzero parent_flag.
2432 Returns nonzero if the name is ambiguous. */
2435 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2436 gfc_symtree **result)
2441 ns = gfc_current_ns;
2445 st = gfc_find_symtree (ns->sym_root, name);
2449 /* Ambiguous generic interfaces are permitted, as long
2450 as the specific interfaces are different. */
2451 if (st->ambiguous && !st->n.sym->attr.generic)
2453 ambiguous_symbol (name, st);
2472 /* Same, but returns the symbol instead. */
2475 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2476 gfc_symbol **result)
2481 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2486 *result = st->n.sym;
2492 /* Save symbol with the information necessary to back it out. */
2495 save_symbol_data (gfc_symbol *sym)
2498 if (sym->gfc_new || sym->old_symbol != NULL)
2501 sym->old_symbol = XCNEW (gfc_symbol);
2502 *(sym->old_symbol) = *sym;
2504 sym->tlink = changed_syms;
2509 /* Given a name, find a symbol, or create it if it does not exist yet
2510 in the current namespace. If the symbol is found we make sure that
2513 The integer return code indicates
2515 1 The symbol name was ambiguous
2516 2 The name meant to be established was already host associated.
2518 So if the return value is nonzero, then an error was issued. */
2521 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
2526 /* This doesn't usually happen during resolution. */
2528 ns = gfc_current_ns;
2530 /* Try to find the symbol in ns. */
2531 st = gfc_find_symtree (ns->sym_root, name);
2535 /* If not there, create a new symbol. */
2536 p = gfc_new_symbol (name, ns);
2538 /* Add to the list of tentative symbols. */
2539 p->old_symbol = NULL;
2540 p->tlink = changed_syms;
2545 st = gfc_new_symtree (&ns->sym_root, name);
2552 /* Make sure the existing symbol is OK. Ambiguous
2553 generic interfaces are permitted, as long as the
2554 specific interfaces are different. */
2555 if (st->ambiguous && !st->n.sym->attr.generic)
2557 ambiguous_symbol (name, st);
2563 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2565 && ns->proc_name->attr.if_source == IFSRC_IFBODY
2566 && (ns->has_import_set || p->attr.imported)))
2568 /* Symbol is from another namespace. */
2569 gfc_error ("Symbol '%s' at %C has already been host associated",
2576 /* Copy in case this symbol is changed. */
2577 save_symbol_data (p);
2586 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2591 i = gfc_get_sym_tree (name, ns, &st);
2596 *result = st->n.sym;
2603 /* Subroutine that searches for a symbol, creating it if it doesn't
2604 exist, but tries to host-associate the symbol if possible. */
2607 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2612 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2615 save_symbol_data (st->n.sym);
2620 if (gfc_current_ns->parent != NULL)
2622 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2633 return gfc_get_sym_tree (name, gfc_current_ns, result);
2638 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2643 i = gfc_get_ha_sym_tree (name, &st);
2646 *result = st->n.sym;
2653 /* Return true if both symbols could refer to the same data object. Does
2654 not take account of aliasing due to equivalence statements. */
2657 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2659 /* Aliasing isn't possible if the symbols have different base types. */
2660 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2663 /* Pointers can point to other pointers, target objects and allocatable
2664 objects. Two allocatable objects cannot share the same storage. */
2665 if (lsym->attr.pointer
2666 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2668 if (lsym->attr.target && rsym->attr.pointer)
2670 if (lsym->attr.allocatable && rsym->attr.pointer)
2677 /* Undoes all the changes made to symbols in the current statement.
2678 This subroutine is made simpler due to the fact that attributes are
2679 never removed once added. */
2682 gfc_undo_symbols (void)
2684 gfc_symbol *p, *q, *old;
2686 for (p = changed_syms; p; p = q)
2692 /* Symbol was new. */
2693 if (p->attr.in_common && p->common_block->head)
2695 /* If the symbol was added to any common block, it
2696 needs to be removed to stop the resolver looking
2697 for a (possibly) dead symbol. */
2699 if (p->common_block->head == p)
2700 p->common_block->head = p->common_next;
2703 gfc_symbol *cparent, *csym;
2705 cparent = p->common_block->head;
2706 csym = cparent->common_next;
2711 csym = csym->common_next;
2714 gcc_assert(cparent->common_next == p);
2716 cparent->common_next = csym->common_next;
2720 gfc_delete_symtree (&p->ns->sym_root, p->name);
2724 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2726 gfc_free_symbol (p);
2730 /* Restore previous state of symbol. Just copy simple stuff. */
2732 old = p->old_symbol;
2734 p->ts.type = old->ts.type;
2735 p->ts.kind = old->ts.kind;
2737 p->attr = old->attr;
2739 if (p->value != old->value)
2741 gfc_free_expr (old->value);
2745 if (p->as != old->as)
2748 gfc_free_array_spec (p->as);
2752 p->generic = old->generic;
2753 p->component_access = old->component_access;
2755 if (p->namelist != NULL && old->namelist == NULL)
2757 gfc_free_namelist (p->namelist);
2762 if (p->namelist_tail != old->namelist_tail)
2764 gfc_free_namelist (old->namelist_tail);
2765 old->namelist_tail->next = NULL;
2769 p->namelist_tail = old->namelist_tail;
2771 if (p->formal != old->formal)
2773 gfc_free_formal_arglist (p->formal);
2774 p->formal = old->formal;
2777 gfc_free (p->old_symbol);
2778 p->old_symbol = NULL;
2782 changed_syms = NULL;
2786 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2787 components of old_symbol that might need deallocation are the "allocatables"
2788 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2789 namelist_tail. In case these differ between old_symbol and sym, it's just
2790 because sym->namelist has gotten a few more items. */
2793 free_old_symbol (gfc_symbol *sym)
2796 if (sym->old_symbol == NULL)
2799 if (sym->old_symbol->as != sym->as)
2800 gfc_free_array_spec (sym->old_symbol->as);
2802 if (sym->old_symbol->value != sym->value)
2803 gfc_free_expr (sym->old_symbol->value);
2805 if (sym->old_symbol->formal != sym->formal)
2806 gfc_free_formal_arglist (sym->old_symbol->formal);
2808 gfc_free (sym->old_symbol);
2809 sym->old_symbol = NULL;
2813 /* Makes the changes made in the current statement permanent-- gets
2814 rid of undo information. */
2817 gfc_commit_symbols (void)
2821 for (p = changed_syms; p; p = q)
2827 free_old_symbol (p);
2829 changed_syms = NULL;
2833 /* Makes the changes made in one symbol permanent -- gets rid of undo
2837 gfc_commit_symbol (gfc_symbol *sym)
2841 if (changed_syms == sym)
2842 changed_syms = sym->tlink;
2845 for (p = changed_syms; p; p = p->tlink)
2846 if (p->tlink == sym)
2848 p->tlink = sym->tlink;
2857 free_old_symbol (sym);
2861 /* Recursive function that deletes an entire tree and all the common
2862 head structures it points to. */
2865 free_common_tree (gfc_symtree * common_tree)
2867 if (common_tree == NULL)
2870 free_common_tree (common_tree->left);
2871 free_common_tree (common_tree->right);
2873 gfc_free (common_tree);
2877 /* Recursive function that deletes an entire tree and all the user
2878 operator nodes that it contains. */
2881 free_uop_tree (gfc_symtree *uop_tree)
2884 if (uop_tree == NULL)
2887 free_uop_tree (uop_tree->left);
2888 free_uop_tree (uop_tree->right);
2890 gfc_free_interface (uop_tree->n.uop->op);
2892 gfc_free (uop_tree->n.uop);
2893 gfc_free (uop_tree);
2897 /* Recursive function that deletes an entire tree and all the symbols
2898 that it contains. */
2901 free_sym_tree (gfc_symtree *sym_tree)
2906 if (sym_tree == NULL)
2909 free_sym_tree (sym_tree->left);
2910 free_sym_tree (sym_tree->right);
2912 sym = sym_tree->n.sym;
2916 gfc_internal_error ("free_sym_tree(): Negative refs");
2918 if (sym->formal_ns != NULL && sym->refs == 1)
2920 /* As formal_ns contains a reference to sym, delete formal_ns just
2921 before the deletion of sym. */
2922 ns = sym->formal_ns;
2923 sym->formal_ns = NULL;
2924 gfc_free_namespace (ns);
2926 else if (sym->refs == 0)
2928 /* Go ahead and delete the symbol. */
2929 gfc_free_symbol (sym);
2932 gfc_free (sym_tree);
2936 /* Free the derived type list. */
2939 gfc_free_dt_list (void)
2941 gfc_dt_list *dt, *n;
2943 for (dt = gfc_derived_types; dt; dt = n)
2949 gfc_derived_types = NULL;
2953 /* Free the gfc_equiv_info's. */
2956 gfc_free_equiv_infos (gfc_equiv_info *s)
2960 gfc_free_equiv_infos (s->next);
2965 /* Free the gfc_equiv_lists. */
2968 gfc_free_equiv_lists (gfc_equiv_list *l)
2972 gfc_free_equiv_lists (l->next);
2973 gfc_free_equiv_infos (l->equiv);
2978 /* Free a finalizer procedure list. */
2981 gfc_free_finalizer (gfc_finalizer* el)
2987 --el->proc_sym->refs;
2988 if (!el->proc_sym->refs)
2989 gfc_free_symbol (el->proc_sym);
2997 gfc_free_finalizer_list (gfc_finalizer* list)
3001 gfc_finalizer* current = list;
3003 gfc_free_finalizer (current);
3008 /* Free a namespace structure and everything below it. Interface
3009 lists associated with intrinsic operators are not freed. These are
3010 taken care of when a specific name is freed. */
3013 gfc_free_namespace (gfc_namespace *ns)
3015 gfc_charlen *cl, *cl2;
3016 gfc_namespace *p, *q;
3025 gcc_assert (ns->refs == 0);
3027 gfc_free_statements (ns->code);
3029 free_sym_tree (ns->sym_root);
3030 free_uop_tree (ns->uop_root);
3031 free_common_tree (ns->common_root);
3032 gfc_free_finalizer_list (ns->finalizers);
3034 for (cl = ns->cl_list; cl; cl = cl2)
3037 gfc_free_expr (cl->length);
3041 free_st_labels (ns->st_labels);
3043 gfc_free_equiv (ns->equiv);
3044 gfc_free_equiv_lists (ns->equiv_lists);
3046 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3047 gfc_free_interface (ns->op[i]);
3049 gfc_free_data (ns->data);
3053 /* Recursively free any contained namespaces. */
3058 gfc_free_namespace (q);
3064 gfc_symbol_init_2 (void)
3067 gfc_current_ns = gfc_get_namespace (NULL, 0);
3072 gfc_symbol_done_2 (void)
3075 gfc_free_namespace (gfc_current_ns);
3076 gfc_current_ns = NULL;
3077 gfc_free_dt_list ();
3081 /* Clear mark bits from symbol nodes associated with a symtree node. */
3084 clear_sym_mark (gfc_symtree *st)
3087 st->n.sym->mark = 0;
3091 /* Recursively traverse the symtree nodes. */
3094 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
3099 gfc_traverse_symtree (st->left, func);
3101 gfc_traverse_symtree (st->right, func);
3105 /* Recursive namespace traversal function. */
3108 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
3114 traverse_ns (st->left, func);
3116 if (st->n.sym->mark == 0)
3117 (*func) (st->n.sym);
3118 st->n.sym->mark = 1;
3120 traverse_ns (st->right, func);
3124 /* Call a given function for all symbols in the namespace. We take
3125 care that each gfc_symbol node is called exactly once. */
3128 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3131 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3133 traverse_ns (ns->sym_root, func);
3137 /* Return TRUE when name is the name of an intrinsic type. */
3140 gfc_is_intrinsic_typename (const char *name)
3142 if (strcmp (name, "integer") == 0
3143 || strcmp (name, "real") == 0
3144 || strcmp (name, "character") == 0
3145 || strcmp (name, "logical") == 0
3146 || strcmp (name, "complex") == 0
3147 || strcmp (name, "doubleprecision") == 0
3148 || strcmp (name, "doublecomplex") == 0)
3155 /* Return TRUE if the symbol is an automatic variable. */
3158 gfc_is_var_automatic (gfc_symbol *sym)
3160 /* Pointer and allocatable variables are never automatic. */
3161 if (sym->attr.pointer || sym->attr.allocatable)
3163 /* Check for arrays with non-constant size. */
3164 if (sym->attr.dimension && sym->as
3165 && !gfc_is_compile_time_shape (sym->as))
3167 /* Check for non-constant length character variables. */
3168 if (sym->ts.type == BT_CHARACTER
3170 && !gfc_is_constant_expr (sym->ts.cl->length))
3175 /* Given a symbol, mark it as SAVEd if it is allowed. */
3178 save_symbol (gfc_symbol *sym)
3181 if (sym->attr.use_assoc)
3184 if (sym->attr.in_common
3186 || sym->attr.flavor != FL_VARIABLE)
3188 /* Automatic objects are not saved. */
3189 if (gfc_is_var_automatic (sym))
3191 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3195 /* Mark those symbols which can be SAVEd as such. */
3198 gfc_save_all (gfc_namespace *ns)
3201 gfc_traverse_ns (ns, save_symbol);
3206 /* Make sure that no changes to symbols are pending. */
3209 gfc_symbol_state(void) {
3211 if (changed_syms != NULL)
3212 gfc_internal_error("Symbol changes still pending!");
3217 /************** Global symbol handling ************/
3220 /* Search a tree for the global symbol. */
3223 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3232 c = strcmp (name, symbol->name);
3236 symbol = (c < 0) ? symbol->left : symbol->right;
3243 /* Compare two global symbols. Used for managing the BB tree. */
3246 gsym_compare (void *_s1, void *_s2)
3248 gfc_gsymbol *s1, *s2;
3250 s1 = (gfc_gsymbol *) _s1;
3251 s2 = (gfc_gsymbol *) _s2;
3252 return strcmp (s1->name, s2->name);
3256 /* Get a global symbol, creating it if it doesn't exist. */
3259 gfc_get_gsymbol (const char *name)
3263 s = gfc_find_gsymbol (gfc_gsym_root, name);
3267 s = XCNEW (gfc_gsymbol);
3268 s->type = GSYM_UNKNOWN;
3269 s->name = gfc_get_string (name);
3271 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3278 get_iso_c_binding_dt (int sym_id)
3280 gfc_dt_list *dt_list;
3282 dt_list = gfc_derived_types;
3284 /* Loop through the derived types in the name list, searching for
3285 the desired symbol from iso_c_binding. Search the parent namespaces
3286 if necessary and requested to (parent_flag). */
3287 while (dt_list != NULL)
3289 if (dt_list->derived->from_intmod != INTMOD_NONE
3290 && dt_list->derived->intmod_sym_id == sym_id)
3291 return dt_list->derived;
3293 dt_list = dt_list->next;
3300 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3301 with C. This is necessary for any derived type that is BIND(C) and for
3302 derived types that are parameters to functions that are BIND(C). All
3303 fields of the derived type are required to be interoperable, and are tested
3304 for such. If an error occurs, the errors are reported here, allowing for
3305 multiple errors to be handled for a single derived type. */
3308 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3310 gfc_component *curr_comp = NULL;
3311 gfc_try is_c_interop = FAILURE;
3312 gfc_try retval = SUCCESS;
3314 if (derived_sym == NULL)
3315 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3316 "unexpectedly NULL");
3318 /* If we've already looked at this derived symbol, do not look at it again
3319 so we don't repeat warnings/errors. */
3320 if (derived_sym->ts.is_c_interop)
3323 /* The derived type must have the BIND attribute to be interoperable
3324 J3/04-007, Section 15.2.3. */
3325 if (derived_sym->attr.is_bind_c != 1)
3327 derived_sym->ts.is_c_interop = 0;
3328 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3329 "attribute to be C interoperable", derived_sym->name,
3330 &(derived_sym->declared_at));
3334 curr_comp = derived_sym->components;
3336 /* TODO: is this really an error? */
3337 if (curr_comp == NULL)
3339 gfc_error ("Derived type '%s' at %L is empty",
3340 derived_sym->name, &(derived_sym->declared_at));
3344 /* Initialize the derived type as being C interoperable.
3345 If we find an error in the components, this will be set false. */
3346 derived_sym->ts.is_c_interop = 1;
3348 /* Loop through the list of components to verify that the kind of
3349 each is a C interoperable type. */
3352 /* The components cannot be pointers (fortran sense).
3353 J3/04-007, Section 15.2.3, C1505. */
3354 if (curr_comp->pointer != 0)
3356 gfc_error ("Component '%s' at %L cannot have the "
3357 "POINTER attribute because it is a member "
3358 "of the BIND(C) derived type '%s' at %L",
3359 curr_comp->name, &(curr_comp->loc),
3360 derived_sym->name, &(derived_sym->declared_at));
3364 /* The components cannot be allocatable.
3365 J3/04-007, Section 15.2.3, C1505. */
3366 if (curr_comp->allocatable != 0)
3368 gfc_error ("Component '%s' at %L cannot have the "
3369 "ALLOCATABLE attribute because it is a member "
3370 "of the BIND(C) derived type '%s' at %L",
3371 curr_comp->name, &(curr_comp->loc),
3372 derived_sym->name, &(derived_sym->declared_at));
3376 /* BIND(C) derived types must have interoperable components. */
3377 if (curr_comp->ts.type == BT_DERIVED
3378 && curr_comp->ts.derived->ts.is_iso_c != 1
3379 && curr_comp->ts.derived != derived_sym)
3381 /* This should be allowed; the draft says a derived-type can not
3382 have type parameters if it is has the BIND attribute. Type
3383 parameters seem to be for making parameterized derived types.
3384 There's no need to verify the type if it is c_ptr/c_funptr. */
3385 retval = verify_bind_c_derived_type (curr_comp->ts.derived);
3389 /* Grab the typespec for the given component and test the kind. */
3390 is_c_interop = verify_c_interop (&(curr_comp->ts), curr_comp->name,
3393 if (is_c_interop != SUCCESS)
3395 /* Report warning and continue since not fatal. The
3396 draft does specify a constraint that requires all fields
3397 to interoperate, but if the user says real(4), etc., it
3398 may interoperate with *something* in C, but the compiler
3399 most likely won't know exactly what. Further, it may not
3400 interoperate with the same data type(s) in C if the user
3401 recompiles with different flags (e.g., -m32 and -m64 on
3402 x86_64 and using integer(4) to claim interop with a
3404 if (derived_sym->attr.is_bind_c == 1)
3405 /* If the derived type is bind(c), all fields must be
3407 gfc_warning ("Component '%s' in derived type '%s' at %L "
3408 "may not be C interoperable, even though "
3409 "derived type '%s' is BIND(C)",
3410 curr_comp->name, derived_sym->name,
3411 &(curr_comp->loc), derived_sym->name);
3413 /* If derived type is param to bind(c) routine, or to one
3414 of the iso_c_binding procs, it must be interoperable, so
3415 all fields must interop too. */
3416 gfc_warning ("Component '%s' in derived type '%s' at %L "
3417 "may not be C interoperable",
3418 curr_comp->name, derived_sym->name,
3423 curr_comp = curr_comp->next;
3424 } while (curr_comp != NULL);
3427 /* Make sure we don't have conflicts with the attributes. */
3428 if (derived_sym->attr.access == ACCESS_PRIVATE)
3430 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3431 "PRIVATE and BIND(C) attributes", derived_sym->name,
3432 &(derived_sym->declared_at));
3436 if (derived_sym->attr.sequence != 0)
3438 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3439 "attribute because it is BIND(C)", derived_sym->name,
3440 &(derived_sym->declared_at));
3444 /* Mark the derived type as not being C interoperable if we found an
3445 error. If there were only warnings, proceed with the assumption
3446 it's interoperable. */
3447 if (retval == FAILURE)
3448 derived_sym->ts.is_c_interop = 0;
3454 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3457 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3458 const char *module_name)
3460 gfc_symtree *tmp_symtree;
3461 gfc_symbol *tmp_sym;
3463 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3465 if (tmp_symtree != NULL)
3466 tmp_sym = tmp_symtree->n.sym;
3470 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3471 "create symbol for %s", ptr_name);
3474 /* Set up the symbol's important fields. Save attr required so we can
3475 initialize the ptr to NULL. */
3476 tmp_sym->attr.save = SAVE_EXPLICIT;
3477 tmp_sym->ts.is_c_interop = 1;
3478 tmp_sym->attr.is_c_interop = 1;
3479 tmp_sym->ts.is_iso_c = 1;
3480 tmp_sym->ts.type = BT_DERIVED;
3482 /* The c_ptr and c_funptr derived types will provide the
3483 definition for c_null_ptr and c_null_funptr, respectively. */
3484 if (ptr_id == ISOCBINDING_NULL_PTR)
3485 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3487 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3488 if (tmp_sym->ts.derived == NULL)
3490 /* This can occur if the user forgot to declare c_ptr or
3491 c_funptr and they're trying to use one of the procedures
3492 that has arg(s) of the missing type. In this case, a
3493 regular version of the thing should have been put in the
3495 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3496 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3497 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3498 ? "_gfortran_iso_c_binding_c_ptr"
3499 : "_gfortran_iso_c_binding_c_funptr"));
3501 tmp_sym->ts.derived =
3502 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3503 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3506 /* Module name is some mangled version of iso_c_binding. */
3507 tmp_sym->module = gfc_get_string (module_name);
3509 /* Say it's from the iso_c_binding module. */
3510 tmp_sym->attr.is_iso_c = 1;
3512 tmp_sym->attr.use_assoc = 1;
3513 tmp_sym->attr.is_bind_c = 1;
3514 /* Set the binding_label. */
3515 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3517 /* Set the c_address field of c_null_ptr and c_null_funptr to
3518 the value of NULL. */
3519 tmp_sym->value = gfc_get_expr ();
3520 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3521 tmp_sym->value->ts.type = BT_DERIVED;
3522 tmp_sym->value->ts.derived = tmp_sym->ts.derived;
3523 /* Create a constructor with no expr, that way we can recognize if the user
3524 tries to call the structure constructor for one of the iso_c_binding
3525 derived types during resolution (resolve_structure_cons). */
3526 tmp_sym->value->value.constructor = gfc_get_constructor ();
3527 /* Must declare c_null_ptr and c_null_funptr as having the
3528 PARAMETER attribute so they can be used in init expressions. */
3529 tmp_sym->attr.flavor = FL_PARAMETER;
3535 /* Add a formal argument, gfc_formal_arglist, to the
3536 end of the given list of arguments. Set the reference to the
3537 provided symbol, param_sym, in the argument. */
3540 add_formal_arg (gfc_formal_arglist **head,
3541 gfc_formal_arglist **tail,
3542 gfc_formal_arglist *formal_arg,
3543 gfc_symbol *param_sym)
3545 /* Put in list, either as first arg or at the tail (curr arg). */
3547 *head = *tail = formal_arg;
3550 (*tail)->next = formal_arg;
3551 (*tail) = formal_arg;
3554 (*tail)->sym = param_sym;
3555 (*tail)->next = NULL;
3561 /* Generates a symbol representing the CPTR argument to an
3562 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3563 CPTR and add it to the provided argument list. */
3566 gen_cptr_param (gfc_formal_arglist **head,
3567 gfc_formal_arglist **tail,
3568 const char *module_name,
3569 gfc_namespace *ns, const char *c_ptr_name,
3572 gfc_symbol *param_sym = NULL;
3573 gfc_symbol *c_ptr_sym = NULL;
3574 gfc_symtree *param_symtree = NULL;
3575 gfc_formal_arglist *formal_arg = NULL;
3576 const char *c_ptr_in;
3577 const char *c_ptr_type = NULL;
3579 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3580 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3582 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3584 if(c_ptr_name == NULL)
3585 c_ptr_in = "gfc_cptr__";
3587 c_ptr_in = c_ptr_name;
3588 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree);
3589 if (param_symtree != NULL)
3590 param_sym = param_symtree->n.sym;
3592 gfc_internal_error ("gen_cptr_param(): Unable to "
3593 "create symbol for %s", c_ptr_in);
3595 /* Set up the appropriate fields for the new c_ptr param sym. */
3597 param_sym->attr.flavor = FL_DERIVED;
3598 param_sym->ts.type = BT_DERIVED;
3599 param_sym->attr.intent = INTENT_IN;
3600 param_sym->attr.dummy = 1;
3602 /* This will pass the ptr to the iso_c routines as a (void *). */
3603 param_sym->attr.value = 1;
3604 param_sym->attr.use_assoc = 1;
3606 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3608 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3609 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3611 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3612 if (c_ptr_sym == NULL)
3614 /* This can happen if the user did not define c_ptr but they are
3615 trying to use one of the iso_c_binding functions that need it. */
3616 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3617 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3618 (const char *)c_ptr_type);
3620 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3621 (const char *)c_ptr_type);
3623 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3626 param_sym->ts.derived = c_ptr_sym;
3627 param_sym->module = gfc_get_string (module_name);
3629 /* Make new formal arg. */
3630 formal_arg = gfc_get_formal_arglist ();
3631 /* Add arg to list of formal args (the CPTR arg). */
3632 add_formal_arg (head, tail, formal_arg, param_sym);
3636 /* Generates a symbol representing the FPTR argument to an
3637 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3638 FPTR and add it to the provided argument list. */
3641 gen_fptr_param (gfc_formal_arglist **head,
3642 gfc_formal_arglist **tail,
3643 const char *module_name,
3644 gfc_namespace *ns, const char *f_ptr_name, int proc)
3646 gfc_symbol *param_sym = NULL;
3647 gfc_symtree *param_symtree = NULL;
3648 gfc_formal_arglist *formal_arg = NULL;
3649 const char *f_ptr_out = "gfc_fptr__";
3651 if (f_ptr_name != NULL)
3652 f_ptr_out = f_ptr_name;
3654 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree);
3655 if (param_symtree != NULL)
3656 param_sym = param_symtree->n.sym;
3658 gfc_internal_error ("generateFPtrParam(): Unable to "
3659 "create symbol for %s", f_ptr_out);
3661 /* Set up the necessary fields for the fptr output param sym. */
3664 param_sym->attr.proc_pointer = 1;
3666 param_sym->attr.pointer = 1;
3667 param_sym->attr.dummy = 1;
3668 param_sym->attr.use_assoc = 1;
3670 /* ISO C Binding type to allow any pointer type as actual param. */
3671 param_sym->ts.type = BT_VOID;
3672 param_sym->module = gfc_get_string (module_name);
3675 formal_arg = gfc_get_formal_arglist ();
3676 /* Add arg to list of formal args. */
3677 add_formal_arg (head, tail, formal_arg, param_sym);
3681 /* Generates a symbol representing the optional SHAPE argument for the
3682 iso_c_binding c_f_pointer() procedure. Also, create a
3683 gfc_formal_arglist for the SHAPE and add it to the provided
3687 gen_shape_param (gfc_formal_arglist **head,
3688 gfc_formal_arglist **tail,
3689 const char *module_name,
3690 gfc_namespace *ns, const char *shape_param_name)
3692 gfc_symbol *param_sym = NULL;
3693 gfc_symtree *param_symtree = NULL;
3694 gfc_formal_arglist *formal_arg = NULL;
3695 const char *shape_param = "gfc_shape_array__";
3698 if (shape_param_name != NULL)
3699 shape_param = shape_param_name;
3701 gfc_get_sym_tree (shape_param, ns, ¶m_symtree);
3702 if (param_symtree != NULL)
3703 param_sym = param_symtree->n.sym;
3705 gfc_internal_error ("generateShapeParam(): Unable to "
3706 "create symbol for %s", shape_param);
3708 /* Set up the necessary fields for the shape input param sym. */
3710 param_sym->attr.dummy = 1;
3711 param_sym->attr.use_assoc = 1;
3713 /* Integer array, rank 1, describing the shape of the object. Make it's
3714 type BT_VOID initially so we can accept any type/kind combination of
3715 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3716 of BT_INTEGER type. */
3717 param_sym->ts.type = BT_VOID;
3719 /* Initialize the kind to default integer. However, it will be overridden
3720 during resolution to match the kind of the SHAPE parameter given as
3721 the actual argument (to allow for any valid integer kind). */
3722 param_sym->ts.kind = gfc_default_integer_kind;
3723 param_sym->as = gfc_get_array_spec ();
3725 /* Clear out the dimension info for the array. */
3726 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3728 param_sym->as->lower[i] = NULL;
3729 param_sym->as->upper[i] = NULL;
3731 param_sym->as->rank = 1;
3732 param_sym->as->lower[0] = gfc_int_expr (1);
3734 /* The extent is unknown until we get it. The length give us
3735 the rank the incoming pointer. */
3736 param_sym->as->type = AS_ASSUMED_SHAPE;
3738 /* The arg is also optional; it is required iff the second arg
3739 (fptr) is to an array, otherwise, it's ignored. */
3740 param_sym->attr.optional = 1;
3741 param_sym->attr.intent = INTENT_IN;
3742 param_sym->attr.dimension = 1;
3743 param_sym->module = gfc_get_string (module_name);
3746 formal_arg = gfc_get_formal_arglist ();
3747 /* Add arg to list of formal args. */
3748 add_formal_arg (head, tail, formal_arg, param_sym);
3751 /* Add a procedure interface to the given symbol (i.e., store a
3752 reference to the list of formal arguments). */
3755 add_proc_interface (gfc_symbol *sym, ifsrc source,
3756 gfc_formal_arglist *formal)
3759 sym->formal = formal;
3760 sym->attr.if_source = source;
3763 /* Copy the formal args from an existing symbol, src, into a new
3764 symbol, dest. New formal args are created, and the description of
3765 each arg is set according to the existing ones. This function is
3766 used when creating procedure declaration variables from a procedure
3767 declaration statement (see match_proc_decl()) to create the formal
3768 args based on the args of a given named interface. */
3771 copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
3773 gfc_formal_arglist *head = NULL;
3774 gfc_formal_arglist *tail = NULL;
3775 gfc_formal_arglist *formal_arg = NULL;
3776 gfc_formal_arglist *curr_arg = NULL;
3777 gfc_formal_arglist *formal_prev = NULL;
3778 /* Save current namespace so we can change it for formal args. */
3779 gfc_namespace *parent_ns = gfc_current_ns;
3781 /* Create a new namespace, which will be the formal ns (namespace
3782 of the formal args). */
3783 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3784 gfc_current_ns->proc_name = dest;
3786 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3788 formal_arg = gfc_get_formal_arglist ();
3789 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
3791 /* May need to copy more info for the symbol. */
3792 formal_arg->sym->attr = curr_arg->sym->attr;
3793 formal_arg->sym->ts = curr_arg->sym->ts;
3794 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
3796 /* If this isn't the first arg, set up the next ptr. For the
3797 last arg built, the formal_arg->next will never get set to
3798 anything other than NULL. */
3799 if (formal_prev != NULL)
3800 formal_prev->next = formal_arg;
3802 formal_arg->next = NULL;
3804 formal_prev = formal_arg;
3806 /* Add arg to list of formal args. */
3807 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3810 /* Add the interface to the symbol. */
3811 add_proc_interface (dest, IFSRC_DECL, head);
3813 /* Store the formal namespace information. */
3814 if (dest->formal != NULL)
3815 /* The current ns should be that for the dest proc. */
3816 dest->formal_ns = gfc_current_ns;
3817 /* Restore the current namespace to what it was on entry. */
3818 gfc_current_ns = parent_ns;
3821 /* Builds the parameter list for the iso_c_binding procedure
3822 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3823 generic version of either the c_f_pointer or c_f_procpointer
3824 functions. The new_proc_sym represents a "resolved" version of the
3825 symbol. The functions are resolved to match the types of their
3826 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3827 something similar to c_f_pointer_i4 if the type of data object fptr
3828 pointed to was a default integer. The actual name of the resolved
3829 procedure symbol is further mangled with the module name, etc., but
3830 the idea holds true. */
3833 build_formal_args (gfc_symbol *new_proc_sym,
3834 gfc_symbol *old_sym, int add_optional_arg)
3836 gfc_formal_arglist *head = NULL, *tail = NULL;
3837 gfc_namespace *parent_ns = NULL;
3839 parent_ns = gfc_current_ns;
3840 /* Create a new namespace, which will be the formal ns (namespace
3841 of the formal args). */
3842 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
3843 gfc_current_ns->proc_name = new_proc_sym;
3845 /* Generate the params. */
3846 if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
3848 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3849 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3850 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3851 gfc_current_ns, "fptr", 1);
3853 else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3855 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3856 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3857 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3858 gfc_current_ns, "fptr", 0);
3859 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3860 gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
3861 gfc_current_ns, "shape");
3864 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3866 /* c_associated has one required arg and one optional; both
3868 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3869 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
3870 if (add_optional_arg)
3872 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3873 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
3874 /* The last param is optional so mark it as such. */
3875 tail->sym->attr.optional = 1;
3879 /* Add the interface (store formal args to new_proc_sym). */
3880 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
3882 /* Set up the formal_ns pointer to the one created for the
3883 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3884 new_proc_sym->formal_ns = gfc_current_ns;
3886 gfc_current_ns = parent_ns;
3890 std_for_isocbinding_symbol (int id)
3894 #define NAMED_INTCST(a,b,c,d) \
3897 #include "iso-c-binding.def"
3900 return GFC_STD_F2003;
3904 /* Generate the given set of C interoperable kind objects, or all
3905 interoperable kinds. This function will only be given kind objects
3906 for valid iso_c_binding defined types because this is verified when
3907 the 'use' statement is parsed. If the user gives an 'only' clause,
3908 the specific kinds are looked up; if they don't exist, an error is
3909 reported. If the user does not give an 'only' clause, all
3910 iso_c_binding symbols are generated. If a list of specific kinds
3911 is given, it must have a NULL in the first empty spot to mark the
3916 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
3917 const char *local_name)
3919 const char *const name = (local_name && local_name[0]) ? local_name
3920 : c_interop_kinds_table[s].name;
3921 gfc_symtree *tmp_symtree = NULL;
3922 gfc_symbol *tmp_sym = NULL;
3923 gfc_dt_list **dt_list_ptr = NULL;
3924 gfc_component *tmp_comp = NULL;
3925 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
3928 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == FAILURE)
3930 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
3932 /* Already exists in this scope so don't re-add it.
3933 TODO: we should probably check that it's really the same symbol. */
3934 if (tmp_symtree != NULL)
3937 /* Create the sym tree in the current ns. */
3938 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
3940 tmp_sym = tmp_symtree->n.sym;
3942 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3945 /* Say what module this symbol belongs to. */
3946 tmp_sym->module = gfc_get_string (mod_name);
3947 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
3948 tmp_sym->intmod_sym_id = s;
3953 #define NAMED_INTCST(a,b,c,d) case a :
3954 #define NAMED_REALCST(a,b,c) case a :
3955 #define NAMED_CMPXCST(a,b,c) case a :
3956 #define NAMED_LOGCST(a,b,c) case a :
3957 #define NAMED_CHARKNDCST(a,b,c) case a :
3958 #include "iso-c-binding.def"
3960 tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
3962 /* Initialize an integer constant expression node. */
3963 tmp_sym->attr.flavor = FL_PARAMETER;
3964 tmp_sym->ts.type = BT_INTEGER;
3965 tmp_sym->ts.kind = gfc_default_integer_kind;
3967 /* Mark this type as a C interoperable one. */
3968 tmp_sym->ts.is_c_interop = 1;
3969 tmp_sym->ts.is_iso_c = 1;
3970 tmp_sym->value->ts.is_c_interop = 1;
3971 tmp_sym->value->ts.is_iso_c = 1;
3972 tmp_sym->attr.is_c_interop = 1;
3974 /* Tell what f90 type this c interop kind is valid. */
3975 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
3977 /* Say it's from the iso_c_binding module. */
3978 tmp_sym->attr.is_iso_c = 1;
3980 /* Make it use associated. */
3981 tmp_sym->attr.use_assoc = 1;
3985 #define NAMED_CHARCST(a,b,c) case a :
3986 #include "iso-c-binding.def"
3988 /* Initialize an integer constant expression node for the
3989 length of the character. */
3990 tmp_sym->value = gfc_get_expr ();
3991 tmp_sym->value->expr_type = EXPR_CONSTANT;
3992 tmp_sym->value->ts.type = BT_CHARACTER;
3993 tmp_sym->value->ts.kind = gfc_default_character_kind;
3994 tmp_sym->value->where = gfc_current_locus;
3995 tmp_sym->value->ts.is_c_interop = 1;
3996 tmp_sym->value->ts.is_iso_c = 1;
3997 tmp_sym->value->value.character.length = 1;
3998 tmp_sym->value->value.character.string = gfc_get_wide_string (2);
3999 tmp_sym->value->value.character.string[0]
4000 = (gfc_char_t) c_interop_kinds_table[s].value;
4001 tmp_sym->value->value.character.string[1] = '\0';
4002 tmp_sym->ts.cl = gfc_get_charlen ();
4003 tmp_sym->ts.cl->length = gfc_int_expr (1);
4005 /* May not need this in both attr and ts, but do need in
4006 attr for writing module file. */
4007 tmp_sym->attr.is_c_interop = 1;
4009 tmp_sym->attr.flavor = FL_PARAMETER;
4010 tmp_sym->ts.type = BT_CHARACTER;
4012 /* Need to set it to the C_CHAR kind. */
4013 tmp_sym->ts.kind = gfc_default_character_kind;
4015 /* Mark this type as a C interoperable one. */
4016 tmp_sym->ts.is_c_interop = 1;
4017 tmp_sym->ts.is_iso_c = 1;
4019 /* Tell what f90 type this c interop kind is valid. */
4020 tmp_sym->ts.f90_type = BT_CHARACTER;
4022 /* Say it's from the iso_c_binding module. */
4023 tmp_sym->attr.is_iso_c = 1;
4025 /* Make it use associated. */
4026 tmp_sym->attr.use_assoc = 1;
4029 case ISOCBINDING_PTR:
4030 case ISOCBINDING_FUNPTR:
4032 /* Initialize an integer constant expression node. */
4033 tmp_sym->attr.flavor = FL_DERIVED;
4034 tmp_sym->ts.is_c_interop = 1;
4035 tmp_sym->attr.is_c_interop = 1;
4036 tmp_sym->attr.is_iso_c = 1;
4037 tmp_sym->ts.is_iso_c = 1;
4038 tmp_sym->ts.type = BT_DERIVED;
4040 /* A derived type must have the bind attribute to be
4041 interoperable (J3/04-007, Section 15.2.3), even though
4042 the binding label is not used. */
4043 tmp_sym->attr.is_bind_c = 1;
4045 tmp_sym->attr.referenced = 1;
4047 tmp_sym->ts.derived = tmp_sym;
4049 /* Add the symbol created for the derived type to the current ns. */
4050 dt_list_ptr = &(gfc_derived_types);
4051 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4052 dt_list_ptr = &((*dt_list_ptr)->next);
4054 /* There is already at least one derived type in the list, so append
4055 the one we're currently building for c_ptr or c_funptr. */
4056 if (*dt_list_ptr != NULL)
4057 dt_list_ptr = &((*dt_list_ptr)->next);
4058 (*dt_list_ptr) = gfc_get_dt_list ();
4059 (*dt_list_ptr)->derived = tmp_sym;
4060 (*dt_list_ptr)->next = NULL;
4062 /* Set up the component of the derived type, which will be
4063 an integer with kind equal to c_ptr_size. Mangle the name of
4064 the field for the c_address to prevent the curious user from
4065 trying to access it from Fortran. */
4066 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
4067 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
4068 if (tmp_comp == NULL)
4069 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4070 "create component for c_address");
4072 tmp_comp->ts.type = BT_INTEGER;
4074 /* Set this because the module will need to read/write this field. */
4075 tmp_comp->ts.f90_type = BT_INTEGER;
4077 /* The kinds for c_ptr and c_funptr are the same. */
4078 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4079 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4081 tmp_comp->pointer = 0;
4082 tmp_comp->dimension = 0;
4084 /* Mark the component as C interoperable. */
4085 tmp_comp->ts.is_c_interop = 1;
4087 /* Make it use associated (iso_c_binding module). */
4088 tmp_sym->attr.use_assoc = 1;
4091 case ISOCBINDING_NULL_PTR:
4092 case ISOCBINDING_NULL_FUNPTR:
4093 gen_special_c_interop_ptr (s, name, mod_name);
4096 case ISOCBINDING_F_POINTER:
4097 case ISOCBINDING_ASSOCIATED:
4098 case ISOCBINDING_LOC:
4099 case ISOCBINDING_FUNLOC:
4100 case ISOCBINDING_F_PROCPOINTER:
4102 tmp_sym->attr.proc = PROC_MODULE;
4104 /* Use the procedure's name as it is in the iso_c_binding module for
4105 setting the binding label in case the user renamed the symbol. */
4106 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
4107 c_interop_kinds_table[s].name);
4108 tmp_sym->attr.is_iso_c = 1;
4109 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4110 tmp_sym->attr.subroutine = 1;
4113 /* TODO! This needs to be finished more for the expr of the
4114 function or something!
4115 This may not need to be here, because trying to do c_loc
4117 if (s == ISOCBINDING_ASSOCIATED)
4119 tmp_sym->attr.function = 1;
4120 tmp_sym->ts.type = BT_LOGICAL;
4121 tmp_sym->ts.kind = gfc_default_logical_kind;
4122 tmp_sym->result = tmp_sym;
4126 /* Here, we're taking the simple approach. We're defining
4127 c_loc as an external identifier so the compiler will put
4128 what we expect on the stack for the address we want the
4130 tmp_sym->ts.type = BT_DERIVED;
4131 if (s == ISOCBINDING_LOC)
4132 tmp_sym->ts.derived =
4133 get_iso_c_binding_dt (ISOCBINDING_PTR);
4135 tmp_sym->ts.derived =
4136 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4138 if (tmp_sym->ts.derived == NULL)
4140 /* Create the necessary derived type so we can continue
4141 processing the file. */
4142 generate_isocbinding_symbol
4143 (mod_name, s == ISOCBINDING_FUNLOC
4144 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4145 (const char *)(s == ISOCBINDING_FUNLOC
4146 ? "_gfortran_iso_c_binding_c_funptr"
4147 : "_gfortran_iso_c_binding_c_ptr"));
4148 tmp_sym->ts.derived =
4149 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4150 ? ISOCBINDING_FUNPTR
4154 /* The function result is itself (no result clause). */
4155 tmp_sym->result = tmp_sym;
4156 tmp_sym->attr.external = 1;
4157 tmp_sym->attr.use_assoc = 0;
4158 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4159 tmp_sym->attr.proc = PROC_UNKNOWN;
4163 tmp_sym->attr.flavor = FL_PROCEDURE;
4164 tmp_sym->attr.contained = 0;
4166 /* Try using this builder routine, with the new and old symbols
4167 both being the generic iso_c proc sym being created. This
4168 will create the formal args (and the new namespace for them).
4169 Don't build an arg list for c_loc because we're going to treat
4170 c_loc as an external procedure. */
4171 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4172 /* The 1 says to add any optional args, if applicable. */
4173 build_formal_args (tmp_sym, tmp_sym, 1);
4175 /* Set this after setting up the symbol, to prevent error messages. */
4176 tmp_sym->attr.use_assoc = 1;
4178 /* This symbol will not be referenced directly. It will be
4179 resolved to the implementation for the given f90 kind. */
4180 tmp_sym->attr.referenced = 0;
4190 /* Creates a new symbol based off of an old iso_c symbol, with a new
4191 binding label. This function can be used to create a new,
4192 resolved, version of a procedure symbol for c_f_pointer or
4193 c_f_procpointer that is based on the generic symbols. A new
4194 parameter list is created for the new symbol using
4195 build_formal_args(). The add_optional_flag specifies whether the
4196 to add the optional SHAPE argument. The new symbol is
4200 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4201 char *new_binding_label, int add_optional_arg)
4203 gfc_symtree *new_symtree = NULL;
4205 /* See if we have a symbol by that name already available, looking
4206 through any parent namespaces. */
4207 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4208 if (new_symtree != NULL)
4209 /* Return the existing symbol. */
4210 return new_symtree->n.sym;
4212 /* Create the symtree/symbol, with attempted host association. */
4213 gfc_get_ha_sym_tree (new_name, &new_symtree);
4214 if (new_symtree == NULL)
4215 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4216 "symtree for '%s'", new_name);
4218 /* Now fill in the fields of the resolved symbol with the old sym. */
4219 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4220 new_symtree->n.sym->attr = old_sym->attr;
4221 new_symtree->n.sym->ts = old_sym->ts;
4222 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4223 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4224 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4225 /* Build the formal arg list. */
4226 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4228 gfc_commit_symbol (new_symtree->n.sym);
4230 return new_symtree->n.sym;