1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
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 ("Implicity 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 *private = "PRIVATE", *recursive = "RECURSIVE",
348 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
349 *public = "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", *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)
416 a1 = gfc_code2string (flavors, attr->flavor);
428 conf (dummy, intrinsic);
429 conf (dummy, threadprivate);
430 conf (pointer, target);
431 conf (pointer, intrinsic);
432 conf (pointer, elemental);
433 conf (allocatable, elemental);
435 conf (target, external);
436 conf (target, intrinsic);
437 conf (external, dimension); /* See Fortran 95's R504. */
439 conf (external, intrinsic);
441 if ((attr->if_source && !attr->procedure) || attr->contained)
443 conf (external, subroutine);
444 conf (external, function);
447 conf (allocatable, pointer);
448 conf_std (allocatable, dummy, GFC_STD_F2003);
449 conf_std (allocatable, function, GFC_STD_F2003);
450 conf_std (allocatable, result, GFC_STD_F2003);
451 conf (elemental, recursive);
453 conf (in_common, dummy);
454 conf (in_common, allocatable);
455 conf (in_common, result);
457 conf (dummy, result);
459 conf (in_equivalence, use_assoc);
460 conf (in_equivalence, dummy);
461 conf (in_equivalence, target);
462 conf (in_equivalence, pointer);
463 conf (in_equivalence, function);
464 conf (in_equivalence, result);
465 conf (in_equivalence, entry);
466 conf (in_equivalence, allocatable);
467 conf (in_equivalence, threadprivate);
469 conf (in_namelist, pointer);
470 conf (in_namelist, allocatable);
472 conf (entry, result);
474 conf (function, subroutine);
476 if (!function && !subroutine)
477 conf (is_bind_c, dummy);
479 conf (is_bind_c, cray_pointer);
480 conf (is_bind_c, cray_pointee);
481 conf (is_bind_c, allocatable);
483 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
484 Parameter conflict caught below. Also, value cannot be specified
485 for a dummy procedure. */
487 /* Cray pointer/pointee conflicts. */
488 conf (cray_pointer, cray_pointee);
489 conf (cray_pointer, dimension);
490 conf (cray_pointer, pointer);
491 conf (cray_pointer, target);
492 conf (cray_pointer, allocatable);
493 conf (cray_pointer, external);
494 conf (cray_pointer, intrinsic);
495 conf (cray_pointer, in_namelist);
496 conf (cray_pointer, function);
497 conf (cray_pointer, subroutine);
498 conf (cray_pointer, entry);
500 conf (cray_pointee, allocatable);
501 conf (cray_pointee, intent);
502 conf (cray_pointee, optional);
503 conf (cray_pointee, dummy);
504 conf (cray_pointee, target);
505 conf (cray_pointee, intrinsic);
506 conf (cray_pointee, pointer);
507 conf (cray_pointee, entry);
508 conf (cray_pointee, in_common);
509 conf (cray_pointee, in_equivalence);
510 conf (cray_pointee, threadprivate);
513 conf (data, function);
515 conf (data, allocatable);
516 conf (data, use_assoc);
518 conf (value, pointer)
519 conf (value, allocatable)
520 conf (value, subroutine)
521 conf (value, function)
522 conf (value, volatile_)
523 conf (value, dimension)
524 conf (value, external)
527 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
530 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
534 conf (protected, intrinsic)
535 conf (protected, external)
536 conf (protected, in_common)
538 conf (volatile_, intrinsic)
539 conf (volatile_, external)
541 if (attr->volatile_ && attr->intent == INTENT_IN)
548 conf (procedure, allocatable)
549 conf (procedure, dimension)
550 conf (procedure, intrinsic)
551 conf (procedure, protected)
552 conf (procedure, target)
553 conf (procedure, value)
554 conf (procedure, volatile_)
555 conf (procedure, entry)
556 /* TODO: Implement procedure pointers. */
557 if (attr->procedure && attr->pointer)
559 gfc_error ("Fortran 2003: Procedure pointers at %L are "
560 "not yet implemented in gfortran", where);
564 a1 = gfc_code2string (flavors, attr->flavor);
566 if (attr->in_namelist
567 && attr->flavor != FL_VARIABLE
568 && attr->flavor != FL_PROCEDURE
569 && attr->flavor != FL_UNKNOWN)
575 switch (attr->flavor)
595 conf2 (threadprivate);
605 if (attr->subroutine)
614 conf2 (threadprivate);
619 case PROC_ST_FUNCTION:
631 conf2 (threadprivate);
651 conf2 (threadprivate);
653 if (attr->intent != INTENT_UNKNOWN)
675 conf2 (threadprivate);
676 /* TODO: hmm, double check this. */
688 gfc_error ("%s attribute conflicts with %s attribute at %L",
691 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
692 a1, a2, name, where);
699 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
700 "with %s attribute at %L", a1, a2,
705 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
706 "with %s attribute in '%s' at %L",
707 a1, a2, name, where);
716 /* Mark a symbol as referenced. */
719 gfc_set_sym_referenced (gfc_symbol *sym)
722 if (sym->attr.referenced)
725 sym->attr.referenced = 1;
727 /* Remember which order dummy variables are accessed in. */
729 sym->dummy_order = next_dummy_order++;
733 /* Common subroutine called by attribute changing subroutines in order
734 to prevent them from changing a symbol that has been
735 use-associated. Returns zero if it is OK to change the symbol,
739 check_used (symbol_attribute *attr, const char *name, locus *where)
742 if (attr->use_assoc == 0)
746 where = &gfc_current_locus;
749 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
752 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
759 /* Generate an error because of a duplicate attribute. */
762 duplicate_attr (const char *attr, locus *where)
766 where = &gfc_current_locus;
768 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
772 /* Called from decl.c (attr_decl1) to check attributes, when declared
776 gfc_add_attribute (symbol_attribute *attr, locus *where)
779 if (check_used (attr, NULL, where))
782 return check_conflict (attr, NULL, where);
786 gfc_add_allocatable (symbol_attribute *attr, locus *where)
789 if (check_used (attr, NULL, where))
792 if (attr->allocatable)
794 duplicate_attr ("ALLOCATABLE", where);
798 attr->allocatable = 1;
799 return check_conflict (attr, NULL, where);
804 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
807 if (check_used (attr, name, where))
812 duplicate_attr ("DIMENSION", where);
817 return check_conflict (attr, name, where);
822 gfc_add_external (symbol_attribute *attr, locus *where)
825 if (check_used (attr, NULL, where))
830 duplicate_attr ("EXTERNAL", where);
836 return check_conflict (attr, NULL, where);
841 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
844 if (check_used (attr, NULL, where))
849 duplicate_attr ("INTRINSIC", where);
855 return check_conflict (attr, NULL, where);
860 gfc_add_optional (symbol_attribute *attr, locus *where)
863 if (check_used (attr, NULL, where))
868 duplicate_attr ("OPTIONAL", where);
873 return check_conflict (attr, NULL, where);
878 gfc_add_pointer (symbol_attribute *attr, locus *where)
881 if (check_used (attr, NULL, where))
885 return check_conflict (attr, NULL, where);
890 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
893 if (check_used (attr, NULL, where))
896 attr->cray_pointer = 1;
897 return check_conflict (attr, NULL, where);
902 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
905 if (check_used (attr, NULL, where))
908 if (attr->cray_pointee)
910 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
911 " statements", where);
915 attr->cray_pointee = 1;
916 return check_conflict (attr, NULL, where);
921 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
923 if (check_used (attr, name, where))
928 if (gfc_notify_std (GFC_STD_LEGACY,
929 "Duplicate PROTECTED attribute specified at %L",
936 return check_conflict (attr, name, where);
941 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
944 if (check_used (attr, name, where))
948 return check_conflict (attr, name, where);
953 gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
956 if (check_used (attr, name, where))
962 ("SAVE attribute at %L cannot be specified in a PURE procedure",
967 if (attr->save == SAVE_EXPLICIT)
969 if (gfc_notify_std (GFC_STD_LEGACY,
970 "Duplicate SAVE attribute specified at %L",
976 attr->save = SAVE_EXPLICIT;
977 return check_conflict (attr, name, where);
982 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
985 if (check_used (attr, name, where))
990 if (gfc_notify_std (GFC_STD_LEGACY,
991 "Duplicate VALUE attribute specified at %L",
998 return check_conflict (attr, name, where);
1003 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1005 /* No check_used needed as 11.2.1 of the F2003 standard allows
1006 that the local identifier made accessible by a use statement can be
1007 given a VOLATILE attribute. */
1009 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1010 if (gfc_notify_std (GFC_STD_LEGACY,
1011 "Duplicate VOLATILE attribute specified at %L", where)
1015 attr->volatile_ = 1;
1016 attr->volatile_ns = gfc_current_ns;
1017 return check_conflict (attr, name, where);
1022 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1025 if (check_used (attr, name, where))
1028 if (attr->threadprivate)
1030 duplicate_attr ("THREADPRIVATE", where);
1034 attr->threadprivate = 1;
1035 return check_conflict (attr, name, where);
1040 gfc_add_target (symbol_attribute *attr, locus *where)
1043 if (check_used (attr, NULL, where))
1048 duplicate_attr ("TARGET", where);
1053 return check_conflict (attr, NULL, where);
1058 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1061 if (check_used (attr, name, where))
1064 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1066 return check_conflict (attr, name, where);
1071 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1074 if (check_used (attr, name, where))
1077 /* Duplicate attribute already checked for. */
1078 attr->in_common = 1;
1079 if (check_conflict (attr, name, where) == FAILURE)
1082 if (attr->flavor == FL_VARIABLE)
1085 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1090 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1093 /* Duplicate attribute already checked for. */
1094 attr->in_equivalence = 1;
1095 if (check_conflict (attr, name, where) == FAILURE)
1098 if (attr->flavor == FL_VARIABLE)
1101 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1106 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1109 if (check_used (attr, name, where))
1113 return check_conflict (attr, name, where);
1118 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1121 attr->in_namelist = 1;
1122 return check_conflict (attr, name, where);
1127 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1130 if (check_used (attr, name, where))
1134 return check_conflict (attr, name, where);
1139 gfc_add_elemental (symbol_attribute *attr, locus *where)
1142 if (check_used (attr, NULL, where))
1145 attr->elemental = 1;
1146 return check_conflict (attr, NULL, where);
1151 gfc_add_pure (symbol_attribute *attr, locus *where)
1154 if (check_used (attr, NULL, where))
1158 return check_conflict (attr, NULL, where);
1163 gfc_add_recursive (symbol_attribute *attr, locus *where)
1166 if (check_used (attr, NULL, where))
1169 attr->recursive = 1;
1170 return check_conflict (attr, NULL, where);
1175 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1178 if (check_used (attr, name, where))
1183 duplicate_attr ("ENTRY", where);
1188 return check_conflict (attr, name, where);
1193 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1196 if (attr->flavor != FL_PROCEDURE
1197 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1201 return check_conflict (attr, name, where);
1206 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1209 if (attr->flavor != FL_PROCEDURE
1210 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1213 attr->subroutine = 1;
1214 return check_conflict (attr, name, where);
1219 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1222 if (attr->flavor != FL_PROCEDURE
1223 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1227 return check_conflict (attr, name, where);
1232 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1235 if (check_used (attr, NULL, where))
1238 if (attr->flavor != FL_PROCEDURE
1239 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1242 if (attr->procedure)
1244 duplicate_attr ("PROCEDURE", where);
1248 attr->procedure = 1;
1250 return check_conflict (attr, NULL, where);
1254 /* Flavors are special because some flavors are not what Fortran
1255 considers attributes and can be reaffirmed multiple times. */
1258 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1262 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1263 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1264 || f == FL_NAMELIST) && check_used (attr, name, where))
1267 if (attr->flavor == f && f == FL_VARIABLE)
1270 if (attr->flavor != FL_UNKNOWN)
1273 where = &gfc_current_locus;
1276 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1277 gfc_code2string (flavors, attr->flavor), name,
1278 gfc_code2string (flavors, f), where);
1280 gfc_error ("%s attribute conflicts with %s attribute at %L",
1281 gfc_code2string (flavors, attr->flavor),
1282 gfc_code2string (flavors, f), where);
1289 return check_conflict (attr, name, where);
1294 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1295 const char *name, locus *where)
1298 if (check_used (attr, name, where))
1301 if (attr->flavor != FL_PROCEDURE
1302 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1306 where = &gfc_current_locus;
1308 if (attr->proc != PROC_UNKNOWN)
1310 gfc_error ("%s procedure at %L is already declared as %s procedure",
1311 gfc_code2string (procedures, t), where,
1312 gfc_code2string (procedures, attr->proc));
1319 /* Statement functions are always scalar and functions. */
1320 if (t == PROC_ST_FUNCTION
1321 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1322 || attr->dimension))
1325 return check_conflict (attr, name, where);
1330 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1333 if (check_used (attr, NULL, where))
1336 if (attr->intent == INTENT_UNKNOWN)
1338 attr->intent = intent;
1339 return check_conflict (attr, NULL, where);
1343 where = &gfc_current_locus;
1345 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1346 gfc_intent_string (attr->intent),
1347 gfc_intent_string (intent), where);
1353 /* No checks for use-association in public and private statements. */
1356 gfc_add_access (symbol_attribute *attr, gfc_access access,
1357 const char *name, locus *where)
1360 if (attr->access == ACCESS_UNKNOWN)
1362 attr->access = access;
1363 return check_conflict (attr, name, where);
1367 where = &gfc_current_locus;
1368 gfc_error ("ACCESS specification at %L was already specified", where);
1374 /* Set the is_bind_c field for the given symbol_attribute. */
1377 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1378 int is_proc_lang_bind_spec)
1381 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1382 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1383 "variables or common blocks", where);
1384 else if (attr->is_bind_c)
1385 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1387 attr->is_bind_c = 1;
1390 where = &gfc_current_locus;
1392 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1396 return check_conflict (attr, name, where);
1401 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1402 gfc_formal_arglist * formal, locus *where)
1405 if (check_used (&sym->attr, sym->name, where))
1409 where = &gfc_current_locus;
1411 if (sym->attr.if_source != IFSRC_UNKNOWN
1412 && sym->attr.if_source != IFSRC_DECL)
1414 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1419 sym->formal = formal;
1420 sym->attr.if_source = source;
1426 /* Add a type to a symbol. */
1429 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1434 where = &gfc_current_locus;
1436 if (sym->ts.type != BT_UNKNOWN)
1438 const char *msg = "Symbol '%s' at %L already has basic type of %s";
1439 if (!(sym->ts.type == ts->type
1440 && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
1441 || gfc_notification_std (GFC_STD_GNU) == ERROR
1444 gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1447 else if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
1448 gfc_basic_typename (sym->ts.type)) == FAILURE)
1452 flavor = sym->attr.flavor;
1454 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1455 || flavor == FL_LABEL
1456 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1457 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1459 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1468 /* Clears all attributes. */
1471 gfc_clear_attr (symbol_attribute *attr)
1473 memset (attr, 0, sizeof (symbol_attribute));
1477 /* Check for missing attributes in the new symbol. Currently does
1478 nothing, but it's not clear that it is unnecessary yet. */
1481 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1482 locus *where ATTRIBUTE_UNUSED)
1489 /* Copy an attribute to a symbol attribute, bit by bit. Some
1490 attributes have a lot of side-effects but cannot be present given
1491 where we are called from, so we ignore some bits. */
1494 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1496 int is_proc_lang_bind_spec;
1498 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1501 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1503 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1505 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1507 if (src->protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1509 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1511 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1513 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1515 if (src->threadprivate
1516 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1518 if (src->target && gfc_add_target (dest, where) == FAILURE)
1520 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1522 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1527 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1530 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1533 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1535 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1537 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1540 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1542 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1544 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1546 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1549 if (src->flavor != FL_UNKNOWN
1550 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1553 if (src->intent != INTENT_UNKNOWN
1554 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1557 if (src->access != ACCESS_UNKNOWN
1558 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1561 if (gfc_missing_attr (dest, where) == FAILURE)
1564 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1566 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1569 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1571 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1575 if (src->is_c_interop)
1576 dest->is_c_interop = 1;
1580 if (src->external && gfc_add_external (dest, where) == FAILURE)
1582 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1592 /************** Component name management ************/
1594 /* Component names of a derived type form their own little namespaces
1595 that are separate from all other spaces. The space is composed of
1596 a singly linked list of gfc_component structures whose head is
1597 located in the parent symbol. */
1600 /* Add a component name to a symbol. The call fails if the name is
1601 already present. On success, the component pointer is modified to
1602 point to the additional component structure. */
1605 gfc_add_component (gfc_symbol *sym, const char *name,
1606 gfc_component **component)
1608 gfc_component *p, *tail;
1612 for (p = sym->components; p; p = p->next)
1614 if (strcmp (p->name, name) == 0)
1616 gfc_error ("Component '%s' at %C already declared at %L",
1624 /* Allocate a new component. */
1625 p = gfc_get_component ();
1628 sym->components = p;
1632 p->name = gfc_get_string (name);
1633 p->loc = gfc_current_locus;
1640 /* Recursive function to switch derived types of all symbol in a
1644 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1652 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1653 sym->ts.derived = to;
1655 switch_types (st->left, from, to);
1656 switch_types (st->right, from, to);
1660 /* This subroutine is called when a derived type is used in order to
1661 make the final determination about which version to use. The
1662 standard requires that a type be defined before it is 'used', but
1663 such types can appear in IMPLICIT statements before the actual
1664 definition. 'Using' in this context means declaring a variable to
1665 be that type or using the type constructor.
1667 If a type is used and the components haven't been defined, then we
1668 have to have a derived type in a parent unit. We find the node in
1669 the other namespace and point the symtree node in this namespace to
1670 that node. Further reference to this name point to the correct
1671 node. If we can't find the node in a parent namespace, then we have
1674 This subroutine takes a pointer to a symbol node and returns a
1675 pointer to the translated node or NULL for an error. Usually there
1676 is no translation and we return the node we were passed. */
1679 gfc_use_derived (gfc_symbol *sym)
1686 if (sym->components != NULL)
1687 return sym; /* Already defined. */
1689 if (sym->ns->parent == NULL)
1692 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1694 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1698 if (s == NULL || s->attr.flavor != FL_DERIVED)
1701 /* Get rid of symbol sym, translating all references to s. */
1702 for (i = 0; i < GFC_LETTERS; i++)
1704 t = &sym->ns->default_type[i];
1705 if (t->derived == sym)
1709 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1714 /* Unlink from list of modified symbols. */
1715 gfc_commit_symbol (sym);
1717 switch_types (sym->ns->sym_root, sym, s);
1719 /* TODO: Also have to replace sym -> s in other lists like
1720 namelists, common lists and interface lists. */
1721 gfc_free_symbol (sym);
1726 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1732 /* Given a derived type node and a component name, try to locate the
1733 component structure. Returns the NULL pointer if the component is
1734 not found or the components are private. */
1737 gfc_find_component (gfc_symbol *sym, const char *name)
1744 sym = gfc_use_derived (sym);
1749 for (p = sym->components; p; p = p->next)
1750 if (strcmp (p->name, name) == 0)
1754 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1758 if (sym->attr.use_assoc && (sym->component_access == ACCESS_PRIVATE
1759 || p->access == ACCESS_PRIVATE))
1761 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1771 /* Given a symbol, free all of the component structures and everything
1775 free_components (gfc_component *p)
1783 gfc_free_array_spec (p->as);
1784 gfc_free_expr (p->initializer);
1791 /* Set component attributes from a standard symbol attribute structure. */
1794 gfc_set_component_attr (gfc_component *c, symbol_attribute *attr)
1797 c->dimension = attr->dimension;
1798 c->pointer = attr->pointer;
1799 c->allocatable = attr->allocatable;
1800 c->access = attr->access;
1804 /* Get a standard symbol attribute structure given the component
1808 gfc_get_component_attr (symbol_attribute *attr, gfc_component *c)
1811 gfc_clear_attr (attr);
1812 attr->dimension = c->dimension;
1813 attr->pointer = c->pointer;
1814 attr->allocatable = c->allocatable;
1815 attr->access = c->access;
1819 /******************** Statement label management ********************/
1821 /* Comparison function for statement labels, used for managing the
1825 compare_st_labels (void *a1, void *b1)
1827 int a = ((gfc_st_label *) a1)->value;
1828 int b = ((gfc_st_label *) b1)->value;
1834 /* Free a single gfc_st_label structure, making sure the tree is not
1835 messed up. This function is called only when some parse error
1839 gfc_free_st_label (gfc_st_label *label)
1845 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
1847 if (label->format != NULL)
1848 gfc_free_expr (label->format);
1854 /* Free a whole tree of gfc_st_label structures. */
1857 free_st_labels (gfc_st_label *label)
1863 free_st_labels (label->left);
1864 free_st_labels (label->right);
1866 if (label->format != NULL)
1867 gfc_free_expr (label->format);
1872 /* Given a label number, search for and return a pointer to the label
1873 structure, creating it if it does not exist. */
1876 gfc_get_st_label (int labelno)
1880 /* First see if the label is already in this namespace. */
1881 lp = gfc_current_ns->st_labels;
1884 if (lp->value == labelno)
1887 if (lp->value < labelno)
1893 lp = gfc_getmem (sizeof (gfc_st_label));
1895 lp->value = labelno;
1896 lp->defined = ST_LABEL_UNKNOWN;
1897 lp->referenced = ST_LABEL_UNKNOWN;
1899 gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
1905 /* Called when a statement with a statement label is about to be
1906 accepted. We add the label to the list of the current namespace,
1907 making sure it hasn't been defined previously and referenced
1911 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
1915 labelno = lp->value;
1917 if (lp->defined != ST_LABEL_UNKNOWN)
1918 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
1919 &lp->where, label_locus);
1922 lp->where = *label_locus;
1926 case ST_LABEL_FORMAT:
1927 if (lp->referenced == ST_LABEL_TARGET)
1928 gfc_error ("Label %d at %C already referenced as branch target",
1931 lp->defined = ST_LABEL_FORMAT;
1935 case ST_LABEL_TARGET:
1936 if (lp->referenced == ST_LABEL_FORMAT)
1937 gfc_error ("Label %d at %C already referenced as a format label",
1940 lp->defined = ST_LABEL_TARGET;
1945 lp->defined = ST_LABEL_BAD_TARGET;
1946 lp->referenced = ST_LABEL_BAD_TARGET;
1952 /* Reference a label. Given a label and its type, see if that
1953 reference is consistent with what is known about that label,
1954 updating the unknown state. Returns FAILURE if something goes
1958 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
1960 gfc_sl_type label_type;
1967 labelno = lp->value;
1969 if (lp->defined != ST_LABEL_UNKNOWN)
1970 label_type = lp->defined;
1973 label_type = lp->referenced;
1974 lp->where = gfc_current_locus;
1977 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
1979 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
1984 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
1985 && type == ST_LABEL_FORMAT)
1987 gfc_error ("Label %d at %C previously used as branch target", labelno);
1992 lp->referenced = type;
2000 /*******A helper function for creating new expressions*************/
2004 gfc_lval_expr_from_sym (gfc_symbol *sym)
2007 lval = gfc_get_expr ();
2008 lval->expr_type = EXPR_VARIABLE;
2009 lval->where = sym->declared_at;
2011 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2013 /* It will always be a full array. */
2014 lval->rank = sym->as ? sym->as->rank : 0;
2017 lval->ref = gfc_get_ref ();
2018 lval->ref->type = REF_ARRAY;
2019 lval->ref->u.ar.type = AR_FULL;
2020 lval->ref->u.ar.dimen = lval->rank;
2021 lval->ref->u.ar.where = sym->declared_at;
2022 lval->ref->u.ar.as = sym->as;
2029 /************** Symbol table management subroutines ****************/
2031 /* Basic details: Fortran 95 requires a potentially unlimited number
2032 of distinct namespaces when compiling a program unit. This case
2033 occurs during a compilation of internal subprograms because all of
2034 the internal subprograms must be read before we can start
2035 generating code for the host.
2037 Given the tricky nature of the Fortran grammar, we must be able to
2038 undo changes made to a symbol table if the current interpretation
2039 of a statement is found to be incorrect. Whenever a symbol is
2040 looked up, we make a copy of it and link to it. All of these
2041 symbols are kept in a singly linked list so that we can commit or
2042 undo the changes at a later time.
2044 A symtree may point to a symbol node outside of its namespace. In
2045 this case, that symbol has been used as a host associated variable
2046 at some previous time. */
2048 /* Allocate a new namespace structure. Copies the implicit types from
2049 PARENT if PARENT_TYPES is set. */
2052 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2056 gfc_intrinsic_op in;
2059 ns = gfc_getmem (sizeof (gfc_namespace));
2060 ns->sym_root = NULL;
2061 ns->uop_root = NULL;
2062 ns->default_access = ACCESS_UNKNOWN;
2063 ns->parent = parent;
2065 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2066 ns->operator_access[in] = ACCESS_UNKNOWN;
2068 /* Initialize default implicit types. */
2069 for (i = 'a'; i <= 'z'; i++)
2071 ns->set_flag[i - 'a'] = 0;
2072 ts = &ns->default_type[i - 'a'];
2074 if (parent_types && ns->parent != NULL)
2076 /* Copy parent settings. */
2077 *ts = ns->parent->default_type[i - 'a'];
2081 if (gfc_option.flag_implicit_none != 0)
2087 if ('i' <= i && i <= 'n')
2089 ts->type = BT_INTEGER;
2090 ts->kind = gfc_default_integer_kind;
2095 ts->kind = gfc_default_real_kind;
2105 /* Comparison function for symtree nodes. */
2108 compare_symtree (void *_st1, void *_st2)
2110 gfc_symtree *st1, *st2;
2112 st1 = (gfc_symtree *) _st1;
2113 st2 = (gfc_symtree *) _st2;
2115 return strcmp (st1->name, st2->name);
2119 /* Allocate a new symtree node and associate it with the new symbol. */
2122 gfc_new_symtree (gfc_symtree **root, const char *name)
2126 st = gfc_getmem (sizeof (gfc_symtree));
2127 st->name = gfc_get_string (name);
2129 gfc_insert_bbt (root, st, compare_symtree);
2134 /* Delete a symbol from the tree. Does not free the symbol itself! */
2137 delete_symtree (gfc_symtree **root, const char *name)
2139 gfc_symtree st, *st0;
2141 st0 = gfc_find_symtree (*root, name);
2143 st.name = gfc_get_string (name);
2144 gfc_delete_bbt (root, &st, compare_symtree);
2150 /* Given a root symtree node and a name, try to find the symbol within
2151 the namespace. Returns NULL if the symbol is not found. */
2154 gfc_find_symtree (gfc_symtree *st, const char *name)
2160 c = strcmp (name, st->name);
2164 st = (c < 0) ? st->left : st->right;
2171 /* Return a symtree node with a name that is guaranteed to be unique
2172 within the namespace and corresponds to an illegal fortran name. */
2175 gfc_get_unique_symtree (gfc_namespace *ns)
2177 char name[GFC_MAX_SYMBOL_LEN + 1];
2178 static int serial = 0;
2180 sprintf (name, "@%d", serial++);
2181 return gfc_new_symtree (&ns->sym_root, name);
2185 /* Given a name find a user operator node, creating it if it doesn't
2186 exist. These are much simpler than symbols because they can't be
2187 ambiguous with one another. */
2190 gfc_get_uop (const char *name)
2195 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2199 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2201 uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op));
2202 uop->name = gfc_get_string (name);
2203 uop->access = ACCESS_UNKNOWN;
2204 uop->ns = gfc_current_ns;
2210 /* Given a name find the user operator node. Returns NULL if it does
2214 gfc_find_uop (const char *name, gfc_namespace *ns)
2219 ns = gfc_current_ns;
2221 st = gfc_find_symtree (ns->uop_root, name);
2222 return (st == NULL) ? NULL : st->n.uop;
2226 /* Remove a gfc_symbol structure and everything it points to. */
2229 gfc_free_symbol (gfc_symbol *sym)
2235 gfc_free_array_spec (sym->as);
2237 free_components (sym->components);
2239 gfc_free_expr (sym->value);
2241 gfc_free_namelist (sym->namelist);
2243 gfc_free_namespace (sym->formal_ns);
2245 if (!sym->attr.generic_copy)
2246 gfc_free_interface (sym->generic);
2248 gfc_free_formal_arglist (sym->formal);
2254 /* Allocate and initialize a new symbol node. */
2257 gfc_new_symbol (const char *name, gfc_namespace *ns)
2261 p = gfc_getmem (sizeof (gfc_symbol));
2263 gfc_clear_ts (&p->ts);
2264 gfc_clear_attr (&p->attr);
2267 p->declared_at = gfc_current_locus;
2269 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2270 gfc_internal_error ("new_symbol(): Symbol name too long");
2272 p->name = gfc_get_string (name);
2274 /* Make sure flags for symbol being C bound are clear initially. */
2275 p->attr.is_bind_c = 0;
2276 p->attr.is_iso_c = 0;
2277 /* Make sure the binding label field has a Nul char to start. */
2278 p->binding_label[0] = '\0';
2280 /* Clear the ptrs we may need. */
2281 p->common_block = NULL;
2287 /* Generate an error if a symbol is ambiguous. */
2290 ambiguous_symbol (const char *name, gfc_symtree *st)
2293 if (st->n.sym->module)
2294 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2295 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2297 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2298 "from current program unit", name, st->n.sym->name);
2302 /* Search for a symtree starting in the current namespace, resorting to
2303 any parent namespaces if requested by a nonzero parent_flag.
2304 Returns nonzero if the name is ambiguous. */
2307 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2308 gfc_symtree **result)
2313 ns = gfc_current_ns;
2317 st = gfc_find_symtree (ns->sym_root, name);
2321 /* Ambiguous generic interfaces are permitted, as long
2322 as the specific interfaces are different. */
2323 if (st->ambiguous && !st->n.sym->attr.generic)
2325 ambiguous_symbol (name, st);
2344 /* Same, but returns the symbol instead. */
2347 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2348 gfc_symbol **result)
2353 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2358 *result = st->n.sym;
2364 /* Save symbol with the information necessary to back it out. */
2367 save_symbol_data (gfc_symbol *sym)
2370 if (sym->new || sym->old_symbol != NULL)
2373 sym->old_symbol = gfc_getmem (sizeof (gfc_symbol));
2374 *(sym->old_symbol) = *sym;
2376 sym->tlink = changed_syms;
2381 /* Given a name, find a symbol, or create it if it does not exist yet
2382 in the current namespace. If the symbol is found we make sure that
2385 The integer return code indicates
2387 1 The symbol name was ambiguous
2388 2 The name meant to be established was already host associated.
2390 So if the return value is nonzero, then an error was issued. */
2393 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
2398 /* This doesn't usually happen during resolution. */
2400 ns = gfc_current_ns;
2402 /* Try to find the symbol in ns. */
2403 st = gfc_find_symtree (ns->sym_root, name);
2407 /* If not there, create a new symbol. */
2408 p = gfc_new_symbol (name, ns);
2410 /* Add to the list of tentative symbols. */
2411 p->old_symbol = NULL;
2412 p->tlink = changed_syms;
2417 st = gfc_new_symtree (&ns->sym_root, name);
2424 /* Make sure the existing symbol is OK. Ambiguous
2425 generic interfaces are permitted, as long as the
2426 specific interfaces are different. */
2427 if (st->ambiguous && !st->n.sym->attr.generic)
2429 ambiguous_symbol (name, st);
2435 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2437 && ns->proc_name->attr.if_source == IFSRC_IFBODY
2438 && (ns->has_import_set || p->attr.imported)))
2440 /* Symbol is from another namespace. */
2441 gfc_error ("Symbol '%s' at %C has already been host associated",
2448 /* Copy in case this symbol is changed. */
2449 save_symbol_data (p);
2458 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2463 i = gfc_get_sym_tree (name, ns, &st);
2468 *result = st->n.sym;
2475 /* Subroutine that searches for a symbol, creating it if it doesn't
2476 exist, but tries to host-associate the symbol if possible. */
2479 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2484 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2487 save_symbol_data (st->n.sym);
2492 if (gfc_current_ns->parent != NULL)
2494 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2505 return gfc_get_sym_tree (name, gfc_current_ns, result);
2510 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2515 i = gfc_get_ha_sym_tree (name, &st);
2518 *result = st->n.sym;
2525 /* Return true if both symbols could refer to the same data object. Does
2526 not take account of aliasing due to equivalence statements. */
2529 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2531 /* Aliasing isn't possible if the symbols have different base types. */
2532 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2535 /* Pointers can point to other pointers, target objects and allocatable
2536 objects. Two allocatable objects cannot share the same storage. */
2537 if (lsym->attr.pointer
2538 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2540 if (lsym->attr.target && rsym->attr.pointer)
2542 if (lsym->attr.allocatable && rsym->attr.pointer)
2549 /* Undoes all the changes made to symbols in the current statement.
2550 This subroutine is made simpler due to the fact that attributes are
2551 never removed once added. */
2554 gfc_undo_symbols (void)
2556 gfc_symbol *p, *q, *old;
2558 for (p = changed_syms; p; p = q)
2564 /* Symbol was new. */
2565 delete_symtree (&p->ns->sym_root, p->name);
2569 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2571 gfc_free_symbol (p);
2575 /* Restore previous state of symbol. Just copy simple stuff. */
2577 old = p->old_symbol;
2579 p->ts.type = old->ts.type;
2580 p->ts.kind = old->ts.kind;
2582 p->attr = old->attr;
2584 if (p->value != old->value)
2586 gfc_free_expr (old->value);
2590 if (p->as != old->as)
2593 gfc_free_array_spec (p->as);
2597 p->generic = old->generic;
2598 p->component_access = old->component_access;
2600 if (p->namelist != NULL && old->namelist == NULL)
2602 gfc_free_namelist (p->namelist);
2607 if (p->namelist_tail != old->namelist_tail)
2609 gfc_free_namelist (old->namelist_tail);
2610 old->namelist_tail->next = NULL;
2614 p->namelist_tail = old->namelist_tail;
2616 if (p->formal != old->formal)
2618 gfc_free_formal_arglist (p->formal);
2619 p->formal = old->formal;
2622 gfc_free (p->old_symbol);
2623 p->old_symbol = NULL;
2627 changed_syms = NULL;
2631 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2632 components of old_symbol that might need deallocation are the "allocatables"
2633 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2634 namelist_tail. In case these differ between old_symbol and sym, it's just
2635 because sym->namelist has gotten a few more items. */
2638 free_old_symbol (gfc_symbol *sym)
2641 if (sym->old_symbol == NULL)
2644 if (sym->old_symbol->as != sym->as)
2645 gfc_free_array_spec (sym->old_symbol->as);
2647 if (sym->old_symbol->value != sym->value)
2648 gfc_free_expr (sym->old_symbol->value);
2650 if (sym->old_symbol->formal != sym->formal)
2651 gfc_free_formal_arglist (sym->old_symbol->formal);
2653 gfc_free (sym->old_symbol);
2654 sym->old_symbol = NULL;
2658 /* Makes the changes made in the current statement permanent-- gets
2659 rid of undo information. */
2662 gfc_commit_symbols (void)
2666 for (p = changed_syms; p; p = q)
2672 free_old_symbol (p);
2674 changed_syms = NULL;
2678 /* Makes the changes made in one symbol permanent -- gets rid of undo
2682 gfc_commit_symbol (gfc_symbol *sym)
2686 if (changed_syms == sym)
2687 changed_syms = sym->tlink;
2690 for (p = changed_syms; p; p = p->tlink)
2691 if (p->tlink == sym)
2693 p->tlink = sym->tlink;
2702 free_old_symbol (sym);
2706 /* Recursive function that deletes an entire tree and all the common
2707 head structures it points to. */
2710 free_common_tree (gfc_symtree * common_tree)
2712 if (common_tree == NULL)
2715 free_common_tree (common_tree->left);
2716 free_common_tree (common_tree->right);
2718 gfc_free (common_tree);
2722 /* Recursive function that deletes an entire tree and all the user
2723 operator nodes that it contains. */
2726 free_uop_tree (gfc_symtree *uop_tree)
2729 if (uop_tree == NULL)
2732 free_uop_tree (uop_tree->left);
2733 free_uop_tree (uop_tree->right);
2735 gfc_free_interface (uop_tree->n.uop->operator);
2737 gfc_free (uop_tree->n.uop);
2738 gfc_free (uop_tree);
2742 /* Recursive function that deletes an entire tree and all the symbols
2743 that it contains. */
2746 free_sym_tree (gfc_symtree *sym_tree)
2751 if (sym_tree == NULL)
2754 free_sym_tree (sym_tree->left);
2755 free_sym_tree (sym_tree->right);
2757 sym = sym_tree->n.sym;
2761 gfc_internal_error ("free_sym_tree(): Negative refs");
2763 if (sym->formal_ns != NULL && sym->refs == 1)
2765 /* As formal_ns contains a reference to sym, delete formal_ns just
2766 before the deletion of sym. */
2767 ns = sym->formal_ns;
2768 sym->formal_ns = NULL;
2769 gfc_free_namespace (ns);
2771 else if (sym->refs == 0)
2773 /* Go ahead and delete the symbol. */
2774 gfc_free_symbol (sym);
2777 gfc_free (sym_tree);
2781 /* Free the derived type list. */
2784 gfc_free_dt_list (void)
2786 gfc_dt_list *dt, *n;
2788 for (dt = gfc_derived_types; dt; dt = n)
2794 gfc_derived_types = NULL;
2798 /* Free the gfc_equiv_info's. */
2801 gfc_free_equiv_infos (gfc_equiv_info *s)
2805 gfc_free_equiv_infos (s->next);
2810 /* Free the gfc_equiv_lists. */
2813 gfc_free_equiv_lists (gfc_equiv_list *l)
2817 gfc_free_equiv_lists (l->next);
2818 gfc_free_equiv_infos (l->equiv);
2823 /* Free a namespace structure and everything below it. Interface
2824 lists associated with intrinsic operators are not freed. These are
2825 taken care of when a specific name is freed. */
2828 gfc_free_namespace (gfc_namespace *ns)
2830 gfc_charlen *cl, *cl2;
2831 gfc_namespace *p, *q;
2840 gcc_assert (ns->refs == 0);
2842 gfc_free_statements (ns->code);
2844 free_sym_tree (ns->sym_root);
2845 free_uop_tree (ns->uop_root);
2846 free_common_tree (ns->common_root);
2848 for (cl = ns->cl_list; cl; cl = cl2)
2851 gfc_free_expr (cl->length);
2855 free_st_labels (ns->st_labels);
2857 gfc_free_equiv (ns->equiv);
2858 gfc_free_equiv_lists (ns->equiv_lists);
2860 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
2861 gfc_free_interface (ns->operator[i]);
2863 gfc_free_data (ns->data);
2867 /* Recursively free any contained namespaces. */
2872 gfc_free_namespace (q);
2878 gfc_symbol_init_2 (void)
2881 gfc_current_ns = gfc_get_namespace (NULL, 0);
2886 gfc_symbol_done_2 (void)
2889 gfc_free_namespace (gfc_current_ns);
2890 gfc_current_ns = NULL;
2891 gfc_free_dt_list ();
2895 /* Clear mark bits from symbol nodes associated with a symtree node. */
2898 clear_sym_mark (gfc_symtree *st)
2901 st->n.sym->mark = 0;
2905 /* Recursively traverse the symtree nodes. */
2908 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
2914 gfc_traverse_symtree (st->left, func);
2915 gfc_traverse_symtree (st->right, func);
2920 /* Recursive namespace traversal function. */
2923 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
2929 if (st->n.sym->mark == 0)
2930 (*func) (st->n.sym);
2931 st->n.sym->mark = 1;
2933 traverse_ns (st->left, func);
2934 traverse_ns (st->right, func);
2938 /* Call a given function for all symbols in the namespace. We take
2939 care that each gfc_symbol node is called exactly once. */
2942 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
2945 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
2947 traverse_ns (ns->sym_root, func);
2951 /* Return TRUE when name is the name of an intrinsic type. */
2954 gfc_is_intrinsic_typename (const char *name)
2956 if (strcmp (name, "integer") == 0
2957 || strcmp (name, "real") == 0
2958 || strcmp (name, "character") == 0
2959 || strcmp (name, "logical") == 0
2960 || strcmp (name, "complex") == 0
2961 || strcmp (name, "doubleprecision") == 0
2962 || strcmp (name, "doublecomplex") == 0)
2969 /* Return TRUE if the symbol is an automatic variable. */
2972 gfc_is_var_automatic (gfc_symbol *sym)
2974 /* Pointer and allocatable variables are never automatic. */
2975 if (sym->attr.pointer || sym->attr.allocatable)
2977 /* Check for arrays with non-constant size. */
2978 if (sym->attr.dimension && sym->as
2979 && !gfc_is_compile_time_shape (sym->as))
2981 /* Check for non-constant length character variables. */
2982 if (sym->ts.type == BT_CHARACTER
2984 && !gfc_is_constant_expr (sym->ts.cl->length))
2989 /* Given a symbol, mark it as SAVEd if it is allowed. */
2992 save_symbol (gfc_symbol *sym)
2995 if (sym->attr.use_assoc)
2998 if (sym->attr.in_common
3000 || sym->attr.flavor != FL_VARIABLE)
3002 /* Automatic objects are not saved. */
3003 if (gfc_is_var_automatic (sym))
3005 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3009 /* Mark those symbols which can be SAVEd as such. */
3012 gfc_save_all (gfc_namespace *ns)
3015 gfc_traverse_ns (ns, save_symbol);
3020 /* Make sure that no changes to symbols are pending. */
3023 gfc_symbol_state(void) {
3025 if (changed_syms != NULL)
3026 gfc_internal_error("Symbol changes still pending!");
3031 /************** Global symbol handling ************/
3034 /* Search a tree for the global symbol. */
3037 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3046 c = strcmp (name, symbol->name);
3050 symbol = (c < 0) ? symbol->left : symbol->right;
3057 /* Compare two global symbols. Used for managing the BB tree. */
3060 gsym_compare (void *_s1, void *_s2)
3062 gfc_gsymbol *s1, *s2;
3064 s1 = (gfc_gsymbol *) _s1;
3065 s2 = (gfc_gsymbol *) _s2;
3066 return strcmp (s1->name, s2->name);
3070 /* Get a global symbol, creating it if it doesn't exist. */
3073 gfc_get_gsymbol (const char *name)
3077 s = gfc_find_gsymbol (gfc_gsym_root, name);
3081 s = gfc_getmem (sizeof (gfc_gsymbol));
3082 s->type = GSYM_UNKNOWN;
3083 s->name = gfc_get_string (name);
3085 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3092 get_iso_c_binding_dt (int sym_id)
3094 gfc_dt_list *dt_list;
3096 dt_list = gfc_derived_types;
3098 /* Loop through the derived types in the name list, searching for
3099 the desired symbol from iso_c_binding. Search the parent namespaces
3100 if necessary and requested to (parent_flag). */
3101 while (dt_list != NULL)
3103 if (dt_list->derived->from_intmod != INTMOD_NONE
3104 && dt_list->derived->intmod_sym_id == sym_id)
3105 return dt_list->derived;
3107 dt_list = dt_list->next;
3114 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3115 with C. This is necessary for any derived type that is BIND(C) and for
3116 derived types that are parameters to functions that are BIND(C). All
3117 fields of the derived type are required to be interoperable, and are tested
3118 for such. If an error occurs, the errors are reported here, allowing for
3119 multiple errors to be handled for a single derived type. */
3122 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3124 gfc_component *curr_comp = NULL;
3125 try is_c_interop = FAILURE;
3126 try retval = SUCCESS;
3128 if (derived_sym == NULL)
3129 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3130 "unexpectedly NULL");
3132 /* If we've already looked at this derived symbol, do not look at it again
3133 so we don't repeat warnings/errors. */
3134 if (derived_sym->ts.is_c_interop)
3137 /* The derived type must have the BIND attribute to be interoperable
3138 J3/04-007, Section 15.2.3. */
3139 if (derived_sym->attr.is_bind_c != 1)
3141 derived_sym->ts.is_c_interop = 0;
3142 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3143 "attribute to be C interoperable", derived_sym->name,
3144 &(derived_sym->declared_at));
3148 curr_comp = derived_sym->components;
3150 /* TODO: is this really an error? */
3151 if (curr_comp == NULL)
3153 gfc_error ("Derived type '%s' at %L is empty",
3154 derived_sym->name, &(derived_sym->declared_at));
3158 /* Initialize the derived type as being C interoperable.
3159 If we find an error in the components, this will be set false. */
3160 derived_sym->ts.is_c_interop = 1;
3162 /* Loop through the list of components to verify that the kind of
3163 each is a C interoperable type. */
3166 /* The components cannot be pointers (fortran sense).
3167 J3/04-007, Section 15.2.3, C1505. */
3168 if (curr_comp->pointer != 0)
3170 gfc_error ("Component '%s' at %L cannot have the "
3171 "POINTER attribute because it is a member "
3172 "of the BIND(C) derived type '%s' at %L",
3173 curr_comp->name, &(curr_comp->loc),
3174 derived_sym->name, &(derived_sym->declared_at));
3178 /* The components cannot be allocatable.
3179 J3/04-007, Section 15.2.3, C1505. */
3180 if (curr_comp->allocatable != 0)
3182 gfc_error ("Component '%s' at %L cannot have the "
3183 "ALLOCATABLE attribute because it is a member "
3184 "of the BIND(C) derived type '%s' at %L",
3185 curr_comp->name, &(curr_comp->loc),
3186 derived_sym->name, &(derived_sym->declared_at));
3190 /* BIND(C) derived types must have interoperable components. */
3191 if (curr_comp->ts.type == BT_DERIVED
3192 && curr_comp->ts.derived->ts.is_iso_c != 1
3193 && curr_comp->ts.derived != derived_sym)
3195 /* This should be allowed; the draft says a derived-type can not
3196 have type parameters if it is has the BIND attribute. Type
3197 parameters seem to be for making parameterized derived types.
3198 There's no need to verify the type if it is c_ptr/c_funptr. */
3199 retval = verify_bind_c_derived_type (curr_comp->ts.derived);
3203 /* Grab the typespec for the given component and test the kind. */
3204 is_c_interop = verify_c_interop (&(curr_comp->ts), curr_comp->name,
3207 if (is_c_interop != SUCCESS)
3209 /* Report warning and continue since not fatal. The
3210 draft does specify a constraint that requires all fields
3211 to interoperate, but if the user says real(4), etc., it
3212 may interoperate with *something* in C, but the compiler
3213 most likely won't know exactly what. Further, it may not
3214 interoperate with the same data type(s) in C if the user
3215 recompiles with different flags (e.g., -m32 and -m64 on
3216 x86_64 and using integer(4) to claim interop with a
3218 if (derived_sym->attr.is_bind_c == 1)
3219 /* If the derived type is bind(c), all fields must be
3221 gfc_warning ("Component '%s' in derived type '%s' at %L "
3222 "may not be C interoperable, even though "
3223 "derived type '%s' is BIND(C)",
3224 curr_comp->name, derived_sym->name,
3225 &(curr_comp->loc), derived_sym->name);
3227 /* If derived type is param to bind(c) routine, or to one
3228 of the iso_c_binding procs, it must be interoperable, so
3229 all fields must interop too. */
3230 gfc_warning ("Component '%s' in derived type '%s' at %L "
3231 "may not be C interoperable",
3232 curr_comp->name, derived_sym->name,
3237 curr_comp = curr_comp->next;
3238 } while (curr_comp != NULL);
3241 /* Make sure we don't have conflicts with the attributes. */
3242 if (derived_sym->attr.access == ACCESS_PRIVATE)
3244 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3245 "PRIVATE and BIND(C) attributes", derived_sym->name,
3246 &(derived_sym->declared_at));
3250 if (derived_sym->attr.sequence != 0)
3252 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3253 "attribute because it is BIND(C)", derived_sym->name,
3254 &(derived_sym->declared_at));
3258 /* Mark the derived type as not being C interoperable if we found an
3259 error. If there were only warnings, proceed with the assumption
3260 it's interoperable. */
3261 if (retval == FAILURE)
3262 derived_sym->ts.is_c_interop = 0;
3268 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3271 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3272 const char *module_name)
3274 gfc_symtree *tmp_symtree;
3275 gfc_symbol *tmp_sym;
3277 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3279 if (tmp_symtree != NULL)
3280 tmp_sym = tmp_symtree->n.sym;
3284 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3285 "create symbol for %s", ptr_name);
3288 /* Set up the symbol's important fields. Save attr required so we can
3289 initialize the ptr to NULL. */
3290 tmp_sym->attr.save = SAVE_EXPLICIT;
3291 tmp_sym->ts.is_c_interop = 1;
3292 tmp_sym->attr.is_c_interop = 1;
3293 tmp_sym->ts.is_iso_c = 1;
3294 tmp_sym->ts.type = BT_DERIVED;
3296 /* The c_ptr and c_funptr derived types will provide the
3297 definition for c_null_ptr and c_null_funptr, respectively. */
3298 if (ptr_id == ISOCBINDING_NULL_PTR)
3299 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3301 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3302 if (tmp_sym->ts.derived == NULL)
3304 /* This can occur if the user forgot to declare c_ptr or
3305 c_funptr and they're trying to use one of the procedures
3306 that has arg(s) of the missing type. In this case, a
3307 regular version of the thing should have been put in the
3309 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3310 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3311 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3312 ? "_gfortran_iso_c_binding_c_ptr"
3313 : "_gfortran_iso_c_binding_c_funptr"));
3315 tmp_sym->ts.derived =
3316 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3317 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3320 /* Module name is some mangled version of iso_c_binding. */
3321 tmp_sym->module = gfc_get_string (module_name);
3323 /* Say it's from the iso_c_binding module. */
3324 tmp_sym->attr.is_iso_c = 1;
3326 tmp_sym->attr.use_assoc = 1;
3327 tmp_sym->attr.is_bind_c = 1;
3328 /* Set the binding_label. */
3329 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3331 /* Set the c_address field of c_null_ptr and c_null_funptr to
3332 the value of NULL. */
3333 tmp_sym->value = gfc_get_expr ();
3334 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3335 tmp_sym->value->ts.type = BT_DERIVED;
3336 tmp_sym->value->ts.derived = tmp_sym->ts.derived;
3337 tmp_sym->value->value.constructor = gfc_get_constructor ();
3338 /* This line will initialize the c_null_ptr/c_null_funptr
3339 c_address field to NULL. */
3340 tmp_sym->value->value.constructor->expr = gfc_int_expr (0);
3341 /* Must declare c_null_ptr and c_null_funptr as having the
3342 PARAMETER attribute so they can be used in init expressions. */
3343 tmp_sym->attr.flavor = FL_PARAMETER;
3349 /* Add a formal argument, gfc_formal_arglist, to the
3350 end of the given list of arguments. Set the reference to the
3351 provided symbol, param_sym, in the argument. */
3354 add_formal_arg (gfc_formal_arglist **head,
3355 gfc_formal_arglist **tail,
3356 gfc_formal_arglist *formal_arg,
3357 gfc_symbol *param_sym)
3359 /* Put in list, either as first arg or at the tail (curr arg). */
3361 *head = *tail = formal_arg;
3364 (*tail)->next = formal_arg;
3365 (*tail) = formal_arg;
3368 (*tail)->sym = param_sym;
3369 (*tail)->next = NULL;
3375 /* Generates a symbol representing the CPTR argument to an
3376 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3377 CPTR and add it to the provided argument list. */
3380 gen_cptr_param (gfc_formal_arglist **head,
3381 gfc_formal_arglist **tail,
3382 const char *module_name,
3383 gfc_namespace *ns, const char *c_ptr_name,
3386 gfc_symbol *param_sym = NULL;
3387 gfc_symbol *c_ptr_sym = NULL;
3388 gfc_symtree *param_symtree = NULL;
3389 gfc_formal_arglist *formal_arg = NULL;
3390 const char *c_ptr_in;
3391 const char *c_ptr_type = NULL;
3393 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3394 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3396 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3398 if(c_ptr_name == NULL)
3399 c_ptr_in = "gfc_cptr__";
3401 c_ptr_in = c_ptr_name;
3402 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree);
3403 if (param_symtree != NULL)
3404 param_sym = param_symtree->n.sym;
3406 gfc_internal_error ("gen_cptr_param(): Unable to "
3407 "create symbol for %s", c_ptr_in);
3409 /* Set up the appropriate fields for the new c_ptr param sym. */
3411 param_sym->attr.flavor = FL_DERIVED;
3412 param_sym->ts.type = BT_DERIVED;
3413 param_sym->attr.intent = INTENT_IN;
3414 param_sym->attr.dummy = 1;
3416 /* This will pass the ptr to the iso_c routines as a (void *). */
3417 param_sym->attr.value = 1;
3418 param_sym->attr.use_assoc = 1;
3420 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3422 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3423 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3425 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3426 if (c_ptr_sym == NULL)
3428 /* This can happen if the user did not define c_ptr but they are
3429 trying to use one of the iso_c_binding functions that need it. */
3430 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3431 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3432 (const char *)c_ptr_type);
3434 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3435 (const char *)c_ptr_type);
3437 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3440 param_sym->ts.derived = c_ptr_sym;
3441 param_sym->module = gfc_get_string (module_name);
3443 /* Make new formal arg. */
3444 formal_arg = gfc_get_formal_arglist ();
3445 /* Add arg to list of formal args (the CPTR arg). */
3446 add_formal_arg (head, tail, formal_arg, param_sym);
3450 /* Generates a symbol representing the FPTR argument to an
3451 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3452 FPTR and add it to the provided argument list. */
3455 gen_fptr_param (gfc_formal_arglist **head,
3456 gfc_formal_arglist **tail,
3457 const char *module_name,
3458 gfc_namespace *ns, const char *f_ptr_name)
3460 gfc_symbol *param_sym = NULL;
3461 gfc_symtree *param_symtree = NULL;
3462 gfc_formal_arglist *formal_arg = NULL;
3463 const char *f_ptr_out = "gfc_fptr__";
3465 if (f_ptr_name != NULL)
3466 f_ptr_out = f_ptr_name;
3468 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree);
3469 if (param_symtree != NULL)
3470 param_sym = param_symtree->n.sym;
3472 gfc_internal_error ("generateFPtrParam(): Unable to "
3473 "create symbol for %s", f_ptr_out);
3475 /* Set up the necessary fields for the fptr output param sym. */
3477 param_sym->attr.pointer = 1;
3478 param_sym->attr.dummy = 1;
3479 param_sym->attr.use_assoc = 1;
3481 /* ISO C Binding type to allow any pointer type as actual param. */
3482 param_sym->ts.type = BT_VOID;
3483 param_sym->module = gfc_get_string (module_name);
3486 formal_arg = gfc_get_formal_arglist ();
3487 /* Add arg to list of formal args. */
3488 add_formal_arg (head, tail, formal_arg, param_sym);
3492 /* Generates a symbol representing the optional SHAPE argument for the
3493 iso_c_binding c_f_pointer() procedure. Also, create a
3494 gfc_formal_arglist for the SHAPE and add it to the provided
3498 gen_shape_param (gfc_formal_arglist **head,
3499 gfc_formal_arglist **tail,
3500 const char *module_name,
3501 gfc_namespace *ns, const char *shape_param_name)
3503 gfc_symbol *param_sym = NULL;
3504 gfc_symtree *param_symtree = NULL;
3505 gfc_formal_arglist *formal_arg = NULL;
3506 const char *shape_param = "gfc_shape_array__";
3509 if (shape_param_name != NULL)
3510 shape_param = shape_param_name;
3512 gfc_get_sym_tree (shape_param, ns, ¶m_symtree);
3513 if (param_symtree != NULL)
3514 param_sym = param_symtree->n.sym;
3516 gfc_internal_error ("generateShapeParam(): Unable to "
3517 "create symbol for %s", shape_param);
3519 /* Set up the necessary fields for the shape input param sym. */
3521 param_sym->attr.dummy = 1;
3522 param_sym->attr.use_assoc = 1;
3524 /* Integer array, rank 1, describing the shape of the object. Make it's
3525 type BT_VOID initially so we can accept any type/kind combination of
3526 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3527 of BT_INTEGER type. */
3528 param_sym->ts.type = BT_VOID;
3530 /* Initialize the kind to default integer. However, it will be overridden
3531 during resolution to match the kind of the SHAPE parameter given as
3532 the actual argument (to allow for any valid integer kind). */
3533 param_sym->ts.kind = gfc_default_integer_kind;
3534 param_sym->as = gfc_get_array_spec ();
3536 /* Clear out the dimension info for the array. */
3537 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3539 param_sym->as->lower[i] = NULL;
3540 param_sym->as->upper[i] = NULL;
3542 param_sym->as->rank = 1;
3543 param_sym->as->lower[0] = gfc_int_expr (1);
3545 /* The extent is unknown until we get it. The length give us
3546 the rank the incoming pointer. */
3547 param_sym->as->type = AS_ASSUMED_SHAPE;
3549 /* The arg is also optional; it is required iff the second arg
3550 (fptr) is to an array, otherwise, it's ignored. */
3551 param_sym->attr.optional = 1;
3552 param_sym->attr.intent = INTENT_IN;
3553 param_sym->attr.dimension = 1;
3554 param_sym->module = gfc_get_string (module_name);
3557 formal_arg = gfc_get_formal_arglist ();
3558 /* Add arg to list of formal args. */
3559 add_formal_arg (head, tail, formal_arg, param_sym);
3562 /* Add a procedure interface to the given symbol (i.e., store a
3563 reference to the list of formal arguments). */
3566 add_proc_interface (gfc_symbol *sym, ifsrc source,
3567 gfc_formal_arglist *formal)
3570 sym->formal = formal;
3571 sym->attr.if_source = source;
3574 /* Copy the formal args from an existing symbol, src, into a new
3575 symbol, dest. New formal args are created, and the description of
3576 each arg is set according to the existing ones. This function is
3577 used when creating procedure declaration variables from a procedure
3578 declaration statement (see match_proc_decl()) to create the formal
3579 args based on the args of a given named interface. */
3581 void copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
3583 gfc_formal_arglist *head = NULL;
3584 gfc_formal_arglist *tail = NULL;
3585 gfc_formal_arglist *formal_arg = NULL;
3586 gfc_formal_arglist *curr_arg = NULL;
3587 gfc_formal_arglist *formal_prev = NULL;
3588 /* Save current namespace so we can change it for formal args. */
3589 gfc_namespace *parent_ns = gfc_current_ns;
3591 /* Create a new namespace, which will be the formal ns (namespace
3592 of the formal args). */
3593 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3594 gfc_current_ns->proc_name = dest;
3596 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3598 formal_arg = gfc_get_formal_arglist ();
3599 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
3601 /* May need to copy more info for the symbol. */
3602 formal_arg->sym->attr = curr_arg->sym->attr;
3603 formal_arg->sym->ts = curr_arg->sym->ts;
3605 /* If this isn't the first arg, set up the next ptr. For the
3606 last arg built, the formal_arg->next will never get set to
3607 anything other than NULL. */
3608 if (formal_prev != NULL)
3609 formal_prev->next = formal_arg;
3611 formal_arg->next = NULL;
3613 formal_prev = formal_arg;
3615 /* Add arg to list of formal args. */
3616 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3619 /* Add the interface to the symbol. */
3620 add_proc_interface (dest, IFSRC_DECL, head);
3622 /* Store the formal namespace information. */
3623 if (dest->formal != NULL)
3624 /* The current ns should be that for the dest proc. */
3625 dest->formal_ns = gfc_current_ns;
3626 /* Restore the current namespace to what it was on entry. */
3627 gfc_current_ns = parent_ns;
3630 /* Builds the parameter list for the iso_c_binding procedure
3631 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3632 generic version of either the c_f_pointer or c_f_procpointer
3633 functions. The new_proc_sym represents a "resolved" version of the
3634 symbol. The functions are resolved to match the types of their
3635 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3636 something similar to c_f_pointer_i4 if the type of data object fptr
3637 pointed to was a default integer. The actual name of the resolved
3638 procedure symbol is further mangled with the module name, etc., but
3639 the idea holds true. */
3642 build_formal_args (gfc_symbol *new_proc_sym,
3643 gfc_symbol *old_sym, int add_optional_arg)
3645 gfc_formal_arglist *head = NULL, *tail = NULL;
3646 gfc_namespace *parent_ns = NULL;
3648 parent_ns = gfc_current_ns;
3649 /* Create a new namespace, which will be the formal ns (namespace
3650 of the formal args). */
3651 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
3652 gfc_current_ns->proc_name = new_proc_sym;
3654 /* Generate the params. */
3655 if ((old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
3656 (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
3658 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3659 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3660 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3661 gfc_current_ns, "fptr");
3663 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3664 if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3666 gen_shape_param (&head, &tail,
3667 (const char *) new_proc_sym->module,
3668 gfc_current_ns, "shape");
3671 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3673 /* c_associated has one required arg and one optional; both
3675 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3676 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
3677 if (add_optional_arg)
3679 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3680 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
3681 /* The last param is optional so mark it as such. */
3682 tail->sym->attr.optional = 1;
3686 /* Add the interface (store formal args to new_proc_sym). */
3687 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
3689 /* Set up the formal_ns pointer to the one created for the
3690 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3691 new_proc_sym->formal_ns = gfc_current_ns;
3693 gfc_current_ns = parent_ns;
3697 /* Generate the given set of C interoperable kind objects, or all
3698 interoperable kinds. This function will only be given kind objects
3699 for valid iso_c_binding defined types because this is verified when
3700 the 'use' statement is parsed. If the user gives an 'only' clause,
3701 the specific kinds are looked up; if they don't exist, an error is
3702 reported. If the user does not give an 'only' clause, all
3703 iso_c_binding symbols are generated. If a list of specific kinds
3704 is given, it must have a NULL in the first empty spot to mark the
3709 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
3710 const char *local_name)
3712 const char *const name = (local_name && local_name[0]) ? local_name
3713 : c_interop_kinds_table[s].name;
3714 gfc_symtree *tmp_symtree = NULL;
3715 gfc_symbol *tmp_sym = NULL;
3716 gfc_dt_list **dt_list_ptr = NULL;
3717 gfc_component *tmp_comp = NULL;
3718 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
3721 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
3723 /* Already exists in this scope so don't re-add it.
3724 TODO: we should probably check that it's really the same symbol. */
3725 if (tmp_symtree != NULL)
3728 /* Create the sym tree in the current ns. */
3729 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
3731 tmp_sym = tmp_symtree->n.sym;
3733 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3736 /* Say what module this symbol belongs to. */
3737 tmp_sym->module = gfc_get_string (mod_name);
3738 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
3739 tmp_sym->intmod_sym_id = s;
3744 #define NAMED_INTCST(a,b,c) case a :
3745 #define NAMED_REALCST(a,b,c) case a :
3746 #define NAMED_CMPXCST(a,b,c) case a :
3747 #define NAMED_LOGCST(a,b,c) case a :
3748 #define NAMED_CHARKNDCST(a,b,c) case a :
3749 #include "iso-c-binding.def"
3751 tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
3753 /* Initialize an integer constant expression node. */
3754 tmp_sym->attr.flavor = FL_PARAMETER;
3755 tmp_sym->ts.type = BT_INTEGER;
3756 tmp_sym->ts.kind = gfc_default_integer_kind;
3758 /* Mark this type as a C interoperable one. */
3759 tmp_sym->ts.is_c_interop = 1;
3760 tmp_sym->ts.is_iso_c = 1;
3761 tmp_sym->value->ts.is_c_interop = 1;
3762 tmp_sym->value->ts.is_iso_c = 1;
3763 tmp_sym->attr.is_c_interop = 1;
3765 /* Tell what f90 type this c interop kind is valid. */
3766 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
3768 /* Say it's from the iso_c_binding module. */
3769 tmp_sym->attr.is_iso_c = 1;
3771 /* Make it use associated. */
3772 tmp_sym->attr.use_assoc = 1;
3776 #define NAMED_CHARCST(a,b,c) case a :
3777 #include "iso-c-binding.def"
3779 /* Initialize an integer constant expression node for the
3780 length of the character. */
3781 tmp_sym->value = gfc_get_expr ();
3782 tmp_sym->value->expr_type = EXPR_CONSTANT;
3783 tmp_sym->value->ts.type = BT_CHARACTER;
3784 tmp_sym->value->ts.kind = gfc_default_character_kind;
3785 tmp_sym->value->where = gfc_current_locus;
3786 tmp_sym->value->ts.is_c_interop = 1;
3787 tmp_sym->value->ts.is_iso_c = 1;
3788 tmp_sym->value->value.character.length = 1;
3789 tmp_sym->value->value.character.string = gfc_getmem (2);
3790 tmp_sym->value->value.character.string[0]
3791 = (char) c_interop_kinds_table[s].value;
3792 tmp_sym->value->value.character.string[1] = '\0';
3794 /* May not need this in both attr and ts, but do need in
3795 attr for writing module file. */
3796 tmp_sym->attr.is_c_interop = 1;
3798 tmp_sym->attr.flavor = FL_PARAMETER;
3799 tmp_sym->ts.type = BT_CHARACTER;
3801 /* Need to set it to the C_CHAR kind. */
3802 tmp_sym->ts.kind = gfc_default_character_kind;
3804 /* Mark this type as a C interoperable one. */
3805 tmp_sym->ts.is_c_interop = 1;
3806 tmp_sym->ts.is_iso_c = 1;
3808 /* Tell what f90 type this c interop kind is valid. */
3809 tmp_sym->ts.f90_type = BT_CHARACTER;
3811 /* Say it's from the iso_c_binding module. */
3812 tmp_sym->attr.is_iso_c = 1;
3814 /* Make it use associated. */
3815 tmp_sym->attr.use_assoc = 1;
3818 case ISOCBINDING_PTR:
3819 case ISOCBINDING_FUNPTR:
3821 /* Initialize an integer constant expression node. */
3822 tmp_sym->attr.flavor = FL_DERIVED;
3823 tmp_sym->ts.is_c_interop = 1;
3824 tmp_sym->attr.is_c_interop = 1;
3825 tmp_sym->attr.is_iso_c = 1;
3826 tmp_sym->ts.is_iso_c = 1;
3827 tmp_sym->ts.type = BT_DERIVED;
3829 /* A derived type must have the bind attribute to be
3830 interoperable (J3/04-007, Section 15.2.3), even though
3831 the binding label is not used. */
3832 tmp_sym->attr.is_bind_c = 1;
3834 tmp_sym->attr.referenced = 1;
3836 tmp_sym->ts.derived = tmp_sym;
3838 /* Add the symbol created for the derived type to the current ns. */
3839 dt_list_ptr = &(gfc_derived_types);
3840 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
3841 dt_list_ptr = &((*dt_list_ptr)->next);
3843 /* There is already at least one derived type in the list, so append
3844 the one we're currently building for c_ptr or c_funptr. */
3845 if (*dt_list_ptr != NULL)
3846 dt_list_ptr = &((*dt_list_ptr)->next);
3847 (*dt_list_ptr) = gfc_get_dt_list ();
3848 (*dt_list_ptr)->derived = tmp_sym;
3849 (*dt_list_ptr)->next = NULL;
3851 /* Set up the component of the derived type, which will be
3852 an integer with kind equal to c_ptr_size. Mangle the name of
3853 the field for the c_address to prevent the curious user from
3854 trying to access it from Fortran. */
3855 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
3856 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
3857 if (tmp_comp == NULL)
3858 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3859 "create component for c_address");
3861 tmp_comp->ts.type = BT_INTEGER;
3863 /* Set this because the module will need to read/write this field. */
3864 tmp_comp->ts.f90_type = BT_INTEGER;
3866 /* The kinds for c_ptr and c_funptr are the same. */
3867 index = get_c_kind ("c_ptr", c_interop_kinds_table);
3868 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
3870 tmp_comp->pointer = 0;
3871 tmp_comp->dimension = 0;
3873 /* Mark the component as C interoperable. */
3874 tmp_comp->ts.is_c_interop = 1;
3876 /* Make it use associated (iso_c_binding module). */
3877 tmp_sym->attr.use_assoc = 1;
3880 case ISOCBINDING_NULL_PTR:
3881 case ISOCBINDING_NULL_FUNPTR:
3882 gen_special_c_interop_ptr (s, name, mod_name);
3885 case ISOCBINDING_F_POINTER:
3886 case ISOCBINDING_ASSOCIATED:
3887 case ISOCBINDING_LOC:
3888 case ISOCBINDING_FUNLOC:
3889 case ISOCBINDING_F_PROCPOINTER:
3891 tmp_sym->attr.proc = PROC_MODULE;
3893 /* Use the procedure's name as it is in the iso_c_binding module for
3894 setting the binding label in case the user renamed the symbol. */
3895 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
3896 c_interop_kinds_table[s].name);
3897 tmp_sym->attr.is_iso_c = 1;
3898 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
3899 tmp_sym->attr.subroutine = 1;
3902 /* TODO! This needs to be finished more for the expr of the
3903 function or something!
3904 This may not need to be here, because trying to do c_loc
3906 if (s == ISOCBINDING_ASSOCIATED)
3908 tmp_sym->attr.function = 1;
3909 tmp_sym->ts.type = BT_LOGICAL;
3910 tmp_sym->ts.kind = gfc_default_logical_kind;
3911 tmp_sym->result = tmp_sym;
3915 /* Here, we're taking the simple approach. We're defining
3916 c_loc as an external identifier so the compiler will put
3917 what we expect on the stack for the address we want the
3919 tmp_sym->ts.type = BT_DERIVED;
3920 if (s == ISOCBINDING_LOC)
3921 tmp_sym->ts.derived =
3922 get_iso_c_binding_dt (ISOCBINDING_PTR);
3924 tmp_sym->ts.derived =
3925 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3927 if (tmp_sym->ts.derived == NULL)
3929 /* Create the necessary derived type so we can continue
3930 processing the file. */
3931 generate_isocbinding_symbol
3932 (mod_name, s == ISOCBINDING_FUNLOC
3933 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
3934 (const char *)(s == ISOCBINDING_FUNLOC
3935 ? "_gfortran_iso_c_binding_c_funptr"
3936 : "_gfortran_iso_c_binding_c_ptr"));
3937 tmp_sym->ts.derived =
3938 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
3939 ? ISOCBINDING_FUNPTR
3943 /* The function result is itself (no result clause). */
3944 tmp_sym->result = tmp_sym;
3945 tmp_sym->attr.external = 1;
3946 tmp_sym->attr.use_assoc = 0;
3947 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
3948 tmp_sym->attr.proc = PROC_UNKNOWN;
3952 tmp_sym->attr.flavor = FL_PROCEDURE;
3953 tmp_sym->attr.contained = 0;
3955 /* Try using this builder routine, with the new and old symbols
3956 both being the generic iso_c proc sym being created. This
3957 will create the formal args (and the new namespace for them).
3958 Don't build an arg list for c_loc because we're going to treat
3959 c_loc as an external procedure. */
3960 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
3961 /* The 1 says to add any optional args, if applicable. */
3962 build_formal_args (tmp_sym, tmp_sym, 1);
3964 /* Set this after setting up the symbol, to prevent error messages. */
3965 tmp_sym->attr.use_assoc = 1;
3967 /* This symbol will not be referenced directly. It will be
3968 resolved to the implementation for the given f90 kind. */
3969 tmp_sym->attr.referenced = 0;
3979 /* Creates a new symbol based off of an old iso_c symbol, with a new
3980 binding label. This function can be used to create a new,
3981 resolved, version of a procedure symbol for c_f_pointer or
3982 c_f_procpointer that is based on the generic symbols. A new
3983 parameter list is created for the new symbol using
3984 build_formal_args(). The add_optional_flag specifies whether the
3985 to add the optional SHAPE argument. The new symbol is
3989 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
3990 char *new_binding_label, int add_optional_arg)
3992 gfc_symtree *new_symtree = NULL;
3994 /* See if we have a symbol by that name already available, looking
3995 through any parent namespaces. */
3996 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
3997 if (new_symtree != NULL)
3998 /* Return the existing symbol. */
3999 return new_symtree->n.sym;
4001 /* Create the symtree/symbol, with attempted host association. */
4002 gfc_get_ha_sym_tree (new_name, &new_symtree);
4003 if (new_symtree == NULL)
4004 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4005 "symtree for '%s'", new_name);
4007 /* Now fill in the fields of the resolved symbol with the old sym. */
4008 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4009 new_symtree->n.sym->attr = old_sym->attr;
4010 new_symtree->n.sym->ts = old_sym->ts;
4011 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4012 /* Build the formal arg list. */
4013 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4015 gfc_commit_symbol (new_symtree->n.sym);
4017 return new_symtree->n.sym;