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 (gfc_symbol *sym, gfc_namespace *ns)
226 letter = sym->name[0];
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'",sym->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, 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;
1788 /* Recursive function to switch derived types of all symbol in a
1792 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1800 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1801 sym->ts.derived = to;
1803 switch_types (st->left, from, to);
1804 switch_types (st->right, from, to);
1808 /* This subroutine is called when a derived type is used in order to
1809 make the final determination about which version to use. The
1810 standard requires that a type be defined before it is 'used', but
1811 such types can appear in IMPLICIT statements before the actual
1812 definition. 'Using' in this context means declaring a variable to
1813 be that type or using the type constructor.
1815 If a type is used and the components haven't been defined, then we
1816 have to have a derived type in a parent unit. We find the node in
1817 the other namespace and point the symtree node in this namespace to
1818 that node. Further reference to this name point to the correct
1819 node. If we can't find the node in a parent namespace, then we have
1822 This subroutine takes a pointer to a symbol node and returns a
1823 pointer to the translated node or NULL for an error. Usually there
1824 is no translation and we return the node we were passed. */
1827 gfc_use_derived (gfc_symbol *sym)
1834 if (sym->components != NULL || sym->attr.zero_comp)
1835 return sym; /* Already defined. */
1837 if (sym->ns->parent == NULL)
1840 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1842 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1846 if (s == NULL || s->attr.flavor != FL_DERIVED)
1849 /* Get rid of symbol sym, translating all references to s. */
1850 for (i = 0; i < GFC_LETTERS; i++)
1852 t = &sym->ns->default_type[i];
1853 if (t->derived == sym)
1857 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1862 /* Unlink from list of modified symbols. */
1863 gfc_commit_symbol (sym);
1865 switch_types (sym->ns->sym_root, sym, s);
1867 /* TODO: Also have to replace sym -> s in other lists like
1868 namelists, common lists and interface lists. */
1869 gfc_free_symbol (sym);
1874 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1880 /* Given a derived type node and a component name, try to locate the
1881 component structure. Returns the NULL pointer if the component is
1882 not found or the components are private. If noaccess is set, no access
1886 gfc_find_component (gfc_symbol *sym, const char *name,
1887 bool noaccess, bool silent)
1894 sym = gfc_use_derived (sym);
1899 for (p = sym->components; p; p = p->next)
1900 if (strcmp (p->name, name) == 0)
1904 && sym->attr.extension
1905 && sym->components->ts.type == BT_DERIVED)
1907 p = gfc_find_component (sym->components->ts.derived, name,
1909 /* Do not overwrite the error. */
1914 if (p == NULL && !silent)
1915 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1918 else if (sym->attr.use_assoc && !noaccess)
1920 if (p->attr.access == ACCESS_PRIVATE)
1923 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1928 /* If there were components given and all components are private, error
1929 out at this place. */
1930 if (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
1933 gfc_error ("All components of '%s' are PRIVATE in structure"
1934 " constructor at %C", sym->name);
1943 /* Given a symbol, free all of the component structures and everything
1947 free_components (gfc_component *p)
1955 gfc_free_array_spec (p->as);
1956 gfc_free_expr (p->initializer);
1963 /******************** Statement label management ********************/
1965 /* Comparison function for statement labels, used for managing the
1969 compare_st_labels (void *a1, void *b1)
1971 int a = ((gfc_st_label *) a1)->value;
1972 int b = ((gfc_st_label *) b1)->value;
1978 /* Free a single gfc_st_label structure, making sure the tree is not
1979 messed up. This function is called only when some parse error
1983 gfc_free_st_label (gfc_st_label *label)
1989 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
1991 if (label->format != NULL)
1992 gfc_free_expr (label->format);
1998 /* Free a whole tree of gfc_st_label structures. */
2001 free_st_labels (gfc_st_label *label)
2007 free_st_labels (label->left);
2008 free_st_labels (label->right);
2010 if (label->format != NULL)
2011 gfc_free_expr (label->format);
2016 /* Given a label number, search for and return a pointer to the label
2017 structure, creating it if it does not exist. */
2020 gfc_get_st_label (int labelno)
2024 /* First see if the label is already in this namespace. */
2025 lp = gfc_current_ns->st_labels;
2028 if (lp->value == labelno)
2031 if (lp->value < labelno)
2037 lp = XCNEW (gfc_st_label);
2039 lp->value = labelno;
2040 lp->defined = ST_LABEL_UNKNOWN;
2041 lp->referenced = ST_LABEL_UNKNOWN;
2043 gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
2049 /* Called when a statement with a statement label is about to be
2050 accepted. We add the label to the list of the current namespace,
2051 making sure it hasn't been defined previously and referenced
2055 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2059 labelno = lp->value;
2061 if (lp->defined != ST_LABEL_UNKNOWN)
2062 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2063 &lp->where, label_locus);
2066 lp->where = *label_locus;
2070 case ST_LABEL_FORMAT:
2071 if (lp->referenced == ST_LABEL_TARGET)
2072 gfc_error ("Label %d at %C already referenced as branch target",
2075 lp->defined = ST_LABEL_FORMAT;
2079 case ST_LABEL_TARGET:
2080 if (lp->referenced == ST_LABEL_FORMAT)
2081 gfc_error ("Label %d at %C already referenced as a format label",
2084 lp->defined = ST_LABEL_TARGET;
2089 lp->defined = ST_LABEL_BAD_TARGET;
2090 lp->referenced = ST_LABEL_BAD_TARGET;
2096 /* Reference a label. Given a label and its type, see if that
2097 reference is consistent with what is known about that label,
2098 updating the unknown state. Returns FAILURE if something goes
2102 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2104 gfc_sl_type label_type;
2111 labelno = lp->value;
2113 if (lp->defined != ST_LABEL_UNKNOWN)
2114 label_type = lp->defined;
2117 label_type = lp->referenced;
2118 lp->where = gfc_current_locus;
2121 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2123 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2128 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2129 && type == ST_LABEL_FORMAT)
2131 gfc_error ("Label %d at %C previously used as branch target", labelno);
2136 lp->referenced = type;
2144 /*******A helper function for creating new expressions*************/
2148 gfc_lval_expr_from_sym (gfc_symbol *sym)
2151 lval = gfc_get_expr ();
2152 lval->expr_type = EXPR_VARIABLE;
2153 lval->where = sym->declared_at;
2155 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2157 /* It will always be a full array. */
2158 lval->rank = sym->as ? sym->as->rank : 0;
2161 lval->ref = gfc_get_ref ();
2162 lval->ref->type = REF_ARRAY;
2163 lval->ref->u.ar.type = AR_FULL;
2164 lval->ref->u.ar.dimen = lval->rank;
2165 lval->ref->u.ar.where = sym->declared_at;
2166 lval->ref->u.ar.as = sym->as;
2173 /************** Symbol table management subroutines ****************/
2175 /* Basic details: Fortran 95 requires a potentially unlimited number
2176 of distinct namespaces when compiling a program unit. This case
2177 occurs during a compilation of internal subprograms because all of
2178 the internal subprograms must be read before we can start
2179 generating code for the host.
2181 Given the tricky nature of the Fortran grammar, we must be able to
2182 undo changes made to a symbol table if the current interpretation
2183 of a statement is found to be incorrect. Whenever a symbol is
2184 looked up, we make a copy of it and link to it. All of these
2185 symbols are kept in a singly linked list so that we can commit or
2186 undo the changes at a later time.
2188 A symtree may point to a symbol node outside of its namespace. In
2189 this case, that symbol has been used as a host associated variable
2190 at some previous time. */
2192 /* Allocate a new namespace structure. Copies the implicit types from
2193 PARENT if PARENT_TYPES is set. */
2196 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2200 gfc_intrinsic_op in;
2203 ns = XCNEW (gfc_namespace);
2204 ns->sym_root = NULL;
2205 ns->uop_root = NULL;
2206 ns->tb_sym_root = NULL;
2207 ns->finalizers = NULL;
2208 ns->default_access = ACCESS_UNKNOWN;
2209 ns->parent = parent;
2211 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2212 ns->operator_access[in] = ACCESS_UNKNOWN;
2214 /* Initialize default implicit types. */
2215 for (i = 'a'; i <= 'z'; i++)
2217 ns->set_flag[i - 'a'] = 0;
2218 ts = &ns->default_type[i - 'a'];
2220 if (parent_types && ns->parent != NULL)
2222 /* Copy parent settings. */
2223 *ts = ns->parent->default_type[i - 'a'];
2227 if (gfc_option.flag_implicit_none != 0)
2233 if ('i' <= i && i <= 'n')
2235 ts->type = BT_INTEGER;
2236 ts->kind = gfc_default_integer_kind;
2241 ts->kind = gfc_default_real_kind;
2251 /* Comparison function for symtree nodes. */
2254 compare_symtree (void *_st1, void *_st2)
2256 gfc_symtree *st1, *st2;
2258 st1 = (gfc_symtree *) _st1;
2259 st2 = (gfc_symtree *) _st2;
2261 return strcmp (st1->name, st2->name);
2265 /* Allocate a new symtree node and associate it with the new symbol. */
2268 gfc_new_symtree (gfc_symtree **root, const char *name)
2272 st = XCNEW (gfc_symtree);
2273 st->name = gfc_get_string (name);
2275 gfc_insert_bbt (root, st, compare_symtree);
2280 /* Delete a symbol from the tree. Does not free the symbol itself! */
2283 gfc_delete_symtree (gfc_symtree **root, const char *name)
2285 gfc_symtree st, *st0;
2287 st0 = gfc_find_symtree (*root, name);
2289 st.name = gfc_get_string (name);
2290 gfc_delete_bbt (root, &st, compare_symtree);
2296 /* Given a root symtree node and a name, try to find the symbol within
2297 the namespace. Returns NULL if the symbol is not found. */
2300 gfc_find_symtree (gfc_symtree *st, const char *name)
2306 c = strcmp (name, st->name);
2310 st = (c < 0) ? st->left : st->right;
2317 /* Return a symtree node with a name that is guaranteed to be unique
2318 within the namespace and corresponds to an illegal fortran name. */
2321 gfc_get_unique_symtree (gfc_namespace *ns)
2323 char name[GFC_MAX_SYMBOL_LEN + 1];
2324 static int serial = 0;
2326 sprintf (name, "@%d", serial++);
2327 return gfc_new_symtree (&ns->sym_root, name);
2331 /* Given a name find a user operator node, creating it if it doesn't
2332 exist. These are much simpler than symbols because they can't be
2333 ambiguous with one another. */
2336 gfc_get_uop (const char *name)
2341 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2345 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2347 uop = st->n.uop = XCNEW (gfc_user_op);
2348 uop->name = gfc_get_string (name);
2349 uop->access = ACCESS_UNKNOWN;
2350 uop->ns = gfc_current_ns;
2356 /* Given a name find the user operator node. Returns NULL if it does
2360 gfc_find_uop (const char *name, gfc_namespace *ns)
2365 ns = gfc_current_ns;
2367 st = gfc_find_symtree (ns->uop_root, name);
2368 return (st == NULL) ? NULL : st->n.uop;
2372 /* Remove a gfc_symbol structure and everything it points to. */
2375 gfc_free_symbol (gfc_symbol *sym)
2381 gfc_free_array_spec (sym->as);
2383 free_components (sym->components);
2385 gfc_free_expr (sym->value);
2387 gfc_free_namelist (sym->namelist);
2389 gfc_free_namespace (sym->formal_ns);
2391 if (!sym->attr.generic_copy)
2392 gfc_free_interface (sym->generic);
2394 gfc_free_formal_arglist (sym->formal);
2396 gfc_free_namespace (sym->f2k_derived);
2402 /* Allocate and initialize a new symbol node. */
2405 gfc_new_symbol (const char *name, gfc_namespace *ns)
2409 p = XCNEW (gfc_symbol);
2411 gfc_clear_ts (&p->ts);
2412 gfc_clear_attr (&p->attr);
2415 p->declared_at = gfc_current_locus;
2417 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2418 gfc_internal_error ("new_symbol(): Symbol name too long");
2420 p->name = gfc_get_string (name);
2422 /* Make sure flags for symbol being C bound are clear initially. */
2423 p->attr.is_bind_c = 0;
2424 p->attr.is_iso_c = 0;
2425 /* Make sure the binding label field has a Nul char to start. */
2426 p->binding_label[0] = '\0';
2428 /* Clear the ptrs we may need. */
2429 p->common_block = NULL;
2430 p->f2k_derived = NULL;
2436 /* Generate an error if a symbol is ambiguous. */
2439 ambiguous_symbol (const char *name, gfc_symtree *st)
2442 if (st->n.sym->module)
2443 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2444 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2446 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2447 "from current program unit", name, st->n.sym->name);
2451 /* Search for a symtree starting in the current namespace, resorting to
2452 any parent namespaces if requested by a nonzero parent_flag.
2453 Returns nonzero if the name is ambiguous. */
2456 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2457 gfc_symtree **result)
2462 ns = gfc_current_ns;
2466 st = gfc_find_symtree (ns->sym_root, name);
2470 /* Ambiguous generic interfaces are permitted, as long
2471 as the specific interfaces are different. */
2472 if (st->ambiguous && !st->n.sym->attr.generic)
2474 ambiguous_symbol (name, st);
2493 /* Same, but returns the symbol instead. */
2496 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2497 gfc_symbol **result)
2502 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2507 *result = st->n.sym;
2513 /* Save symbol with the information necessary to back it out. */
2516 save_symbol_data (gfc_symbol *sym)
2519 if (sym->gfc_new || sym->old_symbol != NULL)
2522 sym->old_symbol = XCNEW (gfc_symbol);
2523 *(sym->old_symbol) = *sym;
2525 sym->tlink = changed_syms;
2530 /* Given a name, find a symbol, or create it if it does not exist yet
2531 in the current namespace. If the symbol is found we make sure that
2534 The integer return code indicates
2536 1 The symbol name was ambiguous
2537 2 The name meant to be established was already host associated.
2539 So if the return value is nonzero, then an error was issued. */
2542 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
2547 /* This doesn't usually happen during resolution. */
2549 ns = gfc_current_ns;
2551 /* Try to find the symbol in ns. */
2552 st = gfc_find_symtree (ns->sym_root, name);
2556 /* If not there, create a new symbol. */
2557 p = gfc_new_symbol (name, ns);
2559 /* Add to the list of tentative symbols. */
2560 p->old_symbol = NULL;
2561 p->tlink = changed_syms;
2566 st = gfc_new_symtree (&ns->sym_root, name);
2573 /* Make sure the existing symbol is OK. Ambiguous
2574 generic interfaces are permitted, as long as the
2575 specific interfaces are different. */
2576 if (st->ambiguous && !st->n.sym->attr.generic)
2578 ambiguous_symbol (name, st);
2584 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2586 && ns->proc_name->attr.if_source == IFSRC_IFBODY
2587 && (ns->has_import_set || p->attr.imported)))
2589 /* Symbol is from another namespace. */
2590 gfc_error ("Symbol '%s' at %C has already been host associated",
2597 /* Copy in case this symbol is changed. */
2598 save_symbol_data (p);
2607 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2612 i = gfc_get_sym_tree (name, ns, &st);
2617 *result = st->n.sym;
2624 /* Subroutine that searches for a symbol, creating it if it doesn't
2625 exist, but tries to host-associate the symbol if possible. */
2628 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2633 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2636 save_symbol_data (st->n.sym);
2641 if (gfc_current_ns->parent != NULL)
2643 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2654 return gfc_get_sym_tree (name, gfc_current_ns, result);
2659 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2664 i = gfc_get_ha_sym_tree (name, &st);
2667 *result = st->n.sym;
2674 /* Return true if both symbols could refer to the same data object. Does
2675 not take account of aliasing due to equivalence statements. */
2678 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2680 /* Aliasing isn't possible if the symbols have different base types. */
2681 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2684 /* Pointers can point to other pointers, target objects and allocatable
2685 objects. Two allocatable objects cannot share the same storage. */
2686 if (lsym->attr.pointer
2687 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2689 if (lsym->attr.target && rsym->attr.pointer)
2691 if (lsym->attr.allocatable && rsym->attr.pointer)
2698 /* Undoes all the changes made to symbols in the current statement.
2699 This subroutine is made simpler due to the fact that attributes are
2700 never removed once added. */
2703 gfc_undo_symbols (void)
2705 gfc_symbol *p, *q, *old;
2706 tentative_tbp *tbp, *tbq;
2708 for (p = changed_syms; p; p = q)
2714 /* Symbol was new. */
2715 if (p->attr.in_common && p->common_block->head)
2717 /* If the symbol was added to any common block, it
2718 needs to be removed to stop the resolver looking
2719 for a (possibly) dead symbol. */
2721 if (p->common_block->head == p)
2722 p->common_block->head = p->common_next;
2725 gfc_symbol *cparent, *csym;
2727 cparent = p->common_block->head;
2728 csym = cparent->common_next;
2733 csym = csym->common_next;
2736 gcc_assert(cparent->common_next == p);
2738 cparent->common_next = csym->common_next;
2742 gfc_delete_symtree (&p->ns->sym_root, p->name);
2746 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2748 gfc_free_symbol (p);
2752 /* Restore previous state of symbol. Just copy simple stuff. */
2754 old = p->old_symbol;
2756 p->ts.type = old->ts.type;
2757 p->ts.kind = old->ts.kind;
2759 p->attr = old->attr;
2761 if (p->value != old->value)
2763 gfc_free_expr (old->value);
2767 if (p->as != old->as)
2770 gfc_free_array_spec (p->as);
2774 p->generic = old->generic;
2775 p->component_access = old->component_access;
2777 if (p->namelist != NULL && old->namelist == NULL)
2779 gfc_free_namelist (p->namelist);
2784 if (p->namelist_tail != old->namelist_tail)
2786 gfc_free_namelist (old->namelist_tail);
2787 old->namelist_tail->next = NULL;
2791 p->namelist_tail = old->namelist_tail;
2793 if (p->formal != old->formal)
2795 gfc_free_formal_arglist (p->formal);
2796 p->formal = old->formal;
2799 gfc_free (p->old_symbol);
2800 p->old_symbol = NULL;
2804 changed_syms = NULL;
2806 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2809 /* Procedure is already marked `error' by default. */
2812 tentative_tbp_list = NULL;
2816 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2817 components of old_symbol that might need deallocation are the "allocatables"
2818 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2819 namelist_tail. In case these differ between old_symbol and sym, it's just
2820 because sym->namelist has gotten a few more items. */
2823 free_old_symbol (gfc_symbol *sym)
2826 if (sym->old_symbol == NULL)
2829 if (sym->old_symbol->as != sym->as)
2830 gfc_free_array_spec (sym->old_symbol->as);
2832 if (sym->old_symbol->value != sym->value)
2833 gfc_free_expr (sym->old_symbol->value);
2835 if (sym->old_symbol->formal != sym->formal)
2836 gfc_free_formal_arglist (sym->old_symbol->formal);
2838 gfc_free (sym->old_symbol);
2839 sym->old_symbol = NULL;
2843 /* Makes the changes made in the current statement permanent-- gets
2844 rid of undo information. */
2847 gfc_commit_symbols (void)
2850 tentative_tbp *tbp, *tbq;
2852 for (p = changed_syms; p; p = q)
2858 free_old_symbol (p);
2860 changed_syms = NULL;
2862 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2865 tbp->proc->error = 0;
2868 tentative_tbp_list = NULL;
2872 /* Makes the changes made in one symbol permanent -- gets rid of undo
2876 gfc_commit_symbol (gfc_symbol *sym)
2880 if (changed_syms == sym)
2881 changed_syms = sym->tlink;
2884 for (p = changed_syms; p; p = p->tlink)
2885 if (p->tlink == sym)
2887 p->tlink = sym->tlink;
2896 free_old_symbol (sym);
2900 /* Recursively free trees containing type-bound procedures. */
2903 free_tb_tree (gfc_symtree *t)
2908 free_tb_tree (t->left);
2909 free_tb_tree (t->right);
2911 /* TODO: Free type-bound procedure structs themselves; probably needs some
2912 sort of ref-counting mechanism. */
2918 /* Recursive function that deletes an entire tree and all the common
2919 head structures it points to. */
2922 free_common_tree (gfc_symtree * common_tree)
2924 if (common_tree == NULL)
2927 free_common_tree (common_tree->left);
2928 free_common_tree (common_tree->right);
2930 gfc_free (common_tree);
2934 /* Recursive function that deletes an entire tree and all the user
2935 operator nodes that it contains. */
2938 free_uop_tree (gfc_symtree *uop_tree)
2941 if (uop_tree == NULL)
2944 free_uop_tree (uop_tree->left);
2945 free_uop_tree (uop_tree->right);
2947 gfc_free_interface (uop_tree->n.uop->op);
2949 gfc_free (uop_tree->n.uop);
2950 gfc_free (uop_tree);
2954 /* Recursive function that deletes an entire tree and all the symbols
2955 that it contains. */
2958 free_sym_tree (gfc_symtree *sym_tree)
2963 if (sym_tree == NULL)
2966 free_sym_tree (sym_tree->left);
2967 free_sym_tree (sym_tree->right);
2969 sym = sym_tree->n.sym;
2973 gfc_internal_error ("free_sym_tree(): Negative refs");
2975 if (sym->formal_ns != NULL && sym->refs == 1)
2977 /* As formal_ns contains a reference to sym, delete formal_ns just
2978 before the deletion of sym. */
2979 ns = sym->formal_ns;
2980 sym->formal_ns = NULL;
2981 gfc_free_namespace (ns);
2983 else if (sym->refs == 0)
2985 /* Go ahead and delete the symbol. */
2986 gfc_free_symbol (sym);
2989 gfc_free (sym_tree);
2993 /* Free the derived type list. */
2996 gfc_free_dt_list (void)
2998 gfc_dt_list *dt, *n;
3000 for (dt = gfc_derived_types; dt; dt = n)
3006 gfc_derived_types = NULL;
3010 /* Free the gfc_equiv_info's. */
3013 gfc_free_equiv_infos (gfc_equiv_info *s)
3017 gfc_free_equiv_infos (s->next);
3022 /* Free the gfc_equiv_lists. */
3025 gfc_free_equiv_lists (gfc_equiv_list *l)
3029 gfc_free_equiv_lists (l->next);
3030 gfc_free_equiv_infos (l->equiv);
3035 /* Free a finalizer procedure list. */
3038 gfc_free_finalizer (gfc_finalizer* el)
3044 --el->proc_sym->refs;
3045 if (!el->proc_sym->refs)
3046 gfc_free_symbol (el->proc_sym);
3054 gfc_free_finalizer_list (gfc_finalizer* list)
3058 gfc_finalizer* current = list;
3060 gfc_free_finalizer (current);
3065 /* Free the charlen list from cl to end (end is not freed).
3066 Free the whole list if end is NULL. */
3068 void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3072 for (; cl != end; cl = cl2)
3077 gfc_free_expr (cl->length);
3083 /* Free a namespace structure and everything below it. Interface
3084 lists associated with intrinsic operators are not freed. These are
3085 taken care of when a specific name is freed. */
3088 gfc_free_namespace (gfc_namespace *ns)
3090 gfc_namespace *p, *q;
3099 gcc_assert (ns->refs == 0);
3101 gfc_free_statements (ns->code);
3103 free_sym_tree (ns->sym_root);
3104 free_uop_tree (ns->uop_root);
3105 free_common_tree (ns->common_root);
3106 free_tb_tree (ns->tb_sym_root);
3107 gfc_free_finalizer_list (ns->finalizers);
3108 gfc_free_charlen (ns->cl_list, NULL);
3109 free_st_labels (ns->st_labels);
3111 gfc_free_equiv (ns->equiv);
3112 gfc_free_equiv_lists (ns->equiv_lists);
3113 gfc_free_use_stmts (ns->use_stmts);
3115 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3116 gfc_free_interface (ns->op[i]);
3118 gfc_free_data (ns->data);
3122 /* Recursively free any contained namespaces. */
3127 gfc_free_namespace (q);
3133 gfc_symbol_init_2 (void)
3136 gfc_current_ns = gfc_get_namespace (NULL, 0);
3141 gfc_symbol_done_2 (void)
3144 gfc_free_namespace (gfc_current_ns);
3145 gfc_current_ns = NULL;
3146 gfc_free_dt_list ();
3150 /* Clear mark bits from symbol nodes associated with a symtree node. */
3153 clear_sym_mark (gfc_symtree *st)
3156 st->n.sym->mark = 0;
3160 /* Recursively traverse the symtree nodes. */
3163 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
3168 gfc_traverse_symtree (st->left, func);
3170 gfc_traverse_symtree (st->right, func);
3174 /* Recursive namespace traversal function. */
3177 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
3183 traverse_ns (st->left, func);
3185 if (st->n.sym->mark == 0)
3186 (*func) (st->n.sym);
3187 st->n.sym->mark = 1;
3189 traverse_ns (st->right, func);
3193 /* Call a given function for all symbols in the namespace. We take
3194 care that each gfc_symbol node is called exactly once. */
3197 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3200 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3202 traverse_ns (ns->sym_root, func);
3206 /* Return TRUE when name is the name of an intrinsic type. */
3209 gfc_is_intrinsic_typename (const char *name)
3211 if (strcmp (name, "integer") == 0
3212 || strcmp (name, "real") == 0
3213 || strcmp (name, "character") == 0
3214 || strcmp (name, "logical") == 0
3215 || strcmp (name, "complex") == 0
3216 || strcmp (name, "doubleprecision") == 0
3217 || strcmp (name, "doublecomplex") == 0)
3224 /* Return TRUE if the symbol is an automatic variable. */
3227 gfc_is_var_automatic (gfc_symbol *sym)
3229 /* Pointer and allocatable variables are never automatic. */
3230 if (sym->attr.pointer || sym->attr.allocatable)
3232 /* Check for arrays with non-constant size. */
3233 if (sym->attr.dimension && sym->as
3234 && !gfc_is_compile_time_shape (sym->as))
3236 /* Check for non-constant length character variables. */
3237 if (sym->ts.type == BT_CHARACTER
3239 && !gfc_is_constant_expr (sym->ts.cl->length))
3244 /* Given a symbol, mark it as SAVEd if it is allowed. */
3247 save_symbol (gfc_symbol *sym)
3250 if (sym->attr.use_assoc)
3253 if (sym->attr.in_common
3256 || sym->attr.flavor != FL_VARIABLE)
3258 /* Automatic objects are not saved. */
3259 if (gfc_is_var_automatic (sym))
3261 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3265 /* Mark those symbols which can be SAVEd as such. */
3268 gfc_save_all (gfc_namespace *ns)
3270 gfc_traverse_ns (ns, save_symbol);
3275 /* Make sure that no changes to symbols are pending. */
3278 gfc_symbol_state(void) {
3280 if (changed_syms != NULL)
3281 gfc_internal_error("Symbol changes still pending!");
3286 /************** Global symbol handling ************/
3289 /* Search a tree for the global symbol. */
3292 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3301 c = strcmp (name, symbol->name);
3305 symbol = (c < 0) ? symbol->left : symbol->right;
3312 /* Compare two global symbols. Used for managing the BB tree. */
3315 gsym_compare (void *_s1, void *_s2)
3317 gfc_gsymbol *s1, *s2;
3319 s1 = (gfc_gsymbol *) _s1;
3320 s2 = (gfc_gsymbol *) _s2;
3321 return strcmp (s1->name, s2->name);
3325 /* Get a global symbol, creating it if it doesn't exist. */
3328 gfc_get_gsymbol (const char *name)
3332 s = gfc_find_gsymbol (gfc_gsym_root, name);
3336 s = XCNEW (gfc_gsymbol);
3337 s->type = GSYM_UNKNOWN;
3338 s->name = gfc_get_string (name);
3340 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3347 get_iso_c_binding_dt (int sym_id)
3349 gfc_dt_list *dt_list;
3351 dt_list = gfc_derived_types;
3353 /* Loop through the derived types in the name list, searching for
3354 the desired symbol from iso_c_binding. Search the parent namespaces
3355 if necessary and requested to (parent_flag). */
3356 while (dt_list != NULL)
3358 if (dt_list->derived->from_intmod != INTMOD_NONE
3359 && dt_list->derived->intmod_sym_id == sym_id)
3360 return dt_list->derived;
3362 dt_list = dt_list->next;
3369 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3370 with C. This is necessary for any derived type that is BIND(C) and for
3371 derived types that are parameters to functions that are BIND(C). All
3372 fields of the derived type are required to be interoperable, and are tested
3373 for such. If an error occurs, the errors are reported here, allowing for
3374 multiple errors to be handled for a single derived type. */
3377 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3379 gfc_component *curr_comp = NULL;
3380 gfc_try is_c_interop = FAILURE;
3381 gfc_try retval = SUCCESS;
3383 if (derived_sym == NULL)
3384 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3385 "unexpectedly NULL");
3387 /* If we've already looked at this derived symbol, do not look at it again
3388 so we don't repeat warnings/errors. */
3389 if (derived_sym->ts.is_c_interop)
3392 /* The derived type must have the BIND attribute to be interoperable
3393 J3/04-007, Section 15.2.3. */
3394 if (derived_sym->attr.is_bind_c != 1)
3396 derived_sym->ts.is_c_interop = 0;
3397 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3398 "attribute to be C interoperable", derived_sym->name,
3399 &(derived_sym->declared_at));
3403 curr_comp = derived_sym->components;
3405 /* TODO: is this really an error? */
3406 if (curr_comp == NULL)
3408 gfc_error ("Derived type '%s' at %L is empty",
3409 derived_sym->name, &(derived_sym->declared_at));
3413 /* Initialize the derived type as being C interoperable.
3414 If we find an error in the components, this will be set false. */
3415 derived_sym->ts.is_c_interop = 1;
3417 /* Loop through the list of components to verify that the kind of
3418 each is a C interoperable type. */
3421 /* The components cannot be pointers (fortran sense).
3422 J3/04-007, Section 15.2.3, C1505. */
3423 if (curr_comp->attr.pointer != 0)
3425 gfc_error ("Component '%s' at %L cannot have the "
3426 "POINTER attribute because it is a member "
3427 "of the BIND(C) derived type '%s' at %L",
3428 curr_comp->name, &(curr_comp->loc),
3429 derived_sym->name, &(derived_sym->declared_at));
3433 /* The components cannot be allocatable.
3434 J3/04-007, Section 15.2.3, C1505. */
3435 if (curr_comp->attr.allocatable != 0)
3437 gfc_error ("Component '%s' at %L cannot have the "
3438 "ALLOCATABLE attribute because it is a member "
3439 "of the BIND(C) derived type '%s' at %L",
3440 curr_comp->name, &(curr_comp->loc),
3441 derived_sym->name, &(derived_sym->declared_at));
3445 /* BIND(C) derived types must have interoperable components. */
3446 if (curr_comp->ts.type == BT_DERIVED
3447 && curr_comp->ts.derived->ts.is_iso_c != 1
3448 && curr_comp->ts.derived != derived_sym)
3450 /* This should be allowed; the draft says a derived-type can not
3451 have type parameters if it is has the BIND attribute. Type
3452 parameters seem to be for making parameterized derived types.
3453 There's no need to verify the type if it is c_ptr/c_funptr. */
3454 retval = verify_bind_c_derived_type (curr_comp->ts.derived);
3458 /* Grab the typespec for the given component and test the kind. */
3459 is_c_interop = verify_c_interop (&(curr_comp->ts));
3461 if (is_c_interop != SUCCESS)
3463 /* Report warning and continue since not fatal. The
3464 draft does specify a constraint that requires all fields
3465 to interoperate, but if the user says real(4), etc., it
3466 may interoperate with *something* in C, but the compiler
3467 most likely won't know exactly what. Further, it may not
3468 interoperate with the same data type(s) in C if the user
3469 recompiles with different flags (e.g., -m32 and -m64 on
3470 x86_64 and using integer(4) to claim interop with a
3472 if (derived_sym->attr.is_bind_c == 1)
3473 /* If the derived type is bind(c), all fields must be
3475 gfc_warning ("Component '%s' in derived type '%s' at %L "
3476 "may not be C interoperable, even though "
3477 "derived type '%s' is BIND(C)",
3478 curr_comp->name, derived_sym->name,
3479 &(curr_comp->loc), derived_sym->name);
3481 /* If derived type is param to bind(c) routine, or to one
3482 of the iso_c_binding procs, it must be interoperable, so
3483 all fields must interop too. */
3484 gfc_warning ("Component '%s' in derived type '%s' at %L "
3485 "may not be C interoperable",
3486 curr_comp->name, derived_sym->name,
3491 curr_comp = curr_comp->next;
3492 } while (curr_comp != NULL);
3495 /* Make sure we don't have conflicts with the attributes. */
3496 if (derived_sym->attr.access == ACCESS_PRIVATE)
3498 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3499 "PRIVATE and BIND(C) attributes", derived_sym->name,
3500 &(derived_sym->declared_at));
3504 if (derived_sym->attr.sequence != 0)
3506 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3507 "attribute because it is BIND(C)", derived_sym->name,
3508 &(derived_sym->declared_at));
3512 /* Mark the derived type as not being C interoperable if we found an
3513 error. If there were only warnings, proceed with the assumption
3514 it's interoperable. */
3515 if (retval == FAILURE)
3516 derived_sym->ts.is_c_interop = 0;
3522 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3525 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3526 const char *module_name)
3528 gfc_symtree *tmp_symtree;
3529 gfc_symbol *tmp_sym;
3531 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3533 if (tmp_symtree != NULL)
3534 tmp_sym = tmp_symtree->n.sym;
3538 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3539 "create symbol for %s", ptr_name);
3542 /* Set up the symbol's important fields. Save attr required so we can
3543 initialize the ptr to NULL. */
3544 tmp_sym->attr.save = SAVE_EXPLICIT;
3545 tmp_sym->ts.is_c_interop = 1;
3546 tmp_sym->attr.is_c_interop = 1;
3547 tmp_sym->ts.is_iso_c = 1;
3548 tmp_sym->ts.type = BT_DERIVED;
3550 /* The c_ptr and c_funptr derived types will provide the
3551 definition for c_null_ptr and c_null_funptr, respectively. */
3552 if (ptr_id == ISOCBINDING_NULL_PTR)
3553 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3555 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3556 if (tmp_sym->ts.derived == NULL)
3558 /* This can occur if the user forgot to declare c_ptr or
3559 c_funptr and they're trying to use one of the procedures
3560 that has arg(s) of the missing type. In this case, a
3561 regular version of the thing should have been put in the
3563 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3564 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3565 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3566 ? "_gfortran_iso_c_binding_c_ptr"
3567 : "_gfortran_iso_c_binding_c_funptr"));
3569 tmp_sym->ts.derived =
3570 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3571 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3574 /* Module name is some mangled version of iso_c_binding. */
3575 tmp_sym->module = gfc_get_string (module_name);
3577 /* Say it's from the iso_c_binding module. */
3578 tmp_sym->attr.is_iso_c = 1;
3580 tmp_sym->attr.use_assoc = 1;
3581 tmp_sym->attr.is_bind_c = 1;
3582 /* Set the binding_label. */
3583 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3585 /* Set the c_address field of c_null_ptr and c_null_funptr to
3586 the value of NULL. */
3587 tmp_sym->value = gfc_get_expr ();
3588 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3589 tmp_sym->value->ts.type = BT_DERIVED;
3590 tmp_sym->value->ts.derived = tmp_sym->ts.derived;
3591 /* Create a constructor with no expr, that way we can recognize if the user
3592 tries to call the structure constructor for one of the iso_c_binding
3593 derived types during resolution (resolve_structure_cons). */
3594 tmp_sym->value->value.constructor = gfc_get_constructor ();
3595 /* Must declare c_null_ptr and c_null_funptr as having the
3596 PARAMETER attribute so they can be used in init expressions. */
3597 tmp_sym->attr.flavor = FL_PARAMETER;
3603 /* Add a formal argument, gfc_formal_arglist, to the
3604 end of the given list of arguments. Set the reference to the
3605 provided symbol, param_sym, in the argument. */
3608 add_formal_arg (gfc_formal_arglist **head,
3609 gfc_formal_arglist **tail,
3610 gfc_formal_arglist *formal_arg,
3611 gfc_symbol *param_sym)
3613 /* Put in list, either as first arg or at the tail (curr arg). */
3615 *head = *tail = formal_arg;
3618 (*tail)->next = formal_arg;
3619 (*tail) = formal_arg;
3622 (*tail)->sym = param_sym;
3623 (*tail)->next = NULL;
3629 /* Generates a symbol representing the CPTR argument to an
3630 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3631 CPTR and add it to the provided argument list. */
3634 gen_cptr_param (gfc_formal_arglist **head,
3635 gfc_formal_arglist **tail,
3636 const char *module_name,
3637 gfc_namespace *ns, const char *c_ptr_name,
3640 gfc_symbol *param_sym = NULL;
3641 gfc_symbol *c_ptr_sym = NULL;
3642 gfc_symtree *param_symtree = NULL;
3643 gfc_formal_arglist *formal_arg = NULL;
3644 const char *c_ptr_in;
3645 const char *c_ptr_type = NULL;
3647 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3648 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3650 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3652 if(c_ptr_name == NULL)
3653 c_ptr_in = "gfc_cptr__";
3655 c_ptr_in = c_ptr_name;
3656 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree);
3657 if (param_symtree != NULL)
3658 param_sym = param_symtree->n.sym;
3660 gfc_internal_error ("gen_cptr_param(): Unable to "
3661 "create symbol for %s", c_ptr_in);
3663 /* Set up the appropriate fields for the new c_ptr param sym. */
3665 param_sym->attr.flavor = FL_DERIVED;
3666 param_sym->ts.type = BT_DERIVED;
3667 param_sym->attr.intent = INTENT_IN;
3668 param_sym->attr.dummy = 1;
3670 /* This will pass the ptr to the iso_c routines as a (void *). */
3671 param_sym->attr.value = 1;
3672 param_sym->attr.use_assoc = 1;
3674 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3676 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3677 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3679 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3680 if (c_ptr_sym == NULL)
3682 /* This can happen if the user did not define c_ptr but they are
3683 trying to use one of the iso_c_binding functions that need it. */
3684 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3685 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3686 (const char *)c_ptr_type);
3688 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3689 (const char *)c_ptr_type);
3691 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3694 param_sym->ts.derived = c_ptr_sym;
3695 param_sym->module = gfc_get_string (module_name);
3697 /* Make new formal arg. */
3698 formal_arg = gfc_get_formal_arglist ();
3699 /* Add arg to list of formal args (the CPTR arg). */
3700 add_formal_arg (head, tail, formal_arg, param_sym);
3704 /* Generates a symbol representing the FPTR argument to an
3705 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3706 FPTR and add it to the provided argument list. */
3709 gen_fptr_param (gfc_formal_arglist **head,
3710 gfc_formal_arglist **tail,
3711 const char *module_name,
3712 gfc_namespace *ns, const char *f_ptr_name, int proc)
3714 gfc_symbol *param_sym = NULL;
3715 gfc_symtree *param_symtree = NULL;
3716 gfc_formal_arglist *formal_arg = NULL;
3717 const char *f_ptr_out = "gfc_fptr__";
3719 if (f_ptr_name != NULL)
3720 f_ptr_out = f_ptr_name;
3722 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree);
3723 if (param_symtree != NULL)
3724 param_sym = param_symtree->n.sym;
3726 gfc_internal_error ("generateFPtrParam(): Unable to "
3727 "create symbol for %s", f_ptr_out);
3729 /* Set up the necessary fields for the fptr output param sym. */
3732 param_sym->attr.proc_pointer = 1;
3734 param_sym->attr.pointer = 1;
3735 param_sym->attr.dummy = 1;
3736 param_sym->attr.use_assoc = 1;
3738 /* ISO C Binding type to allow any pointer type as actual param. */
3739 param_sym->ts.type = BT_VOID;
3740 param_sym->module = gfc_get_string (module_name);
3743 formal_arg = gfc_get_formal_arglist ();
3744 /* Add arg to list of formal args. */
3745 add_formal_arg (head, tail, formal_arg, param_sym);
3749 /* Generates a symbol representing the optional SHAPE argument for the
3750 iso_c_binding c_f_pointer() procedure. Also, create a
3751 gfc_formal_arglist for the SHAPE and add it to the provided
3755 gen_shape_param (gfc_formal_arglist **head,
3756 gfc_formal_arglist **tail,
3757 const char *module_name,
3758 gfc_namespace *ns, const char *shape_param_name)
3760 gfc_symbol *param_sym = NULL;
3761 gfc_symtree *param_symtree = NULL;
3762 gfc_formal_arglist *formal_arg = NULL;
3763 const char *shape_param = "gfc_shape_array__";
3766 if (shape_param_name != NULL)
3767 shape_param = shape_param_name;
3769 gfc_get_sym_tree (shape_param, ns, ¶m_symtree);
3770 if (param_symtree != NULL)
3771 param_sym = param_symtree->n.sym;
3773 gfc_internal_error ("generateShapeParam(): Unable to "
3774 "create symbol for %s", shape_param);
3776 /* Set up the necessary fields for the shape input param sym. */
3778 param_sym->attr.dummy = 1;
3779 param_sym->attr.use_assoc = 1;
3781 /* Integer array, rank 1, describing the shape of the object. Make it's
3782 type BT_VOID initially so we can accept any type/kind combination of
3783 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3784 of BT_INTEGER type. */
3785 param_sym->ts.type = BT_VOID;
3787 /* Initialize the kind to default integer. However, it will be overridden
3788 during resolution to match the kind of the SHAPE parameter given as
3789 the actual argument (to allow for any valid integer kind). */
3790 param_sym->ts.kind = gfc_default_integer_kind;
3791 param_sym->as = gfc_get_array_spec ();
3793 /* Clear out the dimension info for the array. */
3794 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3796 param_sym->as->lower[i] = NULL;
3797 param_sym->as->upper[i] = NULL;
3799 param_sym->as->rank = 1;
3800 param_sym->as->lower[0] = gfc_int_expr (1);
3802 /* The extent is unknown until we get it. The length give us
3803 the rank the incoming pointer. */
3804 param_sym->as->type = AS_ASSUMED_SHAPE;
3806 /* The arg is also optional; it is required iff the second arg
3807 (fptr) is to an array, otherwise, it's ignored. */
3808 param_sym->attr.optional = 1;
3809 param_sym->attr.intent = INTENT_IN;
3810 param_sym->attr.dimension = 1;
3811 param_sym->module = gfc_get_string (module_name);
3814 formal_arg = gfc_get_formal_arglist ();
3815 /* Add arg to list of formal args. */
3816 add_formal_arg (head, tail, formal_arg, param_sym);
3820 /* Add a procedure interface to the given symbol (i.e., store a
3821 reference to the list of formal arguments). */
3824 add_proc_interface (gfc_symbol *sym, ifsrc source,
3825 gfc_formal_arglist *formal)
3828 sym->formal = formal;
3829 sym->attr.if_source = source;
3833 /* Copy the formal args from an existing symbol, src, into a new
3834 symbol, dest. New formal args are created, and the description of
3835 each arg is set according to the existing ones. This function is
3836 used when creating procedure declaration variables from a procedure
3837 declaration statement (see match_proc_decl()) to create the formal
3838 args based on the args of a given named interface. */
3841 gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
3843 gfc_formal_arglist *head = NULL;
3844 gfc_formal_arglist *tail = NULL;
3845 gfc_formal_arglist *formal_arg = NULL;
3846 gfc_formal_arglist *curr_arg = NULL;
3847 gfc_formal_arglist *formal_prev = NULL;
3848 /* Save current namespace so we can change it for formal args. */
3849 gfc_namespace *parent_ns = gfc_current_ns;
3851 /* Create a new namespace, which will be the formal ns (namespace
3852 of the formal args). */
3853 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3854 gfc_current_ns->proc_name = dest;
3856 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3858 formal_arg = gfc_get_formal_arglist ();
3859 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
3861 /* May need to copy more info for the symbol. */
3862 formal_arg->sym->attr = curr_arg->sym->attr;
3863 formal_arg->sym->ts = curr_arg->sym->ts;
3864 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
3865 gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
3867 /* If this isn't the first arg, set up the next ptr. For the
3868 last arg built, the formal_arg->next will never get set to
3869 anything other than NULL. */
3870 if (formal_prev != NULL)
3871 formal_prev->next = formal_arg;
3873 formal_arg->next = NULL;
3875 formal_prev = formal_arg;
3877 /* Add arg to list of formal args. */
3878 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3881 /* Add the interface to the symbol. */
3882 add_proc_interface (dest, IFSRC_DECL, head);
3884 /* Store the formal namespace information. */
3885 if (dest->formal != NULL)
3886 /* The current ns should be that for the dest proc. */
3887 dest->formal_ns = gfc_current_ns;
3888 /* Restore the current namespace to what it was on entry. */
3889 gfc_current_ns = parent_ns;
3894 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
3896 gfc_formal_arglist *head = NULL;
3897 gfc_formal_arglist *tail = NULL;
3898 gfc_formal_arglist *formal_arg = NULL;
3899 gfc_intrinsic_arg *curr_arg = NULL;
3900 gfc_formal_arglist *formal_prev = NULL;
3901 /* Save current namespace so we can change it for formal args. */
3902 gfc_namespace *parent_ns = gfc_current_ns;
3904 /* Create a new namespace, which will be the formal ns (namespace
3905 of the formal args). */
3906 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3907 gfc_current_ns->proc_name = dest;
3909 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3911 formal_arg = gfc_get_formal_arglist ();
3912 gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
3914 /* May need to copy more info for the symbol. */
3915 formal_arg->sym->ts = curr_arg->ts;
3916 formal_arg->sym->attr.optional = curr_arg->optional;
3917 formal_arg->sym->attr.flavor = FL_VARIABLE;
3918 formal_arg->sym->attr.dummy = 1;
3920 /* If this isn't the first arg, set up the next ptr. For the
3921 last arg built, the formal_arg->next will never get set to
3922 anything other than NULL. */
3923 if (formal_prev != NULL)
3924 formal_prev->next = formal_arg;
3926 formal_arg->next = NULL;
3928 formal_prev = formal_arg;
3930 /* Add arg to list of formal args. */
3931 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3934 /* Add the interface to the symbol. */
3935 add_proc_interface (dest, IFSRC_DECL, head);
3937 /* Store the formal namespace information. */
3938 if (dest->formal != NULL)
3939 /* The current ns should be that for the dest proc. */
3940 dest->formal_ns = gfc_current_ns;
3941 /* Restore the current namespace to what it was on entry. */
3942 gfc_current_ns = parent_ns;
3946 /* Builds the parameter list for the iso_c_binding procedure
3947 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3948 generic version of either the c_f_pointer or c_f_procpointer
3949 functions. The new_proc_sym represents a "resolved" version of the
3950 symbol. The functions are resolved to match the types of their
3951 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3952 something similar to c_f_pointer_i4 if the type of data object fptr
3953 pointed to was a default integer. The actual name of the resolved
3954 procedure symbol is further mangled with the module name, etc., but
3955 the idea holds true. */
3958 build_formal_args (gfc_symbol *new_proc_sym,
3959 gfc_symbol *old_sym, int add_optional_arg)
3961 gfc_formal_arglist *head = NULL, *tail = NULL;
3962 gfc_namespace *parent_ns = NULL;
3964 parent_ns = gfc_current_ns;
3965 /* Create a new namespace, which will be the formal ns (namespace
3966 of the formal args). */
3967 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
3968 gfc_current_ns->proc_name = new_proc_sym;
3970 /* Generate the params. */
3971 if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
3973 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3974 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3975 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3976 gfc_current_ns, "fptr", 1);
3978 else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3980 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3981 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3982 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3983 gfc_current_ns, "fptr", 0);
3984 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3985 gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
3986 gfc_current_ns, "shape");
3989 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3991 /* c_associated has one required arg and one optional; both
3993 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3994 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
3995 if (add_optional_arg)
3997 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3998 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
3999 /* The last param is optional so mark it as such. */
4000 tail->sym->attr.optional = 1;
4004 /* Add the interface (store formal args to new_proc_sym). */
4005 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
4007 /* Set up the formal_ns pointer to the one created for the
4008 new procedure so it'll get cleaned up during gfc_free_symbol(). */
4009 new_proc_sym->formal_ns = gfc_current_ns;
4011 gfc_current_ns = parent_ns;
4015 std_for_isocbinding_symbol (int id)
4019 #define NAMED_INTCST(a,b,c,d) \
4022 #include "iso-c-binding.def"
4025 return GFC_STD_F2003;
4029 /* Generate the given set of C interoperable kind objects, or all
4030 interoperable kinds. This function will only be given kind objects
4031 for valid iso_c_binding defined types because this is verified when
4032 the 'use' statement is parsed. If the user gives an 'only' clause,
4033 the specific kinds are looked up; if they don't exist, an error is
4034 reported. If the user does not give an 'only' clause, all
4035 iso_c_binding symbols are generated. If a list of specific kinds
4036 is given, it must have a NULL in the first empty spot to mark the
4041 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4042 const char *local_name)
4044 const char *const name = (local_name && local_name[0]) ? local_name
4045 : c_interop_kinds_table[s].name;
4046 gfc_symtree *tmp_symtree = NULL;
4047 gfc_symbol *tmp_sym = NULL;
4048 gfc_dt_list **dt_list_ptr = NULL;
4049 gfc_component *tmp_comp = NULL;
4050 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
4053 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4055 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4057 /* Already exists in this scope so don't re-add it.
4058 TODO: we should probably check that it's really the same symbol. */
4059 if (tmp_symtree != NULL)
4062 /* Create the sym tree in the current ns. */
4063 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
4065 tmp_sym = tmp_symtree->n.sym;
4067 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4070 /* Say what module this symbol belongs to. */
4071 tmp_sym->module = gfc_get_string (mod_name);
4072 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4073 tmp_sym->intmod_sym_id = s;
4078 #define NAMED_INTCST(a,b,c,d) case a :
4079 #define NAMED_REALCST(a,b,c) case a :
4080 #define NAMED_CMPXCST(a,b,c) case a :
4081 #define NAMED_LOGCST(a,b,c) case a :
4082 #define NAMED_CHARKNDCST(a,b,c) case a :
4083 #include "iso-c-binding.def"
4085 tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
4087 /* Initialize an integer constant expression node. */
4088 tmp_sym->attr.flavor = FL_PARAMETER;
4089 tmp_sym->ts.type = BT_INTEGER;
4090 tmp_sym->ts.kind = gfc_default_integer_kind;
4092 /* Mark this type as a C interoperable one. */
4093 tmp_sym->ts.is_c_interop = 1;
4094 tmp_sym->ts.is_iso_c = 1;
4095 tmp_sym->value->ts.is_c_interop = 1;
4096 tmp_sym->value->ts.is_iso_c = 1;
4097 tmp_sym->attr.is_c_interop = 1;
4099 /* Tell what f90 type this c interop kind is valid. */
4100 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4102 /* Say it's from the iso_c_binding module. */
4103 tmp_sym->attr.is_iso_c = 1;
4105 /* Make it use associated. */
4106 tmp_sym->attr.use_assoc = 1;
4110 #define NAMED_CHARCST(a,b,c) case a :
4111 #include "iso-c-binding.def"
4113 /* Initialize an integer constant expression node for the
4114 length of the character. */
4115 tmp_sym->value = gfc_get_expr ();
4116 tmp_sym->value->expr_type = EXPR_CONSTANT;
4117 tmp_sym->value->ts.type = BT_CHARACTER;
4118 tmp_sym->value->ts.kind = gfc_default_character_kind;
4119 tmp_sym->value->where = gfc_current_locus;
4120 tmp_sym->value->ts.is_c_interop = 1;
4121 tmp_sym->value->ts.is_iso_c = 1;
4122 tmp_sym->value->value.character.length = 1;
4123 tmp_sym->value->value.character.string = gfc_get_wide_string (2);
4124 tmp_sym->value->value.character.string[0]
4125 = (gfc_char_t) c_interop_kinds_table[s].value;
4126 tmp_sym->value->value.character.string[1] = '\0';
4127 tmp_sym->ts.cl = gfc_get_charlen ();
4128 tmp_sym->ts.cl->length = gfc_int_expr (1);
4130 /* May not need this in both attr and ts, but do need in
4131 attr for writing module file. */
4132 tmp_sym->attr.is_c_interop = 1;
4134 tmp_sym->attr.flavor = FL_PARAMETER;
4135 tmp_sym->ts.type = BT_CHARACTER;
4137 /* Need to set it to the C_CHAR kind. */
4138 tmp_sym->ts.kind = gfc_default_character_kind;
4140 /* Mark this type as a C interoperable one. */
4141 tmp_sym->ts.is_c_interop = 1;
4142 tmp_sym->ts.is_iso_c = 1;
4144 /* Tell what f90 type this c interop kind is valid. */
4145 tmp_sym->ts.f90_type = BT_CHARACTER;
4147 /* Say it's from the iso_c_binding module. */
4148 tmp_sym->attr.is_iso_c = 1;
4150 /* Make it use associated. */
4151 tmp_sym->attr.use_assoc = 1;
4154 case ISOCBINDING_PTR:
4155 case ISOCBINDING_FUNPTR:
4157 /* Initialize an integer constant expression node. */
4158 tmp_sym->attr.flavor = FL_DERIVED;
4159 tmp_sym->ts.is_c_interop = 1;
4160 tmp_sym->attr.is_c_interop = 1;
4161 tmp_sym->attr.is_iso_c = 1;
4162 tmp_sym->ts.is_iso_c = 1;
4163 tmp_sym->ts.type = BT_DERIVED;
4165 /* A derived type must have the bind attribute to be
4166 interoperable (J3/04-007, Section 15.2.3), even though
4167 the binding label is not used. */
4168 tmp_sym->attr.is_bind_c = 1;
4170 tmp_sym->attr.referenced = 1;
4172 tmp_sym->ts.derived = tmp_sym;
4174 /* Add the symbol created for the derived type to the current ns. */
4175 dt_list_ptr = &(gfc_derived_types);
4176 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4177 dt_list_ptr = &((*dt_list_ptr)->next);
4179 /* There is already at least one derived type in the list, so append
4180 the one we're currently building for c_ptr or c_funptr. */
4181 if (*dt_list_ptr != NULL)
4182 dt_list_ptr = &((*dt_list_ptr)->next);
4183 (*dt_list_ptr) = gfc_get_dt_list ();
4184 (*dt_list_ptr)->derived = tmp_sym;
4185 (*dt_list_ptr)->next = NULL;
4187 /* Set up the component of the derived type, which will be
4188 an integer with kind equal to c_ptr_size. Mangle the name of
4189 the field for the c_address to prevent the curious user from
4190 trying to access it from Fortran. */
4191 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
4192 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
4193 if (tmp_comp == NULL)
4194 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4195 "create component for c_address");
4197 tmp_comp->ts.type = BT_INTEGER;
4199 /* Set this because the module will need to read/write this field. */
4200 tmp_comp->ts.f90_type = BT_INTEGER;
4202 /* The kinds for c_ptr and c_funptr are the same. */
4203 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4204 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4206 tmp_comp->attr.pointer = 0;
4207 tmp_comp->attr.dimension = 0;
4209 /* Mark the component as C interoperable. */
4210 tmp_comp->ts.is_c_interop = 1;
4212 /* Make it use associated (iso_c_binding module). */
4213 tmp_sym->attr.use_assoc = 1;
4216 case ISOCBINDING_NULL_PTR:
4217 case ISOCBINDING_NULL_FUNPTR:
4218 gen_special_c_interop_ptr (s, name, mod_name);
4221 case ISOCBINDING_F_POINTER:
4222 case ISOCBINDING_ASSOCIATED:
4223 case ISOCBINDING_LOC:
4224 case ISOCBINDING_FUNLOC:
4225 case ISOCBINDING_F_PROCPOINTER:
4227 tmp_sym->attr.proc = PROC_MODULE;
4229 /* Use the procedure's name as it is in the iso_c_binding module for
4230 setting the binding label in case the user renamed the symbol. */
4231 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
4232 c_interop_kinds_table[s].name);
4233 tmp_sym->attr.is_iso_c = 1;
4234 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4235 tmp_sym->attr.subroutine = 1;
4238 /* TODO! This needs to be finished more for the expr of the
4239 function or something!
4240 This may not need to be here, because trying to do c_loc
4242 if (s == ISOCBINDING_ASSOCIATED)
4244 tmp_sym->attr.function = 1;
4245 tmp_sym->ts.type = BT_LOGICAL;
4246 tmp_sym->ts.kind = gfc_default_logical_kind;
4247 tmp_sym->result = tmp_sym;
4251 /* Here, we're taking the simple approach. We're defining
4252 c_loc as an external identifier so the compiler will put
4253 what we expect on the stack for the address we want the
4255 tmp_sym->ts.type = BT_DERIVED;
4256 if (s == ISOCBINDING_LOC)
4257 tmp_sym->ts.derived =
4258 get_iso_c_binding_dt (ISOCBINDING_PTR);
4260 tmp_sym->ts.derived =
4261 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4263 if (tmp_sym->ts.derived == NULL)
4265 /* Create the necessary derived type so we can continue
4266 processing the file. */
4267 generate_isocbinding_symbol
4268 (mod_name, s == ISOCBINDING_FUNLOC
4269 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4270 (const char *)(s == ISOCBINDING_FUNLOC
4271 ? "_gfortran_iso_c_binding_c_funptr"
4272 : "_gfortran_iso_c_binding_c_ptr"));
4273 tmp_sym->ts.derived =
4274 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4275 ? ISOCBINDING_FUNPTR
4279 /* The function result is itself (no result clause). */
4280 tmp_sym->result = tmp_sym;
4281 tmp_sym->attr.external = 1;
4282 tmp_sym->attr.use_assoc = 0;
4283 tmp_sym->attr.pure = 1;
4284 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4285 tmp_sym->attr.proc = PROC_UNKNOWN;
4289 tmp_sym->attr.flavor = FL_PROCEDURE;
4290 tmp_sym->attr.contained = 0;
4292 /* Try using this builder routine, with the new and old symbols
4293 both being the generic iso_c proc sym being created. This
4294 will create the formal args (and the new namespace for them).
4295 Don't build an arg list for c_loc because we're going to treat
4296 c_loc as an external procedure. */
4297 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4298 /* The 1 says to add any optional args, if applicable. */
4299 build_formal_args (tmp_sym, tmp_sym, 1);
4301 /* Set this after setting up the symbol, to prevent error messages. */
4302 tmp_sym->attr.use_assoc = 1;
4304 /* This symbol will not be referenced directly. It will be
4305 resolved to the implementation for the given f90 kind. */
4306 tmp_sym->attr.referenced = 0;
4316 /* Creates a new symbol based off of an old iso_c symbol, with a new
4317 binding label. This function can be used to create a new,
4318 resolved, version of a procedure symbol for c_f_pointer or
4319 c_f_procpointer that is based on the generic symbols. A new
4320 parameter list is created for the new symbol using
4321 build_formal_args(). The add_optional_flag specifies whether the
4322 to add the optional SHAPE argument. The new symbol is
4326 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4327 char *new_binding_label, int add_optional_arg)
4329 gfc_symtree *new_symtree = NULL;
4331 /* See if we have a symbol by that name already available, looking
4332 through any parent namespaces. */
4333 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4334 if (new_symtree != NULL)
4335 /* Return the existing symbol. */
4336 return new_symtree->n.sym;
4338 /* Create the symtree/symbol, with attempted host association. */
4339 gfc_get_ha_sym_tree (new_name, &new_symtree);
4340 if (new_symtree == NULL)
4341 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4342 "symtree for '%s'", new_name);
4344 /* Now fill in the fields of the resolved symbol with the old sym. */
4345 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4346 new_symtree->n.sym->attr = old_sym->attr;
4347 new_symtree->n.sym->ts = old_sym->ts;
4348 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4349 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4350 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4351 /* Build the formal arg list. */
4352 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4354 gfc_commit_symbol (new_symtree->n.sym);
4356 return new_symtree->n.sym;
4360 /* Check that a symbol is already typed. If strict is not set, an untyped
4361 symbol is acceptable for non-standard-conforming mode. */
4364 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4365 bool strict, locus where)
4369 if (gfc_matching_prefix)
4372 /* Check for the type and try to give it an implicit one. */
4373 if (sym->ts.type == BT_UNKNOWN
4374 && gfc_set_default_type (sym, 0, ns) == FAILURE)
4378 gfc_error ("Symbol '%s' is used before it is typed at %L",
4383 if (gfc_notify_std (GFC_STD_GNU,
4384 "Extension: Symbol '%s' is used before"
4385 " it is typed at %L", sym->name, &where) == FAILURE)
4389 /* Everything is ok. */
4394 /* Construct a typebound-procedure structure. Those are stored in a tentative
4395 list and marked `error' until symbols are committed. */
4398 gfc_get_typebound_proc (void)
4400 gfc_typebound_proc *result;
4401 tentative_tbp *list_node;
4403 result = XCNEW (gfc_typebound_proc);
4406 list_node = XCNEW (tentative_tbp);
4407 list_node->next = tentative_tbp_list;
4408 list_node->proc = result;
4409 tentative_tbp_list = list_node;
4415 /* Get the super-type of a given derived type. */
4418 gfc_get_derived_super_type (gfc_symbol* derived)
4420 if (!derived->attr.extension)
4423 gcc_assert (derived->components);
4424 gcc_assert (derived->components->ts.type == BT_DERIVED);
4425 gcc_assert (derived->components->ts.derived);
4427 return derived->components->ts.derived;
4431 /* Find a type-bound procedure by name for a derived-type (looking recursively
4432 through the super-types). */
4435 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
4436 const char* name, bool noaccess)
4440 /* Set default to failure. */
4444 /* Try to find it in the current type's namespace. */
4445 gcc_assert (derived->f2k_derived);
4446 res = gfc_find_symtree (derived->f2k_derived->tb_sym_root, name);
4447 if (res && res->n.tb)
4453 if (!noaccess && derived->attr.use_assoc
4454 && res->n.tb->access == ACCESS_PRIVATE)
4456 gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
4464 /* Otherwise, recurse on parent type if derived is an extension. */
4465 if (derived->attr.extension)
4467 gfc_symbol* super_type;
4468 super_type = gfc_get_derived_super_type (derived);
4469 gcc_assert (super_type);
4470 return gfc_find_typebound_proc (super_type, t, name, noaccess);
4473 /* Nothing found. */
4478 /* Get a typebound-procedure symtree or create and insert it if not yet
4479 present. This is like a very simplified version of gfc_get_sym_tree for
4480 tbp-symtrees rather than regular ones. */
4483 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
4485 gfc_symtree *result;
4487 result = gfc_find_symtree (*root, name);
4490 result = gfc_new_symtree (root, name);
4491 gcc_assert (result);
4492 result->n.tb = NULL;