1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
31 /* Strings for all symbol attributes. We use these for dumping the
32 parse tree, in error messages, and also when reading and writing
35 const mstring flavors[] =
37 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
38 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
39 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
40 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
41 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
45 const mstring procedures[] =
47 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
48 minit ("MODULE-PROC", PROC_MODULE),
49 minit ("INTERNAL-PROC", PROC_INTERNAL),
50 minit ("DUMMY-PROC", PROC_DUMMY),
51 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
52 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
53 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
57 const mstring intents[] =
59 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
60 minit ("IN", INTENT_IN),
61 minit ("OUT", INTENT_OUT),
62 minit ("INOUT", INTENT_INOUT),
66 const mstring access_types[] =
68 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
69 minit ("PUBLIC", ACCESS_PUBLIC),
70 minit ("PRIVATE", ACCESS_PRIVATE),
74 const mstring ifsrc_types[] =
76 minit ("UNKNOWN", IFSRC_UNKNOWN),
77 minit ("DECL", IFSRC_DECL),
78 minit ("BODY", IFSRC_IFBODY)
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;
95 gfc_namespace *gfc_global_ns_list;
97 gfc_gsymbol *gfc_gsym_root = NULL;
99 static gfc_symbol *changed_syms = NULL;
101 gfc_dt_list *gfc_derived_types;
104 /* List of tentative typebound-procedures. */
106 typedef struct tentative_tbp
108 gfc_typebound_proc *proc;
109 struct tentative_tbp *next;
113 static tentative_tbp *tentative_tbp_list = NULL;
116 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
118 /* The following static variable indicates whether a particular element has
119 been explicitly set or not. */
121 static int new_flag[GFC_LETTERS];
124 /* Handle a correctly parsed IMPLICIT NONE. */
127 gfc_set_implicit_none (void)
131 if (gfc_current_ns->seen_implicit_none)
133 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
137 gfc_current_ns->seen_implicit_none = 1;
139 for (i = 0; i < GFC_LETTERS; i++)
141 gfc_clear_ts (&gfc_current_ns->default_type[i]);
142 gfc_current_ns->set_flag[i] = 1;
147 /* Reset the implicit range flags. */
150 gfc_clear_new_implicit (void)
154 for (i = 0; i < GFC_LETTERS; i++)
159 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
162 gfc_add_new_implicit_range (int c1, int c2)
169 for (i = c1; i <= c2; i++)
173 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
185 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
186 the new implicit types back into the existing types will work. */
189 gfc_merge_new_implicit (gfc_typespec *ts)
193 if (gfc_current_ns->seen_implicit_none)
195 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
199 for (i = 0; i < GFC_LETTERS; i++)
203 if (gfc_current_ns->set_flag[i])
205 gfc_error ("Letter %c already has an IMPLICIT type at %C",
210 gfc_current_ns->default_type[i] = *ts;
211 gfc_current_ns->implicit_loc[i] = gfc_current_locus;
212 gfc_current_ns->set_flag[i] = 1;
219 /* Given a symbol, return a pointer to the typespec for its default type. */
222 gfc_get_default_type (const char *name, gfc_namespace *ns)
228 if (gfc_option.flag_allow_leading_underscore && letter == '_')
229 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
230 "gfortran developers, and should not be used for "
231 "implicitly typed variables");
233 if (letter < 'a' || letter > 'z')
234 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
239 return &ns->default_type[letter - 'a'];
243 /* Given a pointer to a symbol, set its type according to the first
244 letter of its name. Fails if the letter in question has no default
248 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
252 if (sym->ts.type != BT_UNKNOWN)
253 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
255 ts = gfc_get_default_type (sym->name, ns);
257 if (ts->type == BT_UNKNOWN)
259 if (error_flag && !sym->attr.untyped)
261 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
262 sym->name, &sym->declared_at);
263 sym->attr.untyped = 1; /* Ensure we only give an error once. */
270 sym->attr.implicit_type = 1;
274 sym->ts.cl = gfc_get_charlen ();
275 *sym->ts.cl = *ts->cl;
278 if (sym->attr.is_bind_c == 1)
280 /* BIND(C) variables should not be implicitly declared. */
281 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
282 "not be C interoperable", sym->name, &sym->declared_at);
283 sym->ts.f90_type = sym->ts.type;
286 if (sym->attr.dummy != 0)
288 if (sym->ns->proc_name != NULL
289 && (sym->ns->proc_name->attr.subroutine != 0
290 || sym->ns->proc_name->attr.function != 0)
291 && sym->ns->proc_name->attr.is_bind_c != 0)
293 /* Dummy args to a BIND(C) routine may not be interoperable if
294 they are implicitly typed. */
295 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
296 "be C interoperable but it is a dummy argument to "
297 "the BIND(C) procedure '%s' at %L", sym->name,
298 &(sym->declared_at), sym->ns->proc_name->name,
299 &(sym->ns->proc_name->declared_at));
300 sym->ts.f90_type = sym->ts.type;
308 /* This function is called from parse.c(parse_progunit) to check the
309 type of the function is not implicitly typed in the host namespace
310 and to implicitly type the function result, if necessary. */
313 gfc_check_function_type (gfc_namespace *ns)
315 gfc_symbol *proc = ns->proc_name;
317 if (!proc->attr.contained || proc->result->attr.implicit_type)
320 if (proc->result->ts.type == BT_UNKNOWN)
322 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
325 if (proc->result != proc)
327 proc->ts = proc->result->ts;
328 proc->as = gfc_copy_array_spec (proc->result->as);
329 proc->attr.dimension = proc->result->attr.dimension;
330 proc->attr.pointer = proc->result->attr.pointer;
331 proc->attr.allocatable = proc->result->attr.allocatable;
334 else if (!proc->result->attr.proc_pointer)
336 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
337 proc->result->name, &proc->result->declared_at);
338 proc->result->attr.untyped = 1;
344 /******************** Symbol attribute stuff *********************/
346 /* This is a generic conflict-checker. We do this to avoid having a
347 single conflict in two places. */
349 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
350 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
351 #define conf_std(a, b, std) if (attr->a && attr->b)\
360 check_conflict (symbol_attribute *attr, const char *name, locus *where)
362 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
363 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
364 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
365 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
366 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
367 *privat = "PRIVATE", *recursive = "RECURSIVE",
368 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
369 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
370 *function = "FUNCTION", *subroutine = "SUBROUTINE",
371 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
372 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
373 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
374 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
375 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
376 static const char *threadprivate = "THREADPRIVATE";
382 where = &gfc_current_locus;
384 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
388 standard = GFC_STD_F2003;
392 /* Check for attributes not allowed in a BLOCK DATA. */
393 if (gfc_current_state () == COMP_BLOCK_DATA)
397 if (attr->in_namelist)
399 if (attr->allocatable)
405 if (attr->access == ACCESS_PRIVATE)
407 if (attr->access == ACCESS_PUBLIC)
409 if (attr->intent != INTENT_UNKNOWN)
415 ("%s attribute not allowed in BLOCK DATA program unit at %L",
421 if (attr->save == SAVE_EXPLICIT)
424 conf (in_common, save);
427 switch (attr->flavor)
435 a1 = gfc_code2string (flavors, attr->flavor);
440 /* Conflicts between SAVE and PROCEDURE will be checked at
441 resolution stage, see "resolve_fl_procedure". */
450 conf (dummy, intrinsic);
451 conf (dummy, threadprivate);
452 conf (pointer, target);
453 conf (pointer, intrinsic);
454 conf (pointer, elemental);
455 conf (allocatable, elemental);
457 conf (target, external);
458 conf (target, intrinsic);
460 if (!attr->if_source)
461 conf (external, dimension); /* See Fortran 95's R504. */
463 conf (external, intrinsic);
464 conf (entry, intrinsic);
466 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
467 conf (external, subroutine);
469 if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
470 "Fortran 2003: Procedure pointer at %C") == FAILURE)
473 conf (allocatable, pointer);
474 conf_std (allocatable, dummy, GFC_STD_F2003);
475 conf_std (allocatable, function, GFC_STD_F2003);
476 conf_std (allocatable, result, GFC_STD_F2003);
477 conf (elemental, recursive);
479 conf (in_common, dummy);
480 conf (in_common, allocatable);
481 conf (in_common, result);
483 conf (dummy, result);
485 conf (in_equivalence, use_assoc);
486 conf (in_equivalence, dummy);
487 conf (in_equivalence, target);
488 conf (in_equivalence, pointer);
489 conf (in_equivalence, function);
490 conf (in_equivalence, result);
491 conf (in_equivalence, entry);
492 conf (in_equivalence, allocatable);
493 conf (in_equivalence, threadprivate);
495 conf (in_namelist, pointer);
496 conf (in_namelist, allocatable);
498 conf (entry, result);
500 conf (function, subroutine);
502 if (!function && !subroutine)
503 conf (is_bind_c, dummy);
505 conf (is_bind_c, cray_pointer);
506 conf (is_bind_c, cray_pointee);
507 conf (is_bind_c, allocatable);
508 conf (is_bind_c, elemental);
510 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
511 Parameter conflict caught below. Also, value cannot be specified
512 for a dummy procedure. */
514 /* Cray pointer/pointee conflicts. */
515 conf (cray_pointer, cray_pointee);
516 conf (cray_pointer, dimension);
517 conf (cray_pointer, pointer);
518 conf (cray_pointer, target);
519 conf (cray_pointer, allocatable);
520 conf (cray_pointer, external);
521 conf (cray_pointer, intrinsic);
522 conf (cray_pointer, in_namelist);
523 conf (cray_pointer, function);
524 conf (cray_pointer, subroutine);
525 conf (cray_pointer, entry);
527 conf (cray_pointee, allocatable);
528 conf (cray_pointee, intent);
529 conf (cray_pointee, optional);
530 conf (cray_pointee, dummy);
531 conf (cray_pointee, target);
532 conf (cray_pointee, intrinsic);
533 conf (cray_pointee, pointer);
534 conf (cray_pointee, entry);
535 conf (cray_pointee, in_common);
536 conf (cray_pointee, in_equivalence);
537 conf (cray_pointee, threadprivate);
540 conf (data, function);
542 conf (data, allocatable);
543 conf (data, use_assoc);
545 conf (value, pointer)
546 conf (value, allocatable)
547 conf (value, subroutine)
548 conf (value, function)
549 conf (value, volatile_)
550 conf (value, dimension)
551 conf (value, external)
554 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
557 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
561 conf (is_protected, intrinsic)
562 conf (is_protected, external)
563 conf (is_protected, in_common)
565 conf (volatile_, intrinsic)
566 conf (volatile_, external)
568 if (attr->volatile_ && attr->intent == INTENT_IN)
575 conf (procedure, allocatable)
576 conf (procedure, dimension)
577 conf (procedure, intrinsic)
578 conf (procedure, is_protected)
579 conf (procedure, target)
580 conf (procedure, value)
581 conf (procedure, volatile_)
582 conf (procedure, entry)
584 a1 = gfc_code2string (flavors, attr->flavor);
586 if (attr->in_namelist
587 && attr->flavor != FL_VARIABLE
588 && attr->flavor != FL_PROCEDURE
589 && attr->flavor != FL_UNKNOWN)
595 switch (attr->flavor)
605 conf2 (is_protected);
615 conf2 (threadprivate);
617 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
619 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
620 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
627 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
641 /* Conflicts with INTENT, SAVE and RESULT will be checked
642 at resolution stage, see "resolve_fl_procedure". */
644 if (attr->subroutine)
651 conf2 (threadprivate);
654 if (!attr->proc_pointer)
659 case PROC_ST_FUNCTION:
669 conf2 (threadprivate);
689 conf2 (threadprivate);
692 if (attr->intent != INTENT_UNKNOWN)
708 conf2 (is_protected);
714 conf2 (threadprivate);
728 gfc_error ("%s attribute conflicts with %s attribute at %L",
731 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
732 a1, a2, name, where);
739 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
740 "with %s attribute at %L", a1, a2,
745 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
746 "with %s attribute in '%s' at %L",
747 a1, a2, name, where);
756 /* Mark a symbol as referenced. */
759 gfc_set_sym_referenced (gfc_symbol *sym)
762 if (sym->attr.referenced)
765 sym->attr.referenced = 1;
767 /* Remember which order dummy variables are accessed in. */
769 sym->dummy_order = next_dummy_order++;
773 /* Common subroutine called by attribute changing subroutines in order
774 to prevent them from changing a symbol that has been
775 use-associated. Returns zero if it is OK to change the symbol,
779 check_used (symbol_attribute *attr, const char *name, locus *where)
782 if (attr->use_assoc == 0)
786 where = &gfc_current_locus;
789 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
792 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
799 /* Generate an error because of a duplicate attribute. */
802 duplicate_attr (const char *attr, locus *where)
806 where = &gfc_current_locus;
808 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
812 /* Called from decl.c (attr_decl1) to check attributes, when declared
816 gfc_add_attribute (symbol_attribute *attr, locus *where)
819 if (check_used (attr, NULL, where))
822 return check_conflict (attr, NULL, where);
826 gfc_add_allocatable (symbol_attribute *attr, locus *where)
829 if (check_used (attr, NULL, where))
832 if (attr->allocatable)
834 duplicate_attr ("ALLOCATABLE", where);
838 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
839 && gfc_find_state (COMP_INTERFACE) == FAILURE)
841 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
846 attr->allocatable = 1;
847 return check_conflict (attr, NULL, where);
852 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
855 if (check_used (attr, name, where))
860 duplicate_attr ("DIMENSION", where);
864 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
865 && gfc_find_state (COMP_INTERFACE) == FAILURE)
867 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
868 "at %L", name, where);
873 return check_conflict (attr, name, where);
878 gfc_add_external (symbol_attribute *attr, locus *where)
881 if (check_used (attr, NULL, where))
886 duplicate_attr ("EXTERNAL", where);
890 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
893 attr->proc_pointer = 1;
898 return check_conflict (attr, NULL, where);
903 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
906 if (check_used (attr, NULL, where))
911 duplicate_attr ("INTRINSIC", where);
917 return check_conflict (attr, NULL, where);
922 gfc_add_optional (symbol_attribute *attr, locus *where)
925 if (check_used (attr, NULL, where))
930 duplicate_attr ("OPTIONAL", where);
935 return check_conflict (attr, NULL, where);
940 gfc_add_pointer (symbol_attribute *attr, locus *where)
943 if (check_used (attr, NULL, where))
946 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
947 && gfc_find_state (COMP_INTERFACE) == FAILURE))
949 duplicate_attr ("POINTER", where);
953 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
954 || (attr->if_source == IFSRC_IFBODY
955 && gfc_find_state (COMP_INTERFACE) == FAILURE))
956 attr->proc_pointer = 1;
960 return check_conflict (attr, NULL, where);
965 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
968 if (check_used (attr, NULL, where))
971 attr->cray_pointer = 1;
972 return check_conflict (attr, NULL, where);
977 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
980 if (check_used (attr, NULL, where))
983 if (attr->cray_pointee)
985 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
986 " statements", where);
990 attr->cray_pointee = 1;
991 return check_conflict (attr, NULL, where);
996 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
998 if (check_used (attr, name, where))
1001 if (attr->is_protected)
1003 if (gfc_notify_std (GFC_STD_LEGACY,
1004 "Duplicate PROTECTED attribute specified at %L",
1010 attr->is_protected = 1;
1011 return check_conflict (attr, name, where);
1016 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1019 if (check_used (attr, name, where))
1023 return check_conflict (attr, name, where);
1028 gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
1031 if (check_used (attr, name, where))
1034 if (gfc_pure (NULL))
1037 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1042 if (attr->save == SAVE_EXPLICIT)
1044 if (gfc_notify_std (GFC_STD_LEGACY,
1045 "Duplicate SAVE attribute specified at %L",
1051 attr->save = SAVE_EXPLICIT;
1052 return check_conflict (attr, name, where);
1057 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1060 if (check_used (attr, name, where))
1065 if (gfc_notify_std (GFC_STD_LEGACY,
1066 "Duplicate VALUE attribute specified at %L",
1073 return check_conflict (attr, name, where);
1078 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1080 /* No check_used needed as 11.2.1 of the F2003 standard allows
1081 that the local identifier made accessible by a use statement can be
1082 given a VOLATILE attribute. */
1084 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1085 if (gfc_notify_std (GFC_STD_LEGACY,
1086 "Duplicate VOLATILE attribute specified at %L", where)
1090 attr->volatile_ = 1;
1091 attr->volatile_ns = gfc_current_ns;
1092 return check_conflict (attr, name, where);
1097 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1100 if (check_used (attr, name, where))
1103 if (attr->threadprivate)
1105 duplicate_attr ("THREADPRIVATE", where);
1109 attr->threadprivate = 1;
1110 return check_conflict (attr, name, where);
1115 gfc_add_target (symbol_attribute *attr, locus *where)
1118 if (check_used (attr, NULL, where))
1123 duplicate_attr ("TARGET", where);
1128 return check_conflict (attr, NULL, where);
1133 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1136 if (check_used (attr, name, where))
1139 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1141 return check_conflict (attr, name, where);
1146 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1149 if (check_used (attr, name, where))
1152 /* Duplicate attribute already checked for. */
1153 attr->in_common = 1;
1154 return check_conflict (attr, name, where);
1159 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1162 /* Duplicate attribute already checked for. */
1163 attr->in_equivalence = 1;
1164 if (check_conflict (attr, name, where) == FAILURE)
1167 if (attr->flavor == FL_VARIABLE)
1170 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1175 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1178 if (check_used (attr, name, where))
1182 return check_conflict (attr, name, where);
1187 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1190 attr->in_namelist = 1;
1191 return check_conflict (attr, name, where);
1196 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1199 if (check_used (attr, name, where))
1203 return check_conflict (attr, name, where);
1208 gfc_add_elemental (symbol_attribute *attr, locus *where)
1211 if (check_used (attr, NULL, where))
1214 if (attr->elemental)
1216 duplicate_attr ("ELEMENTAL", where);
1220 attr->elemental = 1;
1221 return check_conflict (attr, NULL, where);
1226 gfc_add_pure (symbol_attribute *attr, locus *where)
1229 if (check_used (attr, NULL, where))
1234 duplicate_attr ("PURE", where);
1239 return check_conflict (attr, NULL, where);
1244 gfc_add_recursive (symbol_attribute *attr, locus *where)
1247 if (check_used (attr, NULL, where))
1250 if (attr->recursive)
1252 duplicate_attr ("RECURSIVE", where);
1256 attr->recursive = 1;
1257 return check_conflict (attr, NULL, where);
1262 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1265 if (check_used (attr, name, where))
1270 duplicate_attr ("ENTRY", where);
1275 return check_conflict (attr, name, where);
1280 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1283 if (attr->flavor != FL_PROCEDURE
1284 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1288 return check_conflict (attr, name, where);
1293 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1296 if (attr->flavor != FL_PROCEDURE
1297 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1300 attr->subroutine = 1;
1301 return check_conflict (attr, name, where);
1306 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1309 if (attr->flavor != FL_PROCEDURE
1310 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1314 return check_conflict (attr, name, where);
1319 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1322 if (check_used (attr, NULL, where))
1325 if (attr->flavor != FL_PROCEDURE
1326 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1329 if (attr->procedure)
1331 duplicate_attr ("PROCEDURE", where);
1335 attr->procedure = 1;
1337 return check_conflict (attr, NULL, where);
1342 gfc_add_abstract (symbol_attribute* attr, locus* where)
1346 duplicate_attr ("ABSTRACT", where);
1355 /* Flavors are special because some flavors are not what Fortran
1356 considers attributes and can be reaffirmed multiple times. */
1359 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1363 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1364 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1365 || f == FL_NAMELIST) && check_used (attr, name, where))
1368 if (attr->flavor == f && f == FL_VARIABLE)
1371 if (attr->flavor != FL_UNKNOWN)
1374 where = &gfc_current_locus;
1377 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1378 gfc_code2string (flavors, attr->flavor), name,
1379 gfc_code2string (flavors, f), where);
1381 gfc_error ("%s attribute conflicts with %s attribute at %L",
1382 gfc_code2string (flavors, attr->flavor),
1383 gfc_code2string (flavors, f), where);
1390 return check_conflict (attr, name, where);
1395 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1396 const char *name, locus *where)
1399 if (check_used (attr, name, where))
1402 if (attr->flavor != FL_PROCEDURE
1403 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1407 where = &gfc_current_locus;
1409 if (attr->proc != PROC_UNKNOWN)
1411 gfc_error ("%s procedure at %L is already declared as %s procedure",
1412 gfc_code2string (procedures, t), where,
1413 gfc_code2string (procedures, attr->proc));
1420 /* Statement functions are always scalar and functions. */
1421 if (t == PROC_ST_FUNCTION
1422 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1423 || attr->dimension))
1426 return check_conflict (attr, name, where);
1431 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1434 if (check_used (attr, NULL, where))
1437 if (attr->intent == INTENT_UNKNOWN)
1439 attr->intent = intent;
1440 return check_conflict (attr, NULL, where);
1444 where = &gfc_current_locus;
1446 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1447 gfc_intent_string (attr->intent),
1448 gfc_intent_string (intent), where);
1454 /* No checks for use-association in public and private statements. */
1457 gfc_add_access (symbol_attribute *attr, gfc_access access,
1458 const char *name, locus *where)
1461 if (attr->access == ACCESS_UNKNOWN
1462 || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1464 attr->access = access;
1465 return check_conflict (attr, name, where);
1469 where = &gfc_current_locus;
1470 gfc_error ("ACCESS specification at %L was already specified", where);
1476 /* Set the is_bind_c field for the given symbol_attribute. */
1479 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1480 int is_proc_lang_bind_spec)
1483 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1484 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1485 "variables or common blocks", where);
1486 else if (attr->is_bind_c)
1487 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1489 attr->is_bind_c = 1;
1492 where = &gfc_current_locus;
1494 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1498 return check_conflict (attr, name, where);
1502 /* Set the extension field for the given symbol_attribute. */
1505 gfc_add_extension (symbol_attribute *attr, locus *where)
1508 where = &gfc_current_locus;
1510 if (attr->extension)
1511 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1513 attr->extension = 1;
1515 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
1524 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1525 gfc_formal_arglist * formal, locus *where)
1528 if (check_used (&sym->attr, sym->name, where))
1532 where = &gfc_current_locus;
1534 if (sym->attr.if_source != IFSRC_UNKNOWN
1535 && sym->attr.if_source != IFSRC_DECL)
1537 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1542 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1544 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1545 "body", sym->name, where);
1549 sym->formal = formal;
1550 sym->attr.if_source = source;
1556 /* Add a type to a symbol. */
1559 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1564 where = &gfc_current_locus;
1566 if (sym->ts.type != BT_UNKNOWN)
1568 const char *msg = "Symbol '%s' at %L already has basic type of %s";
1569 if (!(sym->ts.type == ts->type && sym->attr.result)
1570 || gfc_notification_std (GFC_STD_GNU) == ERROR
1573 gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1576 if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
1577 gfc_basic_typename (sym->ts.type)) == FAILURE)
1579 if (gfc_option.warn_surprising)
1580 gfc_warning (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1583 if (sym->attr.procedure && sym->ts.interface)
1585 gfc_error ("Procedure '%s' at %L may not have basic type of %s", sym->name, where,
1586 gfc_basic_typename (ts->type));
1590 flavor = sym->attr.flavor;
1592 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1593 || flavor == FL_LABEL
1594 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1595 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1597 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1606 /* Clears all attributes. */
1609 gfc_clear_attr (symbol_attribute *attr)
1611 memset (attr, 0, sizeof (symbol_attribute));
1615 /* Check for missing attributes in the new symbol. Currently does
1616 nothing, but it's not clear that it is unnecessary yet. */
1619 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1620 locus *where ATTRIBUTE_UNUSED)
1627 /* Copy an attribute to a symbol attribute, bit by bit. Some
1628 attributes have a lot of side-effects but cannot be present given
1629 where we are called from, so we ignore some bits. */
1632 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1634 int is_proc_lang_bind_spec;
1636 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1639 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1641 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1643 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1645 if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1647 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1649 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1651 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1653 if (src->threadprivate
1654 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1656 if (src->target && gfc_add_target (dest, where) == FAILURE)
1658 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1660 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1665 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1668 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1671 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1673 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1675 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1678 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1680 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1682 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1684 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1687 if (src->flavor != FL_UNKNOWN
1688 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1691 if (src->intent != INTENT_UNKNOWN
1692 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1695 if (src->access != ACCESS_UNKNOWN
1696 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1699 if (gfc_missing_attr (dest, where) == FAILURE)
1702 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1704 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1707 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1709 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1713 if (src->is_c_interop)
1714 dest->is_c_interop = 1;
1718 if (src->external && gfc_add_external (dest, where) == FAILURE)
1720 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1722 if (src->proc_pointer)
1723 dest->proc_pointer = 1;
1732 /************** Component name management ************/
1734 /* Component names of a derived type form their own little namespaces
1735 that are separate from all other spaces. The space is composed of
1736 a singly linked list of gfc_component structures whose head is
1737 located in the parent symbol. */
1740 /* Add a component name to a symbol. The call fails if the name is
1741 already present. On success, the component pointer is modified to
1742 point to the additional component structure. */
1745 gfc_add_component (gfc_symbol *sym, const char *name,
1746 gfc_component **component)
1748 gfc_component *p, *tail;
1752 for (p = sym->components; p; p = p->next)
1754 if (strcmp (p->name, name) == 0)
1756 gfc_error ("Component '%s' at %C already declared at %L",
1764 if (sym->attr.extension
1765 && gfc_find_component (sym->components->ts.derived, name, true, true))
1767 gfc_error ("Component '%s' at %C already in the parent type "
1768 "at %L", name, &sym->components->ts.derived->declared_at);
1772 /* Allocate a new component. */
1773 p = gfc_get_component ();
1776 sym->components = p;
1780 p->name = gfc_get_string (name);
1781 p->loc = gfc_current_locus;
1782 p->ts.type = BT_UNKNOWN;
1789 /* Recursive function to switch derived types of all symbol in a
1793 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1801 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1802 sym->ts.derived = to;
1804 switch_types (st->left, from, to);
1805 switch_types (st->right, from, to);
1809 /* This subroutine is called when a derived type is used in order to
1810 make the final determination about which version to use. The
1811 standard requires that a type be defined before it is 'used', but
1812 such types can appear in IMPLICIT statements before the actual
1813 definition. 'Using' in this context means declaring a variable to
1814 be that type or using the type constructor.
1816 If a type is used and the components haven't been defined, then we
1817 have to have a derived type in a parent unit. We find the node in
1818 the other namespace and point the symtree node in this namespace to
1819 that node. Further reference to this name point to the correct
1820 node. If we can't find the node in a parent namespace, then we have
1823 This subroutine takes a pointer to a symbol node and returns a
1824 pointer to the translated node or NULL for an error. Usually there
1825 is no translation and we return the node we were passed. */
1828 gfc_use_derived (gfc_symbol *sym)
1835 if (sym->components != NULL || sym->attr.zero_comp)
1836 return sym; /* Already defined. */
1838 if (sym->ns->parent == NULL)
1841 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1843 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1847 if (s == NULL || s->attr.flavor != FL_DERIVED)
1850 /* Get rid of symbol sym, translating all references to s. */
1851 for (i = 0; i < GFC_LETTERS; i++)
1853 t = &sym->ns->default_type[i];
1854 if (t->derived == sym)
1858 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1863 /* Unlink from list of modified symbols. */
1864 gfc_commit_symbol (sym);
1866 switch_types (sym->ns->sym_root, sym, s);
1868 /* TODO: Also have to replace sym -> s in other lists like
1869 namelists, common lists and interface lists. */
1870 gfc_free_symbol (sym);
1875 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1881 /* Given a derived type node and a component name, try to locate the
1882 component structure. Returns the NULL pointer if the component is
1883 not found or the components are private. If noaccess is set, no access
1887 gfc_find_component (gfc_symbol *sym, const char *name,
1888 bool noaccess, bool silent)
1895 sym = gfc_use_derived (sym);
1900 for (p = sym->components; p; p = p->next)
1901 if (strcmp (p->name, name) == 0)
1905 && sym->attr.extension
1906 && sym->components->ts.type == BT_DERIVED)
1908 p = gfc_find_component (sym->components->ts.derived, name,
1910 /* Do not overwrite the error. */
1915 if (p == NULL && !silent)
1916 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1919 else if (sym->attr.use_assoc && !noaccess)
1921 if (p->attr.access == ACCESS_PRIVATE)
1924 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1929 /* If there were components given and all components are private, error
1930 out at this place. */
1931 if (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
1934 gfc_error ("All components of '%s' are PRIVATE in structure"
1935 " constructor at %C", sym->name);
1944 /* Given a symbol, free all of the component structures and everything
1948 free_components (gfc_component *p)
1956 gfc_free_array_spec (p->as);
1957 gfc_free_expr (p->initializer);
1964 /******************** Statement label management ********************/
1966 /* Comparison function for statement labels, used for managing the
1970 compare_st_labels (void *a1, void *b1)
1972 int a = ((gfc_st_label *) a1)->value;
1973 int b = ((gfc_st_label *) b1)->value;
1979 /* Free a single gfc_st_label structure, making sure the tree is not
1980 messed up. This function is called only when some parse error
1984 gfc_free_st_label (gfc_st_label *label)
1990 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
1992 if (label->format != NULL)
1993 gfc_free_expr (label->format);
1999 /* Free a whole tree of gfc_st_label structures. */
2002 free_st_labels (gfc_st_label *label)
2008 free_st_labels (label->left);
2009 free_st_labels (label->right);
2011 if (label->format != NULL)
2012 gfc_free_expr (label->format);
2017 /* Given a label number, search for and return a pointer to the label
2018 structure, creating it if it does not exist. */
2021 gfc_get_st_label (int labelno)
2025 /* First see if the label is already in this namespace. */
2026 lp = gfc_current_ns->st_labels;
2029 if (lp->value == labelno)
2032 if (lp->value < labelno)
2038 lp = XCNEW (gfc_st_label);
2040 lp->value = labelno;
2041 lp->defined = ST_LABEL_UNKNOWN;
2042 lp->referenced = ST_LABEL_UNKNOWN;
2044 gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
2050 /* Called when a statement with a statement label is about to be
2051 accepted. We add the label to the list of the current namespace,
2052 making sure it hasn't been defined previously and referenced
2056 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2060 labelno = lp->value;
2062 if (lp->defined != ST_LABEL_UNKNOWN)
2063 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2064 &lp->where, label_locus);
2067 lp->where = *label_locus;
2071 case ST_LABEL_FORMAT:
2072 if (lp->referenced == ST_LABEL_TARGET)
2073 gfc_error ("Label %d at %C already referenced as branch target",
2076 lp->defined = ST_LABEL_FORMAT;
2080 case ST_LABEL_TARGET:
2081 if (lp->referenced == ST_LABEL_FORMAT)
2082 gfc_error ("Label %d at %C already referenced as a format label",
2085 lp->defined = ST_LABEL_TARGET;
2090 lp->defined = ST_LABEL_BAD_TARGET;
2091 lp->referenced = ST_LABEL_BAD_TARGET;
2097 /* Reference a label. Given a label and its type, see if that
2098 reference is consistent with what is known about that label,
2099 updating the unknown state. Returns FAILURE if something goes
2103 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2105 gfc_sl_type label_type;
2112 labelno = lp->value;
2114 if (lp->defined != ST_LABEL_UNKNOWN)
2115 label_type = lp->defined;
2118 label_type = lp->referenced;
2119 lp->where = gfc_current_locus;
2122 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2124 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2129 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2130 && type == ST_LABEL_FORMAT)
2132 gfc_error ("Label %d at %C previously used as branch target", labelno);
2137 lp->referenced = type;
2145 /*******A helper function for creating new expressions*************/
2149 gfc_lval_expr_from_sym (gfc_symbol *sym)
2152 lval = gfc_get_expr ();
2153 lval->expr_type = EXPR_VARIABLE;
2154 lval->where = sym->declared_at;
2156 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2158 /* It will always be a full array. */
2159 lval->rank = sym->as ? sym->as->rank : 0;
2162 lval->ref = gfc_get_ref ();
2163 lval->ref->type = REF_ARRAY;
2164 lval->ref->u.ar.type = AR_FULL;
2165 lval->ref->u.ar.dimen = lval->rank;
2166 lval->ref->u.ar.where = sym->declared_at;
2167 lval->ref->u.ar.as = sym->as;
2174 /************** Symbol table management subroutines ****************/
2176 /* Basic details: Fortran 95 requires a potentially unlimited number
2177 of distinct namespaces when compiling a program unit. This case
2178 occurs during a compilation of internal subprograms because all of
2179 the internal subprograms must be read before we can start
2180 generating code for the host.
2182 Given the tricky nature of the Fortran grammar, we must be able to
2183 undo changes made to a symbol table if the current interpretation
2184 of a statement is found to be incorrect. Whenever a symbol is
2185 looked up, we make a copy of it and link to it. All of these
2186 symbols are kept in a singly linked list so that we can commit or
2187 undo the changes at a later time.
2189 A symtree may point to a symbol node outside of its namespace. In
2190 this case, that symbol has been used as a host associated variable
2191 at some previous time. */
2193 /* Allocate a new namespace structure. Copies the implicit types from
2194 PARENT if PARENT_TYPES is set. */
2197 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2201 gfc_intrinsic_op in;
2204 ns = XCNEW (gfc_namespace);
2205 ns->sym_root = NULL;
2206 ns->uop_root = NULL;
2207 ns->tb_sym_root = NULL;
2208 ns->finalizers = NULL;
2209 ns->default_access = ACCESS_UNKNOWN;
2210 ns->parent = parent;
2212 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2213 ns->operator_access[in] = ACCESS_UNKNOWN;
2215 /* Initialize default implicit types. */
2216 for (i = 'a'; i <= 'z'; i++)
2218 ns->set_flag[i - 'a'] = 0;
2219 ts = &ns->default_type[i - 'a'];
2221 if (parent_types && ns->parent != NULL)
2223 /* Copy parent settings. */
2224 *ts = ns->parent->default_type[i - 'a'];
2228 if (gfc_option.flag_implicit_none != 0)
2234 if ('i' <= i && i <= 'n')
2236 ts->type = BT_INTEGER;
2237 ts->kind = gfc_default_integer_kind;
2242 ts->kind = gfc_default_real_kind;
2252 /* Comparison function for symtree nodes. */
2255 compare_symtree (void *_st1, void *_st2)
2257 gfc_symtree *st1, *st2;
2259 st1 = (gfc_symtree *) _st1;
2260 st2 = (gfc_symtree *) _st2;
2262 return strcmp (st1->name, st2->name);
2266 /* Allocate a new symtree node and associate it with the new symbol. */
2269 gfc_new_symtree (gfc_symtree **root, const char *name)
2273 st = XCNEW (gfc_symtree);
2274 st->name = gfc_get_string (name);
2276 gfc_insert_bbt (root, st, compare_symtree);
2281 /* Delete a symbol from the tree. Does not free the symbol itself! */
2284 gfc_delete_symtree (gfc_symtree **root, const char *name)
2286 gfc_symtree st, *st0;
2288 st0 = gfc_find_symtree (*root, name);
2290 st.name = gfc_get_string (name);
2291 gfc_delete_bbt (root, &st, compare_symtree);
2297 /* Given a root symtree node and a name, try to find the symbol within
2298 the namespace. Returns NULL if the symbol is not found. */
2301 gfc_find_symtree (gfc_symtree *st, const char *name)
2307 c = strcmp (name, st->name);
2311 st = (c < 0) ? st->left : st->right;
2318 /* Return a symtree node with a name that is guaranteed to be unique
2319 within the namespace and corresponds to an illegal fortran name. */
2322 gfc_get_unique_symtree (gfc_namespace *ns)
2324 char name[GFC_MAX_SYMBOL_LEN + 1];
2325 static int serial = 0;
2327 sprintf (name, "@%d", serial++);
2328 return gfc_new_symtree (&ns->sym_root, name);
2332 /* Given a name find a user operator node, creating it if it doesn't
2333 exist. These are much simpler than symbols because they can't be
2334 ambiguous with one another. */
2337 gfc_get_uop (const char *name)
2342 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2346 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2348 uop = st->n.uop = XCNEW (gfc_user_op);
2349 uop->name = gfc_get_string (name);
2350 uop->access = ACCESS_UNKNOWN;
2351 uop->ns = gfc_current_ns;
2357 /* Given a name find the user operator node. Returns NULL if it does
2361 gfc_find_uop (const char *name, gfc_namespace *ns)
2366 ns = gfc_current_ns;
2368 st = gfc_find_symtree (ns->uop_root, name);
2369 return (st == NULL) ? NULL : st->n.uop;
2373 /* Remove a gfc_symbol structure and everything it points to. */
2376 gfc_free_symbol (gfc_symbol *sym)
2382 gfc_free_array_spec (sym->as);
2384 free_components (sym->components);
2386 gfc_free_expr (sym->value);
2388 gfc_free_namelist (sym->namelist);
2390 gfc_free_namespace (sym->formal_ns);
2392 if (!sym->attr.generic_copy)
2393 gfc_free_interface (sym->generic);
2395 gfc_free_formal_arglist (sym->formal);
2397 gfc_free_namespace (sym->f2k_derived);
2403 /* Allocate and initialize a new symbol node. */
2406 gfc_new_symbol (const char *name, gfc_namespace *ns)
2410 p = XCNEW (gfc_symbol);
2412 gfc_clear_ts (&p->ts);
2413 gfc_clear_attr (&p->attr);
2416 p->declared_at = gfc_current_locus;
2418 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2419 gfc_internal_error ("new_symbol(): Symbol name too long");
2421 p->name = gfc_get_string (name);
2423 /* Make sure flags for symbol being C bound are clear initially. */
2424 p->attr.is_bind_c = 0;
2425 p->attr.is_iso_c = 0;
2426 /* Make sure the binding label field has a Nul char to start. */
2427 p->binding_label[0] = '\0';
2429 /* Clear the ptrs we may need. */
2430 p->common_block = NULL;
2431 p->f2k_derived = NULL;
2437 /* Generate an error if a symbol is ambiguous. */
2440 ambiguous_symbol (const char *name, gfc_symtree *st)
2443 if (st->n.sym->module)
2444 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2445 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2447 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2448 "from current program unit", name, st->n.sym->name);
2452 /* Search for a symtree starting in the current namespace, resorting to
2453 any parent namespaces if requested by a nonzero parent_flag.
2454 Returns nonzero if the name is ambiguous. */
2457 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2458 gfc_symtree **result)
2463 ns = gfc_current_ns;
2467 st = gfc_find_symtree (ns->sym_root, name);
2471 /* Ambiguous generic interfaces are permitted, as long
2472 as the specific interfaces are different. */
2473 if (st->ambiguous && !st->n.sym->attr.generic)
2475 ambiguous_symbol (name, st);
2494 /* Same, but returns the symbol instead. */
2497 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2498 gfc_symbol **result)
2503 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2508 *result = st->n.sym;
2514 /* Save symbol with the information necessary to back it out. */
2517 save_symbol_data (gfc_symbol *sym)
2520 if (sym->gfc_new || sym->old_symbol != NULL)
2523 sym->old_symbol = XCNEW (gfc_symbol);
2524 *(sym->old_symbol) = *sym;
2526 sym->tlink = changed_syms;
2531 /* Given a name, find a symbol, or create it if it does not exist yet
2532 in the current namespace. If the symbol is found we make sure that
2535 The integer return code indicates
2537 1 The symbol name was ambiguous
2538 2 The name meant to be established was already host associated.
2540 So if the return value is nonzero, then an error was issued. */
2543 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
2548 /* This doesn't usually happen during resolution. */
2550 ns = gfc_current_ns;
2552 /* Try to find the symbol in ns. */
2553 st = gfc_find_symtree (ns->sym_root, name);
2557 /* If not there, create a new symbol. */
2558 p = gfc_new_symbol (name, ns);
2560 /* Add to the list of tentative symbols. */
2561 p->old_symbol = NULL;
2562 p->tlink = changed_syms;
2567 st = gfc_new_symtree (&ns->sym_root, name);
2574 /* Make sure the existing symbol is OK. Ambiguous
2575 generic interfaces are permitted, as long as the
2576 specific interfaces are different. */
2577 if (st->ambiguous && !st->n.sym->attr.generic)
2579 ambiguous_symbol (name, st);
2585 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2587 && ns->proc_name->attr.if_source == IFSRC_IFBODY
2588 && (ns->has_import_set || p->attr.imported)))
2590 /* Symbol is from another namespace. */
2591 gfc_error ("Symbol '%s' at %C has already been host associated",
2598 /* Copy in case this symbol is changed. */
2599 save_symbol_data (p);
2608 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2613 i = gfc_get_sym_tree (name, ns, &st);
2618 *result = st->n.sym;
2625 /* Subroutine that searches for a symbol, creating it if it doesn't
2626 exist, but tries to host-associate the symbol if possible. */
2629 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2634 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2637 save_symbol_data (st->n.sym);
2642 if (gfc_current_ns->parent != NULL)
2644 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2655 return gfc_get_sym_tree (name, gfc_current_ns, result);
2660 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2665 i = gfc_get_ha_sym_tree (name, &st);
2668 *result = st->n.sym;
2675 /* Return true if both symbols could refer to the same data object. Does
2676 not take account of aliasing due to equivalence statements. */
2679 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2681 /* Aliasing isn't possible if the symbols have different base types. */
2682 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2685 /* Pointers can point to other pointers, target objects and allocatable
2686 objects. Two allocatable objects cannot share the same storage. */
2687 if (lsym->attr.pointer
2688 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2690 if (lsym->attr.target && rsym->attr.pointer)
2692 if (lsym->attr.allocatable && rsym->attr.pointer)
2699 /* Undoes all the changes made to symbols in the current statement.
2700 This subroutine is made simpler due to the fact that attributes are
2701 never removed once added. */
2704 gfc_undo_symbols (void)
2706 gfc_symbol *p, *q, *old;
2707 tentative_tbp *tbp, *tbq;
2709 for (p = changed_syms; p; p = q)
2715 /* Symbol was new. */
2716 if (p->attr.in_common && p->common_block->head)
2718 /* If the symbol was added to any common block, it
2719 needs to be removed to stop the resolver looking
2720 for a (possibly) dead symbol. */
2722 if (p->common_block->head == p)
2723 p->common_block->head = p->common_next;
2726 gfc_symbol *cparent, *csym;
2728 cparent = p->common_block->head;
2729 csym = cparent->common_next;
2734 csym = csym->common_next;
2737 gcc_assert(cparent->common_next == p);
2739 cparent->common_next = csym->common_next;
2743 gfc_delete_symtree (&p->ns->sym_root, p->name);
2747 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2749 gfc_free_symbol (p);
2753 /* Restore previous state of symbol. Just copy simple stuff. */
2755 old = p->old_symbol;
2757 p->ts.type = old->ts.type;
2758 p->ts.kind = old->ts.kind;
2760 p->attr = old->attr;
2762 if (p->value != old->value)
2764 gfc_free_expr (old->value);
2768 if (p->as != old->as)
2771 gfc_free_array_spec (p->as);
2775 p->generic = old->generic;
2776 p->component_access = old->component_access;
2778 if (p->namelist != NULL && old->namelist == NULL)
2780 gfc_free_namelist (p->namelist);
2785 if (p->namelist_tail != old->namelist_tail)
2787 gfc_free_namelist (old->namelist_tail);
2788 old->namelist_tail->next = NULL;
2792 p->namelist_tail = old->namelist_tail;
2794 if (p->formal != old->formal)
2796 gfc_free_formal_arglist (p->formal);
2797 p->formal = old->formal;
2800 gfc_free (p->old_symbol);
2801 p->old_symbol = NULL;
2805 changed_syms = NULL;
2807 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2810 /* Procedure is already marked `error' by default. */
2813 tentative_tbp_list = NULL;
2817 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2818 components of old_symbol that might need deallocation are the "allocatables"
2819 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2820 namelist_tail. In case these differ between old_symbol and sym, it's just
2821 because sym->namelist has gotten a few more items. */
2824 free_old_symbol (gfc_symbol *sym)
2827 if (sym->old_symbol == NULL)
2830 if (sym->old_symbol->as != sym->as)
2831 gfc_free_array_spec (sym->old_symbol->as);
2833 if (sym->old_symbol->value != sym->value)
2834 gfc_free_expr (sym->old_symbol->value);
2836 if (sym->old_symbol->formal != sym->formal)
2837 gfc_free_formal_arglist (sym->old_symbol->formal);
2839 gfc_free (sym->old_symbol);
2840 sym->old_symbol = NULL;
2844 /* Makes the changes made in the current statement permanent-- gets
2845 rid of undo information. */
2848 gfc_commit_symbols (void)
2851 tentative_tbp *tbp, *tbq;
2853 for (p = changed_syms; p; p = q)
2859 free_old_symbol (p);
2861 changed_syms = NULL;
2863 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2866 tbp->proc->error = 0;
2869 tentative_tbp_list = NULL;
2873 /* Makes the changes made in one symbol permanent -- gets rid of undo
2877 gfc_commit_symbol (gfc_symbol *sym)
2881 if (changed_syms == sym)
2882 changed_syms = sym->tlink;
2885 for (p = changed_syms; p; p = p->tlink)
2886 if (p->tlink == sym)
2888 p->tlink = sym->tlink;
2897 free_old_symbol (sym);
2901 /* Recursively free trees containing type-bound procedures. */
2904 free_tb_tree (gfc_symtree *t)
2909 free_tb_tree (t->left);
2910 free_tb_tree (t->right);
2912 /* TODO: Free type-bound procedure structs themselves; probably needs some
2913 sort of ref-counting mechanism. */
2919 /* Recursive function that deletes an entire tree and all the common
2920 head structures it points to. */
2923 free_common_tree (gfc_symtree * common_tree)
2925 if (common_tree == NULL)
2928 free_common_tree (common_tree->left);
2929 free_common_tree (common_tree->right);
2931 gfc_free (common_tree);
2935 /* Recursive function that deletes an entire tree and all the user
2936 operator nodes that it contains. */
2939 free_uop_tree (gfc_symtree *uop_tree)
2942 if (uop_tree == NULL)
2945 free_uop_tree (uop_tree->left);
2946 free_uop_tree (uop_tree->right);
2948 gfc_free_interface (uop_tree->n.uop->op);
2950 gfc_free (uop_tree->n.uop);
2951 gfc_free (uop_tree);
2955 /* Recursive function that deletes an entire tree and all the symbols
2956 that it contains. */
2959 free_sym_tree (gfc_symtree *sym_tree)
2964 if (sym_tree == NULL)
2967 free_sym_tree (sym_tree->left);
2968 free_sym_tree (sym_tree->right);
2970 sym = sym_tree->n.sym;
2974 gfc_internal_error ("free_sym_tree(): Negative refs");
2976 if (sym->formal_ns != NULL && sym->refs == 1)
2978 /* As formal_ns contains a reference to sym, delete formal_ns just
2979 before the deletion of sym. */
2980 ns = sym->formal_ns;
2981 sym->formal_ns = NULL;
2982 gfc_free_namespace (ns);
2984 else if (sym->refs == 0)
2986 /* Go ahead and delete the symbol. */
2987 gfc_free_symbol (sym);
2990 gfc_free (sym_tree);
2994 /* Free the derived type list. */
2997 gfc_free_dt_list (void)
2999 gfc_dt_list *dt, *n;
3001 for (dt = gfc_derived_types; dt; dt = n)
3007 gfc_derived_types = NULL;
3011 /* Free the gfc_equiv_info's. */
3014 gfc_free_equiv_infos (gfc_equiv_info *s)
3018 gfc_free_equiv_infos (s->next);
3023 /* Free the gfc_equiv_lists. */
3026 gfc_free_equiv_lists (gfc_equiv_list *l)
3030 gfc_free_equiv_lists (l->next);
3031 gfc_free_equiv_infos (l->equiv);
3036 /* Free a finalizer procedure list. */
3039 gfc_free_finalizer (gfc_finalizer* el)
3045 --el->proc_sym->refs;
3046 if (!el->proc_sym->refs)
3047 gfc_free_symbol (el->proc_sym);
3055 gfc_free_finalizer_list (gfc_finalizer* list)
3059 gfc_finalizer* current = list;
3061 gfc_free_finalizer (current);
3066 /* Free the charlen list from cl to end (end is not freed).
3067 Free the whole list if end is NULL. */
3069 void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3073 for (; cl != end; cl = cl2)
3078 gfc_free_expr (cl->length);
3084 /* Free a namespace structure and everything below it. Interface
3085 lists associated with intrinsic operators are not freed. These are
3086 taken care of when a specific name is freed. */
3089 gfc_free_namespace (gfc_namespace *ns)
3091 gfc_namespace *p, *q;
3100 gcc_assert (ns->refs == 0);
3102 gfc_free_statements (ns->code);
3104 free_sym_tree (ns->sym_root);
3105 free_uop_tree (ns->uop_root);
3106 free_common_tree (ns->common_root);
3107 free_tb_tree (ns->tb_sym_root);
3108 gfc_free_finalizer_list (ns->finalizers);
3109 gfc_free_charlen (ns->cl_list, NULL);
3110 free_st_labels (ns->st_labels);
3112 gfc_free_equiv (ns->equiv);
3113 gfc_free_equiv_lists (ns->equiv_lists);
3114 gfc_free_use_stmts (ns->use_stmts);
3116 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3117 gfc_free_interface (ns->op[i]);
3119 gfc_free_data (ns->data);
3123 /* Recursively free any contained namespaces. */
3128 gfc_free_namespace (q);
3134 gfc_symbol_init_2 (void)
3137 gfc_current_ns = gfc_get_namespace (NULL, 0);
3142 gfc_symbol_done_2 (void)
3145 gfc_free_namespace (gfc_current_ns);
3146 gfc_current_ns = NULL;
3147 gfc_free_dt_list ();
3151 /* Clear mark bits from symbol nodes associated with a symtree node. */
3154 clear_sym_mark (gfc_symtree *st)
3157 st->n.sym->mark = 0;
3161 /* Recursively traverse the symtree nodes. */
3164 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
3169 gfc_traverse_symtree (st->left, func);
3171 gfc_traverse_symtree (st->right, func);
3175 /* Recursive namespace traversal function. */
3178 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
3184 traverse_ns (st->left, func);
3186 if (st->n.sym->mark == 0)
3187 (*func) (st->n.sym);
3188 st->n.sym->mark = 1;
3190 traverse_ns (st->right, func);
3194 /* Call a given function for all symbols in the namespace. We take
3195 care that each gfc_symbol node is called exactly once. */
3198 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3201 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3203 traverse_ns (ns->sym_root, func);
3207 /* Return TRUE when name is the name of an intrinsic type. */
3210 gfc_is_intrinsic_typename (const char *name)
3212 if (strcmp (name, "integer") == 0
3213 || strcmp (name, "real") == 0
3214 || strcmp (name, "character") == 0
3215 || strcmp (name, "logical") == 0
3216 || strcmp (name, "complex") == 0
3217 || strcmp (name, "doubleprecision") == 0
3218 || strcmp (name, "doublecomplex") == 0)
3225 /* Return TRUE if the symbol is an automatic variable. */
3228 gfc_is_var_automatic (gfc_symbol *sym)
3230 /* Pointer and allocatable variables are never automatic. */
3231 if (sym->attr.pointer || sym->attr.allocatable)
3233 /* Check for arrays with non-constant size. */
3234 if (sym->attr.dimension && sym->as
3235 && !gfc_is_compile_time_shape (sym->as))
3237 /* Check for non-constant length character variables. */
3238 if (sym->ts.type == BT_CHARACTER
3240 && !gfc_is_constant_expr (sym->ts.cl->length))
3245 /* Given a symbol, mark it as SAVEd if it is allowed. */
3248 save_symbol (gfc_symbol *sym)
3251 if (sym->attr.use_assoc)
3254 if (sym->attr.in_common
3257 || sym->attr.flavor != FL_VARIABLE)
3259 /* Automatic objects are not saved. */
3260 if (gfc_is_var_automatic (sym))
3262 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3266 /* Mark those symbols which can be SAVEd as such. */
3269 gfc_save_all (gfc_namespace *ns)
3271 gfc_traverse_ns (ns, save_symbol);
3276 /* Make sure that no changes to symbols are pending. */
3279 gfc_symbol_state(void) {
3281 if (changed_syms != NULL)
3282 gfc_internal_error("Symbol changes still pending!");
3287 /************** Global symbol handling ************/
3290 /* Search a tree for the global symbol. */
3293 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3302 c = strcmp (name, symbol->name);
3306 symbol = (c < 0) ? symbol->left : symbol->right;
3313 /* Compare two global symbols. Used for managing the BB tree. */
3316 gsym_compare (void *_s1, void *_s2)
3318 gfc_gsymbol *s1, *s2;
3320 s1 = (gfc_gsymbol *) _s1;
3321 s2 = (gfc_gsymbol *) _s2;
3322 return strcmp (s1->name, s2->name);
3326 /* Get a global symbol, creating it if it doesn't exist. */
3329 gfc_get_gsymbol (const char *name)
3333 s = gfc_find_gsymbol (gfc_gsym_root, name);
3337 s = XCNEW (gfc_gsymbol);
3338 s->type = GSYM_UNKNOWN;
3339 s->name = gfc_get_string (name);
3341 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3348 get_iso_c_binding_dt (int sym_id)
3350 gfc_dt_list *dt_list;
3352 dt_list = gfc_derived_types;
3354 /* Loop through the derived types in the name list, searching for
3355 the desired symbol from iso_c_binding. Search the parent namespaces
3356 if necessary and requested to (parent_flag). */
3357 while (dt_list != NULL)
3359 if (dt_list->derived->from_intmod != INTMOD_NONE
3360 && dt_list->derived->intmod_sym_id == sym_id)
3361 return dt_list->derived;
3363 dt_list = dt_list->next;
3370 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3371 with C. This is necessary for any derived type that is BIND(C) and for
3372 derived types that are parameters to functions that are BIND(C). All
3373 fields of the derived type are required to be interoperable, and are tested
3374 for such. If an error occurs, the errors are reported here, allowing for
3375 multiple errors to be handled for a single derived type. */
3378 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3380 gfc_component *curr_comp = NULL;
3381 gfc_try is_c_interop = FAILURE;
3382 gfc_try retval = SUCCESS;
3384 if (derived_sym == NULL)
3385 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3386 "unexpectedly NULL");
3388 /* If we've already looked at this derived symbol, do not look at it again
3389 so we don't repeat warnings/errors. */
3390 if (derived_sym->ts.is_c_interop)
3393 /* The derived type must have the BIND attribute to be interoperable
3394 J3/04-007, Section 15.2.3. */
3395 if (derived_sym->attr.is_bind_c != 1)
3397 derived_sym->ts.is_c_interop = 0;
3398 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3399 "attribute to be C interoperable", derived_sym->name,
3400 &(derived_sym->declared_at));
3404 curr_comp = derived_sym->components;
3406 /* TODO: is this really an error? */
3407 if (curr_comp == NULL)
3409 gfc_error ("Derived type '%s' at %L is empty",
3410 derived_sym->name, &(derived_sym->declared_at));
3414 /* Initialize the derived type as being C interoperable.
3415 If we find an error in the components, this will be set false. */
3416 derived_sym->ts.is_c_interop = 1;
3418 /* Loop through the list of components to verify that the kind of
3419 each is a C interoperable type. */
3422 /* The components cannot be pointers (fortran sense).
3423 J3/04-007, Section 15.2.3, C1505. */
3424 if (curr_comp->attr.pointer != 0)
3426 gfc_error ("Component '%s' at %L cannot have the "
3427 "POINTER attribute because it is a member "
3428 "of the BIND(C) derived type '%s' at %L",
3429 curr_comp->name, &(curr_comp->loc),
3430 derived_sym->name, &(derived_sym->declared_at));
3434 /* The components cannot be allocatable.
3435 J3/04-007, Section 15.2.3, C1505. */
3436 if (curr_comp->attr.allocatable != 0)
3438 gfc_error ("Component '%s' at %L cannot have the "
3439 "ALLOCATABLE attribute because it is a member "
3440 "of the BIND(C) derived type '%s' at %L",
3441 curr_comp->name, &(curr_comp->loc),
3442 derived_sym->name, &(derived_sym->declared_at));
3446 /* BIND(C) derived types must have interoperable components. */
3447 if (curr_comp->ts.type == BT_DERIVED
3448 && curr_comp->ts.derived->ts.is_iso_c != 1
3449 && curr_comp->ts.derived != derived_sym)
3451 /* This should be allowed; the draft says a derived-type can not
3452 have type parameters if it is has the BIND attribute. Type
3453 parameters seem to be for making parameterized derived types.
3454 There's no need to verify the type if it is c_ptr/c_funptr. */
3455 retval = verify_bind_c_derived_type (curr_comp->ts.derived);
3459 /* Grab the typespec for the given component and test the kind. */
3460 is_c_interop = verify_c_interop (&(curr_comp->ts));
3462 if (is_c_interop != SUCCESS)
3464 /* Report warning and continue since not fatal. The
3465 draft does specify a constraint that requires all fields
3466 to interoperate, but if the user says real(4), etc., it
3467 may interoperate with *something* in C, but the compiler
3468 most likely won't know exactly what. Further, it may not
3469 interoperate with the same data type(s) in C if the user
3470 recompiles with different flags (e.g., -m32 and -m64 on
3471 x86_64 and using integer(4) to claim interop with a
3473 if (derived_sym->attr.is_bind_c == 1)
3474 /* If the derived type is bind(c), all fields must be
3476 gfc_warning ("Component '%s' in derived type '%s' at %L "
3477 "may not be C interoperable, even though "
3478 "derived type '%s' is BIND(C)",
3479 curr_comp->name, derived_sym->name,
3480 &(curr_comp->loc), derived_sym->name);
3482 /* If derived type is param to bind(c) routine, or to one
3483 of the iso_c_binding procs, it must be interoperable, so
3484 all fields must interop too. */
3485 gfc_warning ("Component '%s' in derived type '%s' at %L "
3486 "may not be C interoperable",
3487 curr_comp->name, derived_sym->name,
3492 curr_comp = curr_comp->next;
3493 } while (curr_comp != NULL);
3496 /* Make sure we don't have conflicts with the attributes. */
3497 if (derived_sym->attr.access == ACCESS_PRIVATE)
3499 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3500 "PRIVATE and BIND(C) attributes", derived_sym->name,
3501 &(derived_sym->declared_at));
3505 if (derived_sym->attr.sequence != 0)
3507 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3508 "attribute because it is BIND(C)", derived_sym->name,
3509 &(derived_sym->declared_at));
3513 /* Mark the derived type as not being C interoperable if we found an
3514 error. If there were only warnings, proceed with the assumption
3515 it's interoperable. */
3516 if (retval == FAILURE)
3517 derived_sym->ts.is_c_interop = 0;
3523 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3526 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3527 const char *module_name)
3529 gfc_symtree *tmp_symtree;
3530 gfc_symbol *tmp_sym;
3532 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3534 if (tmp_symtree != NULL)
3535 tmp_sym = tmp_symtree->n.sym;
3539 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3540 "create symbol for %s", ptr_name);
3543 /* Set up the symbol's important fields. Save attr required so we can
3544 initialize the ptr to NULL. */
3545 tmp_sym->attr.save = SAVE_EXPLICIT;
3546 tmp_sym->ts.is_c_interop = 1;
3547 tmp_sym->attr.is_c_interop = 1;
3548 tmp_sym->ts.is_iso_c = 1;
3549 tmp_sym->ts.type = BT_DERIVED;
3551 /* The c_ptr and c_funptr derived types will provide the
3552 definition for c_null_ptr and c_null_funptr, respectively. */
3553 if (ptr_id == ISOCBINDING_NULL_PTR)
3554 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3556 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3557 if (tmp_sym->ts.derived == NULL)
3559 /* This can occur if the user forgot to declare c_ptr or
3560 c_funptr and they're trying to use one of the procedures
3561 that has arg(s) of the missing type. In this case, a
3562 regular version of the thing should have been put in the
3564 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3565 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3566 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3567 ? "_gfortran_iso_c_binding_c_ptr"
3568 : "_gfortran_iso_c_binding_c_funptr"));
3570 tmp_sym->ts.derived =
3571 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3572 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3575 /* Module name is some mangled version of iso_c_binding. */
3576 tmp_sym->module = gfc_get_string (module_name);
3578 /* Say it's from the iso_c_binding module. */
3579 tmp_sym->attr.is_iso_c = 1;
3581 tmp_sym->attr.use_assoc = 1;
3582 tmp_sym->attr.is_bind_c = 1;
3583 /* Set the binding_label. */
3584 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3586 /* Set the c_address field of c_null_ptr and c_null_funptr to
3587 the value of NULL. */
3588 tmp_sym->value = gfc_get_expr ();
3589 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3590 tmp_sym->value->ts.type = BT_DERIVED;
3591 tmp_sym->value->ts.derived = tmp_sym->ts.derived;
3592 /* Create a constructor with no expr, that way we can recognize if the user
3593 tries to call the structure constructor for one of the iso_c_binding
3594 derived types during resolution (resolve_structure_cons). */
3595 tmp_sym->value->value.constructor = gfc_get_constructor ();
3596 /* Must declare c_null_ptr and c_null_funptr as having the
3597 PARAMETER attribute so they can be used in init expressions. */
3598 tmp_sym->attr.flavor = FL_PARAMETER;
3604 /* Add a formal argument, gfc_formal_arglist, to the
3605 end of the given list of arguments. Set the reference to the
3606 provided symbol, param_sym, in the argument. */
3609 add_formal_arg (gfc_formal_arglist **head,
3610 gfc_formal_arglist **tail,
3611 gfc_formal_arglist *formal_arg,
3612 gfc_symbol *param_sym)
3614 /* Put in list, either as first arg or at the tail (curr arg). */
3616 *head = *tail = formal_arg;
3619 (*tail)->next = formal_arg;
3620 (*tail) = formal_arg;
3623 (*tail)->sym = param_sym;
3624 (*tail)->next = NULL;
3630 /* Generates a symbol representing the CPTR argument to an
3631 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3632 CPTR and add it to the provided argument list. */
3635 gen_cptr_param (gfc_formal_arglist **head,
3636 gfc_formal_arglist **tail,
3637 const char *module_name,
3638 gfc_namespace *ns, const char *c_ptr_name,
3641 gfc_symbol *param_sym = NULL;
3642 gfc_symbol *c_ptr_sym = NULL;
3643 gfc_symtree *param_symtree = NULL;
3644 gfc_formal_arglist *formal_arg = NULL;
3645 const char *c_ptr_in;
3646 const char *c_ptr_type = NULL;
3648 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3649 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3651 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3653 if(c_ptr_name == NULL)
3654 c_ptr_in = "gfc_cptr__";
3656 c_ptr_in = c_ptr_name;
3657 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree);
3658 if (param_symtree != NULL)
3659 param_sym = param_symtree->n.sym;
3661 gfc_internal_error ("gen_cptr_param(): Unable to "
3662 "create symbol for %s", c_ptr_in);
3664 /* Set up the appropriate fields for the new c_ptr param sym. */
3666 param_sym->attr.flavor = FL_DERIVED;
3667 param_sym->ts.type = BT_DERIVED;
3668 param_sym->attr.intent = INTENT_IN;
3669 param_sym->attr.dummy = 1;
3671 /* This will pass the ptr to the iso_c routines as a (void *). */
3672 param_sym->attr.value = 1;
3673 param_sym->attr.use_assoc = 1;
3675 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3677 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3678 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3680 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3681 if (c_ptr_sym == NULL)
3683 /* This can happen if the user did not define c_ptr but they are
3684 trying to use one of the iso_c_binding functions that need it. */
3685 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3686 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3687 (const char *)c_ptr_type);
3689 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3690 (const char *)c_ptr_type);
3692 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3695 param_sym->ts.derived = c_ptr_sym;
3696 param_sym->module = gfc_get_string (module_name);
3698 /* Make new formal arg. */
3699 formal_arg = gfc_get_formal_arglist ();
3700 /* Add arg to list of formal args (the CPTR arg). */
3701 add_formal_arg (head, tail, formal_arg, param_sym);
3705 /* Generates a symbol representing the FPTR argument to an
3706 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3707 FPTR and add it to the provided argument list. */
3710 gen_fptr_param (gfc_formal_arglist **head,
3711 gfc_formal_arglist **tail,
3712 const char *module_name,
3713 gfc_namespace *ns, const char *f_ptr_name, int proc)
3715 gfc_symbol *param_sym = NULL;
3716 gfc_symtree *param_symtree = NULL;
3717 gfc_formal_arglist *formal_arg = NULL;
3718 const char *f_ptr_out = "gfc_fptr__";
3720 if (f_ptr_name != NULL)
3721 f_ptr_out = f_ptr_name;
3723 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree);
3724 if (param_symtree != NULL)
3725 param_sym = param_symtree->n.sym;
3727 gfc_internal_error ("generateFPtrParam(): Unable to "
3728 "create symbol for %s", f_ptr_out);
3730 /* Set up the necessary fields for the fptr output param sym. */
3733 param_sym->attr.proc_pointer = 1;
3735 param_sym->attr.pointer = 1;
3736 param_sym->attr.dummy = 1;
3737 param_sym->attr.use_assoc = 1;
3739 /* ISO C Binding type to allow any pointer type as actual param. */
3740 param_sym->ts.type = BT_VOID;
3741 param_sym->module = gfc_get_string (module_name);
3744 formal_arg = gfc_get_formal_arglist ();
3745 /* Add arg to list of formal args. */
3746 add_formal_arg (head, tail, formal_arg, param_sym);
3750 /* Generates a symbol representing the optional SHAPE argument for the
3751 iso_c_binding c_f_pointer() procedure. Also, create a
3752 gfc_formal_arglist for the SHAPE and add it to the provided
3756 gen_shape_param (gfc_formal_arglist **head,
3757 gfc_formal_arglist **tail,
3758 const char *module_name,
3759 gfc_namespace *ns, const char *shape_param_name)
3761 gfc_symbol *param_sym = NULL;
3762 gfc_symtree *param_symtree = NULL;
3763 gfc_formal_arglist *formal_arg = NULL;
3764 const char *shape_param = "gfc_shape_array__";
3767 if (shape_param_name != NULL)
3768 shape_param = shape_param_name;
3770 gfc_get_sym_tree (shape_param, ns, ¶m_symtree);
3771 if (param_symtree != NULL)
3772 param_sym = param_symtree->n.sym;
3774 gfc_internal_error ("generateShapeParam(): Unable to "
3775 "create symbol for %s", shape_param);
3777 /* Set up the necessary fields for the shape input param sym. */
3779 param_sym->attr.dummy = 1;
3780 param_sym->attr.use_assoc = 1;
3782 /* Integer array, rank 1, describing the shape of the object. Make it's
3783 type BT_VOID initially so we can accept any type/kind combination of
3784 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3785 of BT_INTEGER type. */
3786 param_sym->ts.type = BT_VOID;
3788 /* Initialize the kind to default integer. However, it will be overridden
3789 during resolution to match the kind of the SHAPE parameter given as
3790 the actual argument (to allow for any valid integer kind). */
3791 param_sym->ts.kind = gfc_default_integer_kind;
3792 param_sym->as = gfc_get_array_spec ();
3794 /* Clear out the dimension info for the array. */
3795 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3797 param_sym->as->lower[i] = NULL;
3798 param_sym->as->upper[i] = NULL;
3800 param_sym->as->rank = 1;
3801 param_sym->as->lower[0] = gfc_int_expr (1);
3803 /* The extent is unknown until we get it. The length give us
3804 the rank the incoming pointer. */
3805 param_sym->as->type = AS_ASSUMED_SHAPE;
3807 /* The arg is also optional; it is required iff the second arg
3808 (fptr) is to an array, otherwise, it's ignored. */
3809 param_sym->attr.optional = 1;
3810 param_sym->attr.intent = INTENT_IN;
3811 param_sym->attr.dimension = 1;
3812 param_sym->module = gfc_get_string (module_name);
3815 formal_arg = gfc_get_formal_arglist ();
3816 /* Add arg to list of formal args. */
3817 add_formal_arg (head, tail, formal_arg, param_sym);
3821 /* Add a procedure interface to the given symbol (i.e., store a
3822 reference to the list of formal arguments). */
3825 add_proc_interface (gfc_symbol *sym, ifsrc source,
3826 gfc_formal_arglist *formal)
3829 sym->formal = formal;
3830 sym->attr.if_source = source;
3834 /* Copy the formal args from an existing symbol, src, into a new
3835 symbol, dest. New formal args are created, and the description of
3836 each arg is set according to the existing ones. This function is
3837 used when creating procedure declaration variables from a procedure
3838 declaration statement (see match_proc_decl()) to create the formal
3839 args based on the args of a given named interface. */
3842 gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
3844 gfc_formal_arglist *head = NULL;
3845 gfc_formal_arglist *tail = NULL;
3846 gfc_formal_arglist *formal_arg = NULL;
3847 gfc_formal_arglist *curr_arg = NULL;
3848 gfc_formal_arglist *formal_prev = NULL;
3849 /* Save current namespace so we can change it for formal args. */
3850 gfc_namespace *parent_ns = gfc_current_ns;
3852 /* Create a new namespace, which will be the formal ns (namespace
3853 of the formal args). */
3854 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3855 gfc_current_ns->proc_name = dest;
3857 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3859 formal_arg = gfc_get_formal_arglist ();
3860 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
3862 /* May need to copy more info for the symbol. */
3863 formal_arg->sym->attr = curr_arg->sym->attr;
3864 formal_arg->sym->ts = curr_arg->sym->ts;
3865 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
3866 gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
3868 /* If this isn't the first arg, set up the next ptr. For the
3869 last arg built, the formal_arg->next will never get set to
3870 anything other than NULL. */
3871 if (formal_prev != NULL)
3872 formal_prev->next = formal_arg;
3874 formal_arg->next = NULL;
3876 formal_prev = formal_arg;
3878 /* Add arg to list of formal args. */
3879 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3882 /* Add the interface to the symbol. */
3883 add_proc_interface (dest, IFSRC_DECL, head);
3885 /* Store the formal namespace information. */
3886 if (dest->formal != NULL)
3887 /* The current ns should be that for the dest proc. */
3888 dest->formal_ns = gfc_current_ns;
3889 /* Restore the current namespace to what it was on entry. */
3890 gfc_current_ns = parent_ns;
3895 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
3897 gfc_formal_arglist *head = NULL;
3898 gfc_formal_arglist *tail = NULL;
3899 gfc_formal_arglist *formal_arg = NULL;
3900 gfc_intrinsic_arg *curr_arg = NULL;
3901 gfc_formal_arglist *formal_prev = NULL;
3902 /* Save current namespace so we can change it for formal args. */
3903 gfc_namespace *parent_ns = gfc_current_ns;
3905 /* Create a new namespace, which will be the formal ns (namespace
3906 of the formal args). */
3907 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3908 gfc_current_ns->proc_name = dest;
3910 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3912 formal_arg = gfc_get_formal_arglist ();
3913 gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
3915 /* May need to copy more info for the symbol. */
3916 formal_arg->sym->ts = curr_arg->ts;
3917 formal_arg->sym->attr.optional = curr_arg->optional;
3918 formal_arg->sym->attr.flavor = FL_VARIABLE;
3919 formal_arg->sym->attr.dummy = 1;
3921 /* If this isn't the first arg, set up the next ptr. For the
3922 last arg built, the formal_arg->next will never get set to
3923 anything other than NULL. */
3924 if (formal_prev != NULL)
3925 formal_prev->next = formal_arg;
3927 formal_arg->next = NULL;
3929 formal_prev = formal_arg;
3931 /* Add arg to list of formal args. */
3932 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3935 /* Add the interface to the symbol. */
3936 add_proc_interface (dest, IFSRC_DECL, head);
3938 /* Store the formal namespace information. */
3939 if (dest->formal != NULL)
3940 /* The current ns should be that for the dest proc. */
3941 dest->formal_ns = gfc_current_ns;
3942 /* Restore the current namespace to what it was on entry. */
3943 gfc_current_ns = parent_ns;
3947 /* Builds the parameter list for the iso_c_binding procedure
3948 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3949 generic version of either the c_f_pointer or c_f_procpointer
3950 functions. The new_proc_sym represents a "resolved" version of the
3951 symbol. The functions are resolved to match the types of their
3952 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3953 something similar to c_f_pointer_i4 if the type of data object fptr
3954 pointed to was a default integer. The actual name of the resolved
3955 procedure symbol is further mangled with the module name, etc., but
3956 the idea holds true. */
3959 build_formal_args (gfc_symbol *new_proc_sym,
3960 gfc_symbol *old_sym, int add_optional_arg)
3962 gfc_formal_arglist *head = NULL, *tail = NULL;
3963 gfc_namespace *parent_ns = NULL;
3965 parent_ns = gfc_current_ns;
3966 /* Create a new namespace, which will be the formal ns (namespace
3967 of the formal args). */
3968 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
3969 gfc_current_ns->proc_name = new_proc_sym;
3971 /* Generate the params. */
3972 if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
3974 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3975 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3976 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3977 gfc_current_ns, "fptr", 1);
3979 else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3981 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3982 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3983 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3984 gfc_current_ns, "fptr", 0);
3985 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3986 gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
3987 gfc_current_ns, "shape");
3990 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3992 /* c_associated has one required arg and one optional; both
3994 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3995 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
3996 if (add_optional_arg)
3998 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3999 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
4000 /* The last param is optional so mark it as such. */
4001 tail->sym->attr.optional = 1;
4005 /* Add the interface (store formal args to new_proc_sym). */
4006 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
4008 /* Set up the formal_ns pointer to the one created for the
4009 new procedure so it'll get cleaned up during gfc_free_symbol(). */
4010 new_proc_sym->formal_ns = gfc_current_ns;
4012 gfc_current_ns = parent_ns;
4016 std_for_isocbinding_symbol (int id)
4020 #define NAMED_INTCST(a,b,c,d) \
4023 #include "iso-c-binding.def"
4026 return GFC_STD_F2003;
4030 /* Generate the given set of C interoperable kind objects, or all
4031 interoperable kinds. This function will only be given kind objects
4032 for valid iso_c_binding defined types because this is verified when
4033 the 'use' statement is parsed. If the user gives an 'only' clause,
4034 the specific kinds are looked up; if they don't exist, an error is
4035 reported. If the user does not give an 'only' clause, all
4036 iso_c_binding symbols are generated. If a list of specific kinds
4037 is given, it must have a NULL in the first empty spot to mark the
4042 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4043 const char *local_name)
4045 const char *const name = (local_name && local_name[0]) ? local_name
4046 : c_interop_kinds_table[s].name;
4047 gfc_symtree *tmp_symtree = NULL;
4048 gfc_symbol *tmp_sym = NULL;
4049 gfc_dt_list **dt_list_ptr = NULL;
4050 gfc_component *tmp_comp = NULL;
4051 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
4054 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4056 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4058 /* Already exists in this scope so don't re-add it.
4059 TODO: we should probably check that it's really the same symbol. */
4060 if (tmp_symtree != NULL)
4063 /* Create the sym tree in the current ns. */
4064 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
4066 tmp_sym = tmp_symtree->n.sym;
4068 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4071 /* Say what module this symbol belongs to. */
4072 tmp_sym->module = gfc_get_string (mod_name);
4073 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4074 tmp_sym->intmod_sym_id = s;
4079 #define NAMED_INTCST(a,b,c,d) case a :
4080 #define NAMED_REALCST(a,b,c) case a :
4081 #define NAMED_CMPXCST(a,b,c) case a :
4082 #define NAMED_LOGCST(a,b,c) case a :
4083 #define NAMED_CHARKNDCST(a,b,c) case a :
4084 #include "iso-c-binding.def"
4086 tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
4088 /* Initialize an integer constant expression node. */
4089 tmp_sym->attr.flavor = FL_PARAMETER;
4090 tmp_sym->ts.type = BT_INTEGER;
4091 tmp_sym->ts.kind = gfc_default_integer_kind;
4093 /* Mark this type as a C interoperable one. */
4094 tmp_sym->ts.is_c_interop = 1;
4095 tmp_sym->ts.is_iso_c = 1;
4096 tmp_sym->value->ts.is_c_interop = 1;
4097 tmp_sym->value->ts.is_iso_c = 1;
4098 tmp_sym->attr.is_c_interop = 1;
4100 /* Tell what f90 type this c interop kind is valid. */
4101 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4103 /* Say it's from the iso_c_binding module. */
4104 tmp_sym->attr.is_iso_c = 1;
4106 /* Make it use associated. */
4107 tmp_sym->attr.use_assoc = 1;
4111 #define NAMED_CHARCST(a,b,c) case a :
4112 #include "iso-c-binding.def"
4114 /* Initialize an integer constant expression node for the
4115 length of the character. */
4116 tmp_sym->value = gfc_get_expr ();
4117 tmp_sym->value->expr_type = EXPR_CONSTANT;
4118 tmp_sym->value->ts.type = BT_CHARACTER;
4119 tmp_sym->value->ts.kind = gfc_default_character_kind;
4120 tmp_sym->value->where = gfc_current_locus;
4121 tmp_sym->value->ts.is_c_interop = 1;
4122 tmp_sym->value->ts.is_iso_c = 1;
4123 tmp_sym->value->value.character.length = 1;
4124 tmp_sym->value->value.character.string = gfc_get_wide_string (2);
4125 tmp_sym->value->value.character.string[0]
4126 = (gfc_char_t) c_interop_kinds_table[s].value;
4127 tmp_sym->value->value.character.string[1] = '\0';
4128 tmp_sym->ts.cl = gfc_get_charlen ();
4129 tmp_sym->ts.cl->length = gfc_int_expr (1);
4131 /* May not need this in both attr and ts, but do need in
4132 attr for writing module file. */
4133 tmp_sym->attr.is_c_interop = 1;
4135 tmp_sym->attr.flavor = FL_PARAMETER;
4136 tmp_sym->ts.type = BT_CHARACTER;
4138 /* Need to set it to the C_CHAR kind. */
4139 tmp_sym->ts.kind = gfc_default_character_kind;
4141 /* Mark this type as a C interoperable one. */
4142 tmp_sym->ts.is_c_interop = 1;
4143 tmp_sym->ts.is_iso_c = 1;
4145 /* Tell what f90 type this c interop kind is valid. */
4146 tmp_sym->ts.f90_type = BT_CHARACTER;
4148 /* Say it's from the iso_c_binding module. */
4149 tmp_sym->attr.is_iso_c = 1;
4151 /* Make it use associated. */
4152 tmp_sym->attr.use_assoc = 1;
4155 case ISOCBINDING_PTR:
4156 case ISOCBINDING_FUNPTR:
4158 /* Initialize an integer constant expression node. */
4159 tmp_sym->attr.flavor = FL_DERIVED;
4160 tmp_sym->ts.is_c_interop = 1;
4161 tmp_sym->attr.is_c_interop = 1;
4162 tmp_sym->attr.is_iso_c = 1;
4163 tmp_sym->ts.is_iso_c = 1;
4164 tmp_sym->ts.type = BT_DERIVED;
4166 /* A derived type must have the bind attribute to be
4167 interoperable (J3/04-007, Section 15.2.3), even though
4168 the binding label is not used. */
4169 tmp_sym->attr.is_bind_c = 1;
4171 tmp_sym->attr.referenced = 1;
4173 tmp_sym->ts.derived = tmp_sym;
4175 /* Add the symbol created for the derived type to the current ns. */
4176 dt_list_ptr = &(gfc_derived_types);
4177 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4178 dt_list_ptr = &((*dt_list_ptr)->next);
4180 /* There is already at least one derived type in the list, so append
4181 the one we're currently building for c_ptr or c_funptr. */
4182 if (*dt_list_ptr != NULL)
4183 dt_list_ptr = &((*dt_list_ptr)->next);
4184 (*dt_list_ptr) = gfc_get_dt_list ();
4185 (*dt_list_ptr)->derived = tmp_sym;
4186 (*dt_list_ptr)->next = NULL;
4188 /* Set up the component of the derived type, which will be
4189 an integer with kind equal to c_ptr_size. Mangle the name of
4190 the field for the c_address to prevent the curious user from
4191 trying to access it from Fortran. */
4192 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
4193 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
4194 if (tmp_comp == NULL)
4195 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4196 "create component for c_address");
4198 tmp_comp->ts.type = BT_INTEGER;
4200 /* Set this because the module will need to read/write this field. */
4201 tmp_comp->ts.f90_type = BT_INTEGER;
4203 /* The kinds for c_ptr and c_funptr are the same. */
4204 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4205 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4207 tmp_comp->attr.pointer = 0;
4208 tmp_comp->attr.dimension = 0;
4210 /* Mark the component as C interoperable. */
4211 tmp_comp->ts.is_c_interop = 1;
4213 /* Make it use associated (iso_c_binding module). */
4214 tmp_sym->attr.use_assoc = 1;
4217 case ISOCBINDING_NULL_PTR:
4218 case ISOCBINDING_NULL_FUNPTR:
4219 gen_special_c_interop_ptr (s, name, mod_name);
4222 case ISOCBINDING_F_POINTER:
4223 case ISOCBINDING_ASSOCIATED:
4224 case ISOCBINDING_LOC:
4225 case ISOCBINDING_FUNLOC:
4226 case ISOCBINDING_F_PROCPOINTER:
4228 tmp_sym->attr.proc = PROC_MODULE;
4230 /* Use the procedure's name as it is in the iso_c_binding module for
4231 setting the binding label in case the user renamed the symbol. */
4232 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
4233 c_interop_kinds_table[s].name);
4234 tmp_sym->attr.is_iso_c = 1;
4235 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4236 tmp_sym->attr.subroutine = 1;
4239 /* TODO! This needs to be finished more for the expr of the
4240 function or something!
4241 This may not need to be here, because trying to do c_loc
4243 if (s == ISOCBINDING_ASSOCIATED)
4245 tmp_sym->attr.function = 1;
4246 tmp_sym->ts.type = BT_LOGICAL;
4247 tmp_sym->ts.kind = gfc_default_logical_kind;
4248 tmp_sym->result = tmp_sym;
4252 /* Here, we're taking the simple approach. We're defining
4253 c_loc as an external identifier so the compiler will put
4254 what we expect on the stack for the address we want the
4256 tmp_sym->ts.type = BT_DERIVED;
4257 if (s == ISOCBINDING_LOC)
4258 tmp_sym->ts.derived =
4259 get_iso_c_binding_dt (ISOCBINDING_PTR);
4261 tmp_sym->ts.derived =
4262 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4264 if (tmp_sym->ts.derived == NULL)
4266 /* Create the necessary derived type so we can continue
4267 processing the file. */
4268 generate_isocbinding_symbol
4269 (mod_name, s == ISOCBINDING_FUNLOC
4270 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4271 (const char *)(s == ISOCBINDING_FUNLOC
4272 ? "_gfortran_iso_c_binding_c_funptr"
4273 : "_gfortran_iso_c_binding_c_ptr"));
4274 tmp_sym->ts.derived =
4275 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4276 ? ISOCBINDING_FUNPTR
4280 /* The function result is itself (no result clause). */
4281 tmp_sym->result = tmp_sym;
4282 tmp_sym->attr.external = 1;
4283 tmp_sym->attr.use_assoc = 0;
4284 tmp_sym->attr.pure = 1;
4285 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4286 tmp_sym->attr.proc = PROC_UNKNOWN;
4290 tmp_sym->attr.flavor = FL_PROCEDURE;
4291 tmp_sym->attr.contained = 0;
4293 /* Try using this builder routine, with the new and old symbols
4294 both being the generic iso_c proc sym being created. This
4295 will create the formal args (and the new namespace for them).
4296 Don't build an arg list for c_loc because we're going to treat
4297 c_loc as an external procedure. */
4298 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4299 /* The 1 says to add any optional args, if applicable. */
4300 build_formal_args (tmp_sym, tmp_sym, 1);
4302 /* Set this after setting up the symbol, to prevent error messages. */
4303 tmp_sym->attr.use_assoc = 1;
4305 /* This symbol will not be referenced directly. It will be
4306 resolved to the implementation for the given f90 kind. */
4307 tmp_sym->attr.referenced = 0;
4317 /* Creates a new symbol based off of an old iso_c symbol, with a new
4318 binding label. This function can be used to create a new,
4319 resolved, version of a procedure symbol for c_f_pointer or
4320 c_f_procpointer that is based on the generic symbols. A new
4321 parameter list is created for the new symbol using
4322 build_formal_args(). The add_optional_flag specifies whether the
4323 to add the optional SHAPE argument. The new symbol is
4327 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4328 char *new_binding_label, int add_optional_arg)
4330 gfc_symtree *new_symtree = NULL;
4332 /* See if we have a symbol by that name already available, looking
4333 through any parent namespaces. */
4334 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4335 if (new_symtree != NULL)
4336 /* Return the existing symbol. */
4337 return new_symtree->n.sym;
4339 /* Create the symtree/symbol, with attempted host association. */
4340 gfc_get_ha_sym_tree (new_name, &new_symtree);
4341 if (new_symtree == NULL)
4342 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4343 "symtree for '%s'", new_name);
4345 /* Now fill in the fields of the resolved symbol with the old sym. */
4346 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4347 new_symtree->n.sym->attr = old_sym->attr;
4348 new_symtree->n.sym->ts = old_sym->ts;
4349 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4350 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4351 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4352 /* Build the formal arg list. */
4353 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4355 gfc_commit_symbol (new_symtree->n.sym);
4357 return new_symtree->n.sym;
4361 /* Check that a symbol is already typed. If strict is not set, an untyped
4362 symbol is acceptable for non-standard-conforming mode. */
4365 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4366 bool strict, locus where)
4370 if (gfc_matching_prefix)
4373 /* Check for the type and try to give it an implicit one. */
4374 if (sym->ts.type == BT_UNKNOWN
4375 && gfc_set_default_type (sym, 0, ns) == FAILURE)
4379 gfc_error ("Symbol '%s' is used before it is typed at %L",
4384 if (gfc_notify_std (GFC_STD_GNU,
4385 "Extension: Symbol '%s' is used before"
4386 " it is typed at %L", sym->name, &where) == FAILURE)
4390 /* Everything is ok. */
4395 /* Construct a typebound-procedure structure. Those are stored in a tentative
4396 list and marked `error' until symbols are committed. */
4399 gfc_get_typebound_proc (void)
4401 gfc_typebound_proc *result;
4402 tentative_tbp *list_node;
4404 result = XCNEW (gfc_typebound_proc);
4407 list_node = XCNEW (tentative_tbp);
4408 list_node->next = tentative_tbp_list;
4409 list_node->proc = result;
4410 tentative_tbp_list = list_node;
4416 /* Get the super-type of a given derived type. */
4419 gfc_get_derived_super_type (gfc_symbol* derived)
4421 if (!derived->attr.extension)
4424 gcc_assert (derived->components);
4425 gcc_assert (derived->components->ts.type == BT_DERIVED);
4426 gcc_assert (derived->components->ts.derived);
4428 return derived->components->ts.derived;
4432 /* Find a type-bound procedure by name for a derived-type (looking recursively
4433 through the super-types). */
4436 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
4437 const char* name, bool noaccess)
4441 /* Set default to failure. */
4445 /* Try to find it in the current type's namespace. */
4446 gcc_assert (derived->f2k_derived);
4447 res = gfc_find_symtree (derived->f2k_derived->tb_sym_root, name);
4448 if (res && res->n.tb)
4454 if (!noaccess && derived->attr.use_assoc
4455 && res->n.tb->access == ACCESS_PRIVATE)
4457 gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
4465 /* Otherwise, recurse on parent type if derived is an extension. */
4466 if (derived->attr.extension)
4468 gfc_symbol* super_type;
4469 super_type = gfc_get_derived_super_type (derived);
4470 gcc_assert (super_type);
4471 return gfc_find_typebound_proc (super_type, t, name, noaccess);
4474 /* Nothing found. */
4479 /* Get a typebound-procedure symtree or create and insert it if not yet
4480 present. This is like a very simplified version of gfc_get_sym_tree for
4481 tbp-symtrees rather than regular ones. */
4484 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
4486 gfc_symtree *result;
4488 result = gfc_find_symtree (*root, name);
4491 result = gfc_new_symtree (root, name);
4492 gcc_assert (result);
4493 result->n.tb = NULL;