1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
3 2009, 2010 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
31 /* Strings for all symbol attributes. We use these for dumping the
32 parse tree, in error messages, and also when reading and writing
35 const mstring flavors[] =
37 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
38 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
39 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
40 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
41 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
45 const mstring procedures[] =
47 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
48 minit ("MODULE-PROC", PROC_MODULE),
49 minit ("INTERNAL-PROC", PROC_INTERNAL),
50 minit ("DUMMY-PROC", PROC_DUMMY),
51 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
52 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
53 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
57 const mstring intents[] =
59 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
60 minit ("IN", INTENT_IN),
61 minit ("OUT", INTENT_OUT),
62 minit ("INOUT", INTENT_INOUT),
66 const mstring access_types[] =
68 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
69 minit ("PUBLIC", ACCESS_PUBLIC),
70 minit ("PRIVATE", ACCESS_PRIVATE),
74 const mstring ifsrc_types[] =
76 minit ("UNKNOWN", IFSRC_UNKNOWN),
77 minit ("DECL", IFSRC_DECL),
78 minit ("BODY", IFSRC_IFBODY)
81 const mstring save_status[] =
83 minit ("UNKNOWN", SAVE_NONE),
84 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
85 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
88 /* This is to make sure the backend generates setup code in the correct
91 static int next_dummy_order = 1;
94 gfc_namespace *gfc_current_ns;
95 gfc_namespace *gfc_global_ns_list;
97 gfc_gsymbol *gfc_gsym_root = NULL;
99 static gfc_symbol *changed_syms = NULL;
101 gfc_dt_list *gfc_derived_types;
104 /* List of tentative typebound-procedures. */
106 typedef struct tentative_tbp
108 gfc_typebound_proc *proc;
109 struct tentative_tbp *next;
113 static tentative_tbp *tentative_tbp_list = NULL;
116 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
118 /* The following static variable indicates whether a particular element has
119 been explicitly set or not. */
121 static int new_flag[GFC_LETTERS];
124 /* Handle a correctly parsed IMPLICIT NONE. */
127 gfc_set_implicit_none (void)
131 if (gfc_current_ns->seen_implicit_none)
133 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
137 gfc_current_ns->seen_implicit_none = 1;
139 for (i = 0; i < GFC_LETTERS; i++)
141 gfc_clear_ts (&gfc_current_ns->default_type[i]);
142 gfc_current_ns->set_flag[i] = 1;
147 /* Reset the implicit range flags. */
150 gfc_clear_new_implicit (void)
154 for (i = 0; i < GFC_LETTERS; i++)
159 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
162 gfc_add_new_implicit_range (int c1, int c2)
169 for (i = c1; i <= c2; i++)
173 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
185 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
186 the new implicit types back into the existing types will work. */
189 gfc_merge_new_implicit (gfc_typespec *ts)
193 if (gfc_current_ns->seen_implicit_none)
195 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
199 for (i = 0; i < GFC_LETTERS; i++)
203 if (gfc_current_ns->set_flag[i])
205 gfc_error ("Letter %c already has an IMPLICIT type at %C",
210 gfc_current_ns->default_type[i] = *ts;
211 gfc_current_ns->implicit_loc[i] = gfc_current_locus;
212 gfc_current_ns->set_flag[i] = 1;
219 /* Given a symbol, return a pointer to the typespec for its default type. */
222 gfc_get_default_type (const char *name, gfc_namespace *ns)
228 if (gfc_option.flag_allow_leading_underscore && letter == '_')
229 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
230 "gfortran developers, and should not be used for "
231 "implicitly typed variables");
233 if (letter < 'a' || letter > 'z')
234 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
239 return &ns->default_type[letter - 'a'];
243 /* Given a pointer to a symbol, set its type according to the first
244 letter of its name. Fails if the letter in question has no default
248 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
252 if (sym->ts.type != BT_UNKNOWN)
253 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
255 ts = gfc_get_default_type (sym->name, ns);
257 if (ts->type == BT_UNKNOWN)
259 if (error_flag && !sym->attr.untyped)
261 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
262 sym->name, &sym->declared_at);
263 sym->attr.untyped = 1; /* Ensure we only give an error once. */
270 sym->attr.implicit_type = 1;
272 if (ts->type == BT_CHARACTER && ts->u.cl)
273 sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
275 if (sym->attr.is_bind_c == 1)
277 /* BIND(C) variables should not be implicitly declared. */
278 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
279 "not be C interoperable", sym->name, &sym->declared_at);
280 sym->ts.f90_type = sym->ts.type;
283 if (sym->attr.dummy != 0)
285 if (sym->ns->proc_name != NULL
286 && (sym->ns->proc_name->attr.subroutine != 0
287 || sym->ns->proc_name->attr.function != 0)
288 && sym->ns->proc_name->attr.is_bind_c != 0)
290 /* Dummy args to a BIND(C) routine may not be interoperable if
291 they are implicitly typed. */
292 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
293 "be C interoperable but it is a dummy argument to "
294 "the BIND(C) procedure '%s' at %L", sym->name,
295 &(sym->declared_at), sym->ns->proc_name->name,
296 &(sym->ns->proc_name->declared_at));
297 sym->ts.f90_type = sym->ts.type;
305 /* This function is called from parse.c(parse_progunit) to check the
306 type of the function is not implicitly typed in the host namespace
307 and to implicitly type the function result, if necessary. */
310 gfc_check_function_type (gfc_namespace *ns)
312 gfc_symbol *proc = ns->proc_name;
314 if (!proc->attr.contained || proc->result->attr.implicit_type)
317 if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
319 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
322 if (proc->result != proc)
324 proc->ts = proc->result->ts;
325 proc->as = gfc_copy_array_spec (proc->result->as);
326 proc->attr.dimension = proc->result->attr.dimension;
327 proc->attr.pointer = proc->result->attr.pointer;
328 proc->attr.allocatable = proc->result->attr.allocatable;
331 else if (!proc->result->attr.proc_pointer)
333 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
334 proc->result->name, &proc->result->declared_at);
335 proc->result->attr.untyped = 1;
341 /******************** Symbol attribute stuff *********************/
343 /* This is a generic conflict-checker. We do this to avoid having a
344 single conflict in two places. */
346 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
347 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
348 #define conf_std(a, b, std) if (attr->a && attr->b)\
357 check_conflict (symbol_attribute *attr, const char *name, locus *where)
359 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
360 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
361 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
362 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
363 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
364 *privat = "PRIVATE", *recursive = "RECURSIVE",
365 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
366 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
367 *function = "FUNCTION", *subroutine = "SUBROUTINE",
368 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
369 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
370 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
371 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
372 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
373 *asynchronous = "ASYNCHRONOUS";
374 static const char *threadprivate = "THREADPRIVATE";
380 where = &gfc_current_locus;
382 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
386 standard = GFC_STD_F2003;
390 /* Check for attributes not allowed in a BLOCK DATA. */
391 if (gfc_current_state () == COMP_BLOCK_DATA)
395 if (attr->in_namelist)
397 if (attr->allocatable)
403 if (attr->access == ACCESS_PRIVATE)
405 if (attr->access == ACCESS_PUBLIC)
407 if (attr->intent != INTENT_UNKNOWN)
413 ("%s attribute not allowed in BLOCK DATA program unit at %L",
419 if (attr->save == SAVE_EXPLICIT)
422 conf (in_common, save);
425 switch (attr->flavor)
433 a1 = gfc_code2string (flavors, attr->flavor);
438 /* Conflicts between SAVE and PROCEDURE will be checked at
439 resolution stage, see "resolve_fl_procedure". */
448 conf (dummy, intrinsic);
449 conf (dummy, threadprivate);
450 conf (pointer, target);
451 conf (pointer, intrinsic);
452 conf (pointer, elemental);
453 conf (allocatable, elemental);
455 conf (target, external);
456 conf (target, intrinsic);
458 if (!attr->if_source)
459 conf (external, dimension); /* See Fortran 95's R504. */
461 conf (external, intrinsic);
462 conf (entry, intrinsic);
464 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
465 conf (external, subroutine);
467 if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
468 "Fortran 2003: Procedure pointer at %C") == FAILURE)
471 conf (allocatable, pointer);
472 conf_std (allocatable, dummy, GFC_STD_F2003);
473 conf_std (allocatable, function, GFC_STD_F2003);
474 conf_std (allocatable, result, GFC_STD_F2003);
475 conf (elemental, recursive);
477 conf (in_common, dummy);
478 conf (in_common, allocatable);
479 conf (in_common, result);
481 conf (dummy, result);
483 conf (in_equivalence, use_assoc);
484 conf (in_equivalence, dummy);
485 conf (in_equivalence, target);
486 conf (in_equivalence, pointer);
487 conf (in_equivalence, function);
488 conf (in_equivalence, result);
489 conf (in_equivalence, entry);
490 conf (in_equivalence, allocatable);
491 conf (in_equivalence, threadprivate);
493 conf (in_namelist, pointer);
494 conf (in_namelist, allocatable);
496 conf (entry, result);
498 conf (function, subroutine);
500 if (!function && !subroutine)
501 conf (is_bind_c, dummy);
503 conf (is_bind_c, cray_pointer);
504 conf (is_bind_c, cray_pointee);
505 conf (is_bind_c, allocatable);
506 conf (is_bind_c, elemental);
508 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
509 Parameter conflict caught below. Also, value cannot be specified
510 for a dummy procedure. */
512 /* Cray pointer/pointee conflicts. */
513 conf (cray_pointer, cray_pointee);
514 conf (cray_pointer, dimension);
515 conf (cray_pointer, pointer);
516 conf (cray_pointer, target);
517 conf (cray_pointer, allocatable);
518 conf (cray_pointer, external);
519 conf (cray_pointer, intrinsic);
520 conf (cray_pointer, in_namelist);
521 conf (cray_pointer, function);
522 conf (cray_pointer, subroutine);
523 conf (cray_pointer, entry);
525 conf (cray_pointee, allocatable);
526 conf (cray_pointee, intent);
527 conf (cray_pointee, optional);
528 conf (cray_pointee, dummy);
529 conf (cray_pointee, target);
530 conf (cray_pointee, intrinsic);
531 conf (cray_pointee, pointer);
532 conf (cray_pointee, entry);
533 conf (cray_pointee, in_common);
534 conf (cray_pointee, in_equivalence);
535 conf (cray_pointee, threadprivate);
538 conf (data, function);
540 conf (data, allocatable);
541 conf (data, use_assoc);
543 conf (value, pointer)
544 conf (value, allocatable)
545 conf (value, subroutine)
546 conf (value, function)
547 conf (value, volatile_)
548 conf (value, dimension)
549 conf (value, external)
552 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
555 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
559 conf (is_protected, intrinsic)
560 conf (is_protected, external)
561 conf (is_protected, in_common)
563 conf (asynchronous, intrinsic)
564 conf (asynchronous, external)
566 conf (volatile_, intrinsic)
567 conf (volatile_, external)
569 if (attr->volatile_ && attr->intent == INTENT_IN)
576 conf (procedure, allocatable)
577 conf (procedure, dimension)
578 conf (procedure, intrinsic)
579 conf (procedure, is_protected)
580 conf (procedure, target)
581 conf (procedure, value)
582 conf (procedure, volatile_)
583 conf (procedure, asynchronous)
584 conf (procedure, entry)
586 a1 = gfc_code2string (flavors, attr->flavor);
588 if (attr->in_namelist
589 && attr->flavor != FL_VARIABLE
590 && attr->flavor != FL_PROCEDURE
591 && attr->flavor != FL_UNKNOWN)
597 switch (attr->flavor)
606 conf2 (asynchronous);
608 conf2 (is_protected);
618 conf2 (threadprivate);
620 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
622 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
623 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
630 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
644 /* Conflicts with INTENT, SAVE and RESULT will be checked
645 at resolution stage, see "resolve_fl_procedure". */
647 if (attr->subroutine)
653 conf2 (asynchronous);
657 conf2 (threadprivate);
660 if (!attr->proc_pointer)
665 case PROC_ST_FUNCTION:
675 conf2 (threadprivate);
695 conf2 (threadprivate);
698 if (attr->intent != INTENT_UNKNOWN)
714 conf2 (is_protected);
720 conf2 (asynchronous);
721 conf2 (threadprivate);
735 gfc_error ("%s attribute conflicts with %s attribute at %L",
738 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
739 a1, a2, name, where);
746 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
747 "with %s attribute at %L", a1, a2,
752 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
753 "with %s attribute in '%s' at %L",
754 a1, a2, name, where);
763 /* Mark a symbol as referenced. */
766 gfc_set_sym_referenced (gfc_symbol *sym)
769 if (sym->attr.referenced)
772 sym->attr.referenced = 1;
774 /* Remember which order dummy variables are accessed in. */
776 sym->dummy_order = next_dummy_order++;
780 /* Common subroutine called by attribute changing subroutines in order
781 to prevent them from changing a symbol that has been
782 use-associated. Returns zero if it is OK to change the symbol,
786 check_used (symbol_attribute *attr, const char *name, locus *where)
789 if (attr->use_assoc == 0)
793 where = &gfc_current_locus;
796 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
799 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
806 /* Generate an error because of a duplicate attribute. */
809 duplicate_attr (const char *attr, locus *where)
813 where = &gfc_current_locus;
815 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
820 gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
821 locus *where ATTRIBUTE_UNUSED)
823 attr->ext_attr |= 1 << ext_attr;
828 /* Called from decl.c (attr_decl1) to check attributes, when declared
832 gfc_add_attribute (symbol_attribute *attr, locus *where)
834 if (check_used (attr, NULL, where))
837 return check_conflict (attr, NULL, where);
842 gfc_add_allocatable (symbol_attribute *attr, locus *where)
845 if (check_used (attr, NULL, where))
848 if (attr->allocatable)
850 duplicate_attr ("ALLOCATABLE", where);
854 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
855 && gfc_find_state (COMP_INTERFACE) == FAILURE)
857 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
862 attr->allocatable = 1;
863 return check_conflict (attr, NULL, where);
868 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
871 if (check_used (attr, name, where))
876 duplicate_attr ("DIMENSION", where);
880 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
881 && gfc_find_state (COMP_INTERFACE) == FAILURE)
883 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
884 "at %L", name, where);
889 return check_conflict (attr, name, where);
894 gfc_add_external (symbol_attribute *attr, locus *where)
897 if (check_used (attr, NULL, where))
902 duplicate_attr ("EXTERNAL", where);
906 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
909 attr->proc_pointer = 1;
914 return check_conflict (attr, NULL, where);
919 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
922 if (check_used (attr, NULL, where))
927 duplicate_attr ("INTRINSIC", where);
933 return check_conflict (attr, NULL, where);
938 gfc_add_optional (symbol_attribute *attr, locus *where)
941 if (check_used (attr, NULL, where))
946 duplicate_attr ("OPTIONAL", where);
951 return check_conflict (attr, NULL, where);
956 gfc_add_pointer (symbol_attribute *attr, locus *where)
959 if (check_used (attr, NULL, where))
962 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
963 && gfc_find_state (COMP_INTERFACE) == FAILURE))
965 duplicate_attr ("POINTER", where);
969 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
970 || (attr->if_source == IFSRC_IFBODY
971 && gfc_find_state (COMP_INTERFACE) == FAILURE))
972 attr->proc_pointer = 1;
976 return check_conflict (attr, NULL, where);
981 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
984 if (check_used (attr, NULL, where))
987 attr->cray_pointer = 1;
988 return check_conflict (attr, NULL, where);
993 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
996 if (check_used (attr, NULL, where))
999 if (attr->cray_pointee)
1001 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1002 " statements", where);
1006 attr->cray_pointee = 1;
1007 return check_conflict (attr, NULL, where);
1012 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1014 if (check_used (attr, name, where))
1017 if (attr->is_protected)
1019 if (gfc_notify_std (GFC_STD_LEGACY,
1020 "Duplicate PROTECTED attribute specified at %L",
1026 attr->is_protected = 1;
1027 return check_conflict (attr, name, where);
1032 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1035 if (check_used (attr, name, where))
1039 return check_conflict (attr, name, where);
1044 gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
1047 if (check_used (attr, name, where))
1050 if (gfc_pure (NULL))
1053 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1058 if (attr->save == SAVE_EXPLICIT && !attr->vtab)
1060 if (gfc_notify_std (GFC_STD_LEGACY,
1061 "Duplicate SAVE attribute specified at %L",
1067 attr->save = SAVE_EXPLICIT;
1068 return check_conflict (attr, name, where);
1073 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1076 if (check_used (attr, name, where))
1081 if (gfc_notify_std (GFC_STD_LEGACY,
1082 "Duplicate VALUE attribute specified at %L",
1089 return check_conflict (attr, name, where);
1094 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1096 /* No check_used needed as 11.2.1 of the F2003 standard allows
1097 that the local identifier made accessible by a use statement can be
1098 given a VOLATILE attribute. */
1100 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1101 if (gfc_notify_std (GFC_STD_LEGACY,
1102 "Duplicate VOLATILE attribute specified at %L", where)
1106 attr->volatile_ = 1;
1107 attr->volatile_ns = gfc_current_ns;
1108 return check_conflict (attr, name, where);
1113 gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1115 /* No check_used needed as 11.2.1 of the F2003 standard allows
1116 that the local identifier made accessible by a use statement can be
1117 given a ASYNCHRONOUS attribute. */
1119 if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
1120 if (gfc_notify_std (GFC_STD_LEGACY,
1121 "Duplicate ASYNCHRONOUS attribute specified at %L",
1125 attr->asynchronous = 1;
1126 attr->asynchronous_ns = gfc_current_ns;
1127 return check_conflict (attr, name, where);
1132 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1135 if (check_used (attr, name, where))
1138 if (attr->threadprivate)
1140 duplicate_attr ("THREADPRIVATE", where);
1144 attr->threadprivate = 1;
1145 return check_conflict (attr, name, where);
1150 gfc_add_target (symbol_attribute *attr, locus *where)
1153 if (check_used (attr, NULL, where))
1158 duplicate_attr ("TARGET", where);
1163 return check_conflict (attr, NULL, where);
1168 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1171 if (check_used (attr, name, where))
1174 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1176 return check_conflict (attr, name, where);
1181 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1184 if (check_used (attr, name, where))
1187 /* Duplicate attribute already checked for. */
1188 attr->in_common = 1;
1189 return check_conflict (attr, name, where);
1194 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1197 /* Duplicate attribute already checked for. */
1198 attr->in_equivalence = 1;
1199 if (check_conflict (attr, name, where) == FAILURE)
1202 if (attr->flavor == FL_VARIABLE)
1205 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1210 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1213 if (check_used (attr, name, where))
1217 return check_conflict (attr, name, where);
1222 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1225 attr->in_namelist = 1;
1226 return check_conflict (attr, name, where);
1231 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1234 if (check_used (attr, name, where))
1238 return check_conflict (attr, name, where);
1243 gfc_add_elemental (symbol_attribute *attr, locus *where)
1246 if (check_used (attr, NULL, where))
1249 if (attr->elemental)
1251 duplicate_attr ("ELEMENTAL", where);
1255 attr->elemental = 1;
1256 return check_conflict (attr, NULL, where);
1261 gfc_add_pure (symbol_attribute *attr, locus *where)
1264 if (check_used (attr, NULL, where))
1269 duplicate_attr ("PURE", where);
1274 return check_conflict (attr, NULL, where);
1279 gfc_add_recursive (symbol_attribute *attr, locus *where)
1282 if (check_used (attr, NULL, where))
1285 if (attr->recursive)
1287 duplicate_attr ("RECURSIVE", where);
1291 attr->recursive = 1;
1292 return check_conflict (attr, NULL, where);
1297 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1300 if (check_used (attr, name, where))
1305 duplicate_attr ("ENTRY", where);
1310 return check_conflict (attr, name, where);
1315 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1318 if (attr->flavor != FL_PROCEDURE
1319 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1323 return check_conflict (attr, name, where);
1328 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1331 if (attr->flavor != FL_PROCEDURE
1332 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1335 attr->subroutine = 1;
1336 return check_conflict (attr, name, where);
1341 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1344 if (attr->flavor != FL_PROCEDURE
1345 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1349 return check_conflict (attr, name, where);
1354 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1357 if (check_used (attr, NULL, where))
1360 if (attr->flavor != FL_PROCEDURE
1361 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1364 if (attr->procedure)
1366 duplicate_attr ("PROCEDURE", where);
1370 attr->procedure = 1;
1372 return check_conflict (attr, NULL, where);
1377 gfc_add_abstract (symbol_attribute* attr, locus* where)
1381 duplicate_attr ("ABSTRACT", where);
1390 /* Flavors are special because some flavors are not what Fortran
1391 considers attributes and can be reaffirmed multiple times. */
1394 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1398 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1399 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1400 || f == FL_NAMELIST) && check_used (attr, name, where))
1403 if (attr->flavor == f && f == FL_VARIABLE)
1406 if (attr->flavor != FL_UNKNOWN)
1409 where = &gfc_current_locus;
1412 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1413 gfc_code2string (flavors, attr->flavor), name,
1414 gfc_code2string (flavors, f), where);
1416 gfc_error ("%s attribute conflicts with %s attribute at %L",
1417 gfc_code2string (flavors, attr->flavor),
1418 gfc_code2string (flavors, f), where);
1425 return check_conflict (attr, name, where);
1430 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1431 const char *name, locus *where)
1434 if (check_used (attr, name, where))
1437 if (attr->flavor != FL_PROCEDURE
1438 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1442 where = &gfc_current_locus;
1444 if (attr->proc != PROC_UNKNOWN)
1446 gfc_error ("%s procedure at %L is already declared as %s procedure",
1447 gfc_code2string (procedures, t), where,
1448 gfc_code2string (procedures, attr->proc));
1455 /* Statement functions are always scalar and functions. */
1456 if (t == PROC_ST_FUNCTION
1457 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1458 || attr->dimension))
1461 return check_conflict (attr, name, where);
1466 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1469 if (check_used (attr, NULL, where))
1472 if (attr->intent == INTENT_UNKNOWN)
1474 attr->intent = intent;
1475 return check_conflict (attr, NULL, where);
1479 where = &gfc_current_locus;
1481 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1482 gfc_intent_string (attr->intent),
1483 gfc_intent_string (intent), where);
1489 /* No checks for use-association in public and private statements. */
1492 gfc_add_access (symbol_attribute *attr, gfc_access access,
1493 const char *name, locus *where)
1496 if (attr->access == ACCESS_UNKNOWN
1497 || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1499 attr->access = access;
1500 return check_conflict (attr, name, where);
1504 where = &gfc_current_locus;
1505 gfc_error ("ACCESS specification at %L was already specified", where);
1511 /* Set the is_bind_c field for the given symbol_attribute. */
1514 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1515 int is_proc_lang_bind_spec)
1518 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1519 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1520 "variables or common blocks", where);
1521 else if (attr->is_bind_c)
1522 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1524 attr->is_bind_c = 1;
1527 where = &gfc_current_locus;
1529 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1533 return check_conflict (attr, name, where);
1537 /* Set the extension field for the given symbol_attribute. */
1540 gfc_add_extension (symbol_attribute *attr, locus *where)
1543 where = &gfc_current_locus;
1545 if (attr->extension)
1546 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1548 attr->extension = 1;
1550 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
1559 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1560 gfc_formal_arglist * formal, locus *where)
1563 if (check_used (&sym->attr, sym->name, where))
1567 where = &gfc_current_locus;
1569 if (sym->attr.if_source != IFSRC_UNKNOWN
1570 && sym->attr.if_source != IFSRC_DECL)
1572 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1577 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1579 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1580 "body", sym->name, where);
1584 sym->formal = formal;
1585 sym->attr.if_source = source;
1591 /* Add a type to a symbol. */
1594 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1600 where = &gfc_current_locus;
1603 type = sym->result->ts.type;
1605 type = sym->ts.type;
1607 if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
1608 type = sym->ns->proc_name->ts.type;
1610 if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
1612 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1613 where, gfc_basic_typename (type));
1617 if (sym->attr.procedure && sym->ts.interface)
1619 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1620 sym->name, where, gfc_basic_typename (ts->type));
1624 flavor = sym->attr.flavor;
1626 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1627 || flavor == FL_LABEL
1628 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1629 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1631 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1640 /* Clears all attributes. */
1643 gfc_clear_attr (symbol_attribute *attr)
1645 memset (attr, 0, sizeof (symbol_attribute));
1649 /* Check for missing attributes in the new symbol. Currently does
1650 nothing, but it's not clear that it is unnecessary yet. */
1653 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1654 locus *where ATTRIBUTE_UNUSED)
1661 /* Copy an attribute to a symbol attribute, bit by bit. Some
1662 attributes have a lot of side-effects but cannot be present given
1663 where we are called from, so we ignore some bits. */
1666 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1668 int is_proc_lang_bind_spec;
1670 /* In line with the other attributes, we only add bits but do not remove
1671 them; cf. also PR 41034. */
1672 dest->ext_attr |= src->ext_attr;
1674 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1677 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1679 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1681 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1683 if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1685 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1687 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1689 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1691 if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
1693 if (src->threadprivate
1694 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1696 if (src->target && gfc_add_target (dest, where) == FAILURE)
1698 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1700 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1705 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1708 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1711 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1713 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1715 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1718 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1720 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1722 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1724 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1727 if (src->flavor != FL_UNKNOWN
1728 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1731 if (src->intent != INTENT_UNKNOWN
1732 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1735 if (src->access != ACCESS_UNKNOWN
1736 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1739 if (gfc_missing_attr (dest, where) == FAILURE)
1742 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1744 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1747 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1749 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1753 if (src->is_c_interop)
1754 dest->is_c_interop = 1;
1758 if (src->external && gfc_add_external (dest, where) == FAILURE)
1760 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1762 if (src->proc_pointer)
1763 dest->proc_pointer = 1;
1772 /************** Component name management ************/
1774 /* Component names of a derived type form their own little namespaces
1775 that are separate from all other spaces. The space is composed of
1776 a singly linked list of gfc_component structures whose head is
1777 located in the parent symbol. */
1780 /* Add a component name to a symbol. The call fails if the name is
1781 already present. On success, the component pointer is modified to
1782 point to the additional component structure. */
1785 gfc_add_component (gfc_symbol *sym, const char *name,
1786 gfc_component **component)
1788 gfc_component *p, *tail;
1792 for (p = sym->components; p; p = p->next)
1794 if (strcmp (p->name, name) == 0)
1796 gfc_error ("Component '%s' at %C already declared at %L",
1804 if (sym->attr.extension
1805 && gfc_find_component (sym->components->ts.u.derived, name, true, true))
1807 gfc_error ("Component '%s' at %C already in the parent type "
1808 "at %L", name, &sym->components->ts.u.derived->declared_at);
1812 /* Allocate a new component. */
1813 p = gfc_get_component ();
1816 sym->components = p;
1820 p->name = gfc_get_string (name);
1821 p->loc = gfc_current_locus;
1822 p->ts.type = BT_UNKNOWN;
1829 /* Recursive function to switch derived types of all symbol in a
1833 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1841 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
1842 sym->ts.u.derived = to;
1844 switch_types (st->left, from, to);
1845 switch_types (st->right, from, to);
1849 /* This subroutine is called when a derived type is used in order to
1850 make the final determination about which version to use. The
1851 standard requires that a type be defined before it is 'used', but
1852 such types can appear in IMPLICIT statements before the actual
1853 definition. 'Using' in this context means declaring a variable to
1854 be that type or using the type constructor.
1856 If a type is used and the components haven't been defined, then we
1857 have to have a derived type in a parent unit. We find the node in
1858 the other namespace and point the symtree node in this namespace to
1859 that node. Further reference to this name point to the correct
1860 node. If we can't find the node in a parent namespace, then we have
1863 This subroutine takes a pointer to a symbol node and returns a
1864 pointer to the translated node or NULL for an error. Usually there
1865 is no translation and we return the node we were passed. */
1868 gfc_use_derived (gfc_symbol *sym)
1875 if (sym->components != NULL || sym->attr.zero_comp)
1876 return sym; /* Already defined. */
1878 if (sym->ns->parent == NULL)
1881 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1883 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1887 if (s == NULL || s->attr.flavor != FL_DERIVED)
1890 /* Get rid of symbol sym, translating all references to s. */
1891 for (i = 0; i < GFC_LETTERS; i++)
1893 t = &sym->ns->default_type[i];
1894 if (t->u.derived == sym)
1898 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1903 /* Unlink from list of modified symbols. */
1904 gfc_commit_symbol (sym);
1906 switch_types (sym->ns->sym_root, sym, s);
1908 /* TODO: Also have to replace sym -> s in other lists like
1909 namelists, common lists and interface lists. */
1910 gfc_free_symbol (sym);
1915 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1921 /* Given a derived type node and a component name, try to locate the
1922 component structure. Returns the NULL pointer if the component is
1923 not found or the components are private. If noaccess is set, no access
1927 gfc_find_component (gfc_symbol *sym, const char *name,
1928 bool noaccess, bool silent)
1935 sym = gfc_use_derived (sym);
1940 for (p = sym->components; p; p = p->next)
1941 if (strcmp (p->name, name) == 0)
1945 && sym->attr.extension
1946 && sym->components->ts.type == BT_DERIVED)
1948 p = gfc_find_component (sym->components->ts.u.derived, name,
1950 /* Do not overwrite the error. */
1955 if (p == NULL && !silent)
1956 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1959 else if (sym->attr.use_assoc && !noaccess)
1961 bool is_parent_comp = sym->attr.extension && (p == sym->components);
1962 if (p->attr.access == ACCESS_PRIVATE ||
1963 (p->attr.access != ACCESS_PUBLIC
1964 && sym->component_access == ACCESS_PRIVATE
1965 && !is_parent_comp))
1968 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1978 /* Given a symbol, free all of the component structures and everything
1982 free_components (gfc_component *p)
1990 gfc_free_array_spec (p->as);
1991 gfc_free_expr (p->initializer);
1998 /******************** Statement label management ********************/
2000 /* Comparison function for statement labels, used for managing the
2004 compare_st_labels (void *a1, void *b1)
2006 int a = ((gfc_st_label *) a1)->value;
2007 int b = ((gfc_st_label *) b1)->value;
2013 /* Free a single gfc_st_label structure, making sure the tree is not
2014 messed up. This function is called only when some parse error
2018 gfc_free_st_label (gfc_st_label *label)
2024 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
2026 if (label->format != NULL)
2027 gfc_free_expr (label->format);
2033 /* Free a whole tree of gfc_st_label structures. */
2036 free_st_labels (gfc_st_label *label)
2042 free_st_labels (label->left);
2043 free_st_labels (label->right);
2045 if (label->format != NULL)
2046 gfc_free_expr (label->format);
2051 /* Given a label number, search for and return a pointer to the label
2052 structure, creating it if it does not exist. */
2055 gfc_get_st_label (int labelno)
2060 /* Find the namespace of the scoping unit:
2061 If we're in a BLOCK construct, jump to the parent namespace. */
2062 ns = gfc_current_ns;
2063 while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2066 /* First see if the label is already in this namespace. */
2070 if (lp->value == labelno)
2073 if (lp->value < labelno)
2079 lp = XCNEW (gfc_st_label);
2081 lp->value = labelno;
2082 lp->defined = ST_LABEL_UNKNOWN;
2083 lp->referenced = ST_LABEL_UNKNOWN;
2085 gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2091 /* Called when a statement with a statement label is about to be
2092 accepted. We add the label to the list of the current namespace,
2093 making sure it hasn't been defined previously and referenced
2097 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2101 labelno = lp->value;
2103 if (lp->defined != ST_LABEL_UNKNOWN)
2104 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2105 &lp->where, label_locus);
2108 lp->where = *label_locus;
2112 case ST_LABEL_FORMAT:
2113 if (lp->referenced == ST_LABEL_TARGET)
2114 gfc_error ("Label %d at %C already referenced as branch target",
2117 lp->defined = ST_LABEL_FORMAT;
2121 case ST_LABEL_TARGET:
2122 if (lp->referenced == ST_LABEL_FORMAT)
2123 gfc_error ("Label %d at %C already referenced as a format label",
2126 lp->defined = ST_LABEL_TARGET;
2131 lp->defined = ST_LABEL_BAD_TARGET;
2132 lp->referenced = ST_LABEL_BAD_TARGET;
2138 /* Reference a label. Given a label and its type, see if that
2139 reference is consistent with what is known about that label,
2140 updating the unknown state. Returns FAILURE if something goes
2144 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2146 gfc_sl_type label_type;
2153 labelno = lp->value;
2155 if (lp->defined != ST_LABEL_UNKNOWN)
2156 label_type = lp->defined;
2159 label_type = lp->referenced;
2160 lp->where = gfc_current_locus;
2163 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2165 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2170 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2171 && type == ST_LABEL_FORMAT)
2173 gfc_error ("Label %d at %C previously used as branch target", labelno);
2178 lp->referenced = type;
2186 /*******A helper function for creating new expressions*************/
2190 gfc_lval_expr_from_sym (gfc_symbol *sym)
2193 lval = gfc_get_expr ();
2194 lval->expr_type = EXPR_VARIABLE;
2195 lval->where = sym->declared_at;
2197 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2199 /* It will always be a full array. */
2200 lval->rank = sym->as ? sym->as->rank : 0;
2203 lval->ref = gfc_get_ref ();
2204 lval->ref->type = REF_ARRAY;
2205 lval->ref->u.ar.type = AR_FULL;
2206 lval->ref->u.ar.dimen = lval->rank;
2207 lval->ref->u.ar.where = sym->declared_at;
2208 lval->ref->u.ar.as = sym->as;
2215 /************** Symbol table management subroutines ****************/
2217 /* Basic details: Fortran 95 requires a potentially unlimited number
2218 of distinct namespaces when compiling a program unit. This case
2219 occurs during a compilation of internal subprograms because all of
2220 the internal subprograms must be read before we can start
2221 generating code for the host.
2223 Given the tricky nature of the Fortran grammar, we must be able to
2224 undo changes made to a symbol table if the current interpretation
2225 of a statement is found to be incorrect. Whenever a symbol is
2226 looked up, we make a copy of it and link to it. All of these
2227 symbols are kept in a singly linked list so that we can commit or
2228 undo the changes at a later time.
2230 A symtree may point to a symbol node outside of its namespace. In
2231 this case, that symbol has been used as a host associated variable
2232 at some previous time. */
2234 /* Allocate a new namespace structure. Copies the implicit types from
2235 PARENT if PARENT_TYPES is set. */
2238 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2245 ns = XCNEW (gfc_namespace);
2246 ns->sym_root = NULL;
2247 ns->uop_root = NULL;
2248 ns->tb_sym_root = NULL;
2249 ns->finalizers = NULL;
2250 ns->default_access = ACCESS_UNKNOWN;
2251 ns->parent = parent;
2253 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2255 ns->operator_access[in] = ACCESS_UNKNOWN;
2256 ns->tb_op[in] = NULL;
2259 /* Initialize default implicit types. */
2260 for (i = 'a'; i <= 'z'; i++)
2262 ns->set_flag[i - 'a'] = 0;
2263 ts = &ns->default_type[i - 'a'];
2265 if (parent_types && ns->parent != NULL)
2267 /* Copy parent settings. */
2268 *ts = ns->parent->default_type[i - 'a'];
2272 if (gfc_option.flag_implicit_none != 0)
2278 if ('i' <= i && i <= 'n')
2280 ts->type = BT_INTEGER;
2281 ts->kind = gfc_default_integer_kind;
2286 ts->kind = gfc_default_real_kind;
2296 /* Comparison function for symtree nodes. */
2299 compare_symtree (void *_st1, void *_st2)
2301 gfc_symtree *st1, *st2;
2303 st1 = (gfc_symtree *) _st1;
2304 st2 = (gfc_symtree *) _st2;
2306 return strcmp (st1->name, st2->name);
2310 /* Allocate a new symtree node and associate it with the new symbol. */
2313 gfc_new_symtree (gfc_symtree **root, const char *name)
2317 st = XCNEW (gfc_symtree);
2318 st->name = gfc_get_string (name);
2320 gfc_insert_bbt (root, st, compare_symtree);
2325 /* Delete a symbol from the tree. Does not free the symbol itself! */
2328 gfc_delete_symtree (gfc_symtree **root, const char *name)
2330 gfc_symtree st, *st0;
2332 st0 = gfc_find_symtree (*root, name);
2334 st.name = gfc_get_string (name);
2335 gfc_delete_bbt (root, &st, compare_symtree);
2341 /* Given a root symtree node and a name, try to find the symbol within
2342 the namespace. Returns NULL if the symbol is not found. */
2345 gfc_find_symtree (gfc_symtree *st, const char *name)
2351 c = strcmp (name, st->name);
2355 st = (c < 0) ? st->left : st->right;
2362 /* Return a symtree node with a name that is guaranteed to be unique
2363 within the namespace and corresponds to an illegal fortran name. */
2366 gfc_get_unique_symtree (gfc_namespace *ns)
2368 char name[GFC_MAX_SYMBOL_LEN + 1];
2369 static int serial = 0;
2371 sprintf (name, "@%d", serial++);
2372 return gfc_new_symtree (&ns->sym_root, name);
2376 /* Given a name find a user operator node, creating it if it doesn't
2377 exist. These are much simpler than symbols because they can't be
2378 ambiguous with one another. */
2381 gfc_get_uop (const char *name)
2386 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2390 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2392 uop = st->n.uop = XCNEW (gfc_user_op);
2393 uop->name = gfc_get_string (name);
2394 uop->access = ACCESS_UNKNOWN;
2395 uop->ns = gfc_current_ns;
2401 /* Given a name find the user operator node. Returns NULL if it does
2405 gfc_find_uop (const char *name, gfc_namespace *ns)
2410 ns = gfc_current_ns;
2412 st = gfc_find_symtree (ns->uop_root, name);
2413 return (st == NULL) ? NULL : st->n.uop;
2417 /* Remove a gfc_symbol structure and everything it points to. */
2420 gfc_free_symbol (gfc_symbol *sym)
2426 gfc_free_array_spec (sym->as);
2428 free_components (sym->components);
2430 gfc_free_expr (sym->value);
2432 gfc_free_namelist (sym->namelist);
2434 gfc_free_namespace (sym->formal_ns);
2436 if (!sym->attr.generic_copy)
2437 gfc_free_interface (sym->generic);
2439 gfc_free_formal_arglist (sym->formal);
2441 gfc_free_namespace (sym->f2k_derived);
2447 /* Allocate and initialize a new symbol node. */
2450 gfc_new_symbol (const char *name, gfc_namespace *ns)
2454 p = XCNEW (gfc_symbol);
2456 gfc_clear_ts (&p->ts);
2457 gfc_clear_attr (&p->attr);
2460 p->declared_at = gfc_current_locus;
2462 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2463 gfc_internal_error ("new_symbol(): Symbol name too long");
2465 p->name = gfc_get_string (name);
2467 /* Make sure flags for symbol being C bound are clear initially. */
2468 p->attr.is_bind_c = 0;
2469 p->attr.is_iso_c = 0;
2470 /* Make sure the binding label field has a Nul char to start. */
2471 p->binding_label[0] = '\0';
2473 /* Clear the ptrs we may need. */
2474 p->common_block = NULL;
2475 p->f2k_derived = NULL;
2481 /* Generate an error if a symbol is ambiguous. */
2484 ambiguous_symbol (const char *name, gfc_symtree *st)
2487 if (st->n.sym->module)
2488 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2489 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2491 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2492 "from current program unit", name, st->n.sym->name);
2496 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2497 selector on the stack. If yes, replace it by the corresponding temporary. */
2500 select_type_insert_tmp (gfc_symtree **st)
2502 gfc_select_type_stack *stack = select_type_stack;
2503 for (; stack; stack = stack->prev)
2504 if ((*st)->n.sym == stack->selector && stack->tmp)
2509 /* Search for a symtree starting in the current namespace, resorting to
2510 any parent namespaces if requested by a nonzero parent_flag.
2511 Returns nonzero if the name is ambiguous. */
2514 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2515 gfc_symtree **result)
2520 ns = gfc_current_ns;
2524 st = gfc_find_symtree (ns->sym_root, name);
2527 select_type_insert_tmp (&st);
2530 /* Ambiguous generic interfaces are permitted, as long
2531 as the specific interfaces are different. */
2532 if (st->ambiguous && !st->n.sym->attr.generic)
2534 ambiguous_symbol (name, st);
2553 /* Same, but returns the symbol instead. */
2556 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2557 gfc_symbol **result)
2562 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2567 *result = st->n.sym;
2573 /* Save symbol with the information necessary to back it out. */
2576 save_symbol_data (gfc_symbol *sym)
2579 if (sym->gfc_new || sym->old_symbol != NULL)
2582 sym->old_symbol = XCNEW (gfc_symbol);
2583 *(sym->old_symbol) = *sym;
2585 sym->tlink = changed_syms;
2590 /* Given a name, find a symbol, or create it if it does not exist yet
2591 in the current namespace. If the symbol is found we make sure that
2594 The integer return code indicates
2596 1 The symbol name was ambiguous
2597 2 The name meant to be established was already host associated.
2599 So if the return value is nonzero, then an error was issued. */
2602 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2603 bool allow_subroutine)
2608 /* This doesn't usually happen during resolution. */
2610 ns = gfc_current_ns;
2612 /* Try to find the symbol in ns. */
2613 st = gfc_find_symtree (ns->sym_root, name);
2617 /* If not there, create a new symbol. */
2618 p = gfc_new_symbol (name, ns);
2620 /* Add to the list of tentative symbols. */
2621 p->old_symbol = NULL;
2622 p->tlink = changed_syms;
2627 st = gfc_new_symtree (&ns->sym_root, name);
2634 /* Make sure the existing symbol is OK. Ambiguous
2635 generic interfaces are permitted, as long as the
2636 specific interfaces are different. */
2637 if (st->ambiguous && !st->n.sym->attr.generic)
2639 ambiguous_symbol (name, st);
2644 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2645 && !(allow_subroutine && p->attr.subroutine)
2646 && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2647 && (ns->has_import_set || p->attr.imported)))
2649 /* Symbol is from another namespace. */
2650 gfc_error ("Symbol '%s' at %C has already been host associated",
2657 /* Copy in case this symbol is changed. */
2658 save_symbol_data (p);
2667 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2672 i = gfc_get_sym_tree (name, ns, &st, false);
2677 *result = st->n.sym;
2684 /* Subroutine that searches for a symbol, creating it if it doesn't
2685 exist, but tries to host-associate the symbol if possible. */
2688 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2693 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2697 save_symbol_data (st->n.sym);
2702 if (gfc_current_ns->parent != NULL)
2704 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2715 return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2720 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2725 i = gfc_get_ha_sym_tree (name, &st);
2728 *result = st->n.sym;
2735 /* Return true if both symbols could refer to the same data object. Does
2736 not take account of aliasing due to equivalence statements. */
2739 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2741 /* Aliasing isn't possible if the symbols have different base types. */
2742 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2745 /* Pointers can point to other pointers, target objects and allocatable
2746 objects. Two allocatable objects cannot share the same storage. */
2747 if (lsym->attr.pointer
2748 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2750 if (lsym->attr.target && rsym->attr.pointer)
2752 if (lsym->attr.allocatable && rsym->attr.pointer)
2759 /* Undoes all the changes made to symbols in the current statement.
2760 This subroutine is made simpler due to the fact that attributes are
2761 never removed once added. */
2764 gfc_undo_symbols (void)
2766 gfc_symbol *p, *q, *old;
2767 tentative_tbp *tbp, *tbq;
2769 for (p = changed_syms; p; p = q)
2775 /* Symbol was new. */
2776 if (p->attr.in_common && p->common_block && p->common_block->head)
2778 /* If the symbol was added to any common block, it
2779 needs to be removed to stop the resolver looking
2780 for a (possibly) dead symbol. */
2782 if (p->common_block->head == p)
2783 p->common_block->head = p->common_next;
2786 gfc_symbol *cparent, *csym;
2788 cparent = p->common_block->head;
2789 csym = cparent->common_next;
2794 csym = csym->common_next;
2797 gcc_assert(cparent->common_next == p);
2799 cparent->common_next = csym->common_next;
2803 gfc_delete_symtree (&p->ns->sym_root, p->name);
2807 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2809 gfc_free_symbol (p);
2813 /* Restore previous state of symbol. Just copy simple stuff. */
2815 old = p->old_symbol;
2817 p->ts.type = old->ts.type;
2818 p->ts.kind = old->ts.kind;
2820 p->attr = old->attr;
2822 if (p->value != old->value)
2824 gfc_free_expr (old->value);
2828 if (p->as != old->as)
2831 gfc_free_array_spec (p->as);
2835 p->generic = old->generic;
2836 p->component_access = old->component_access;
2838 if (p->namelist != NULL && old->namelist == NULL)
2840 gfc_free_namelist (p->namelist);
2845 if (p->namelist_tail != old->namelist_tail)
2847 gfc_free_namelist (old->namelist_tail);
2848 old->namelist_tail->next = NULL;
2852 p->namelist_tail = old->namelist_tail;
2854 if (p->formal != old->formal)
2856 gfc_free_formal_arglist (p->formal);
2857 p->formal = old->formal;
2860 gfc_free (p->old_symbol);
2861 p->old_symbol = NULL;
2865 changed_syms = NULL;
2867 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2870 /* Procedure is already marked `error' by default. */
2873 tentative_tbp_list = NULL;
2877 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2878 components of old_symbol that might need deallocation are the "allocatables"
2879 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2880 namelist_tail. In case these differ between old_symbol and sym, it's just
2881 because sym->namelist has gotten a few more items. */
2884 free_old_symbol (gfc_symbol *sym)
2887 if (sym->old_symbol == NULL)
2890 if (sym->old_symbol->as != sym->as)
2891 gfc_free_array_spec (sym->old_symbol->as);
2893 if (sym->old_symbol->value != sym->value)
2894 gfc_free_expr (sym->old_symbol->value);
2896 if (sym->old_symbol->formal != sym->formal)
2897 gfc_free_formal_arglist (sym->old_symbol->formal);
2899 gfc_free (sym->old_symbol);
2900 sym->old_symbol = NULL;
2904 /* Makes the changes made in the current statement permanent-- gets
2905 rid of undo information. */
2908 gfc_commit_symbols (void)
2911 tentative_tbp *tbp, *tbq;
2913 for (p = changed_syms; p; p = q)
2919 free_old_symbol (p);
2921 changed_syms = NULL;
2923 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2926 tbp->proc->error = 0;
2929 tentative_tbp_list = NULL;
2933 /* Makes the changes made in one symbol permanent -- gets rid of undo
2937 gfc_commit_symbol (gfc_symbol *sym)
2941 if (changed_syms == sym)
2942 changed_syms = sym->tlink;
2945 for (p = changed_syms; p; p = p->tlink)
2946 if (p->tlink == sym)
2948 p->tlink = sym->tlink;
2957 free_old_symbol (sym);
2961 /* Recursively free trees containing type-bound procedures. */
2964 free_tb_tree (gfc_symtree *t)
2969 free_tb_tree (t->left);
2970 free_tb_tree (t->right);
2972 /* TODO: Free type-bound procedure structs themselves; probably needs some
2973 sort of ref-counting mechanism. */
2979 /* Recursive function that deletes an entire tree and all the common
2980 head structures it points to. */
2983 free_common_tree (gfc_symtree * common_tree)
2985 if (common_tree == NULL)
2988 free_common_tree (common_tree->left);
2989 free_common_tree (common_tree->right);
2991 gfc_free (common_tree);
2995 /* Recursive function that deletes an entire tree and all the user
2996 operator nodes that it contains. */
2999 free_uop_tree (gfc_symtree *uop_tree)
3001 if (uop_tree == NULL)
3004 free_uop_tree (uop_tree->left);
3005 free_uop_tree (uop_tree->right);
3007 gfc_free_interface (uop_tree->n.uop->op);
3008 gfc_free (uop_tree->n.uop);
3009 gfc_free (uop_tree);
3013 /* Recursive function that deletes an entire tree and all the symbols
3014 that it contains. */
3017 free_sym_tree (gfc_symtree *sym_tree)
3022 if (sym_tree == NULL)
3025 free_sym_tree (sym_tree->left);
3026 free_sym_tree (sym_tree->right);
3028 sym = sym_tree->n.sym;
3032 gfc_internal_error ("free_sym_tree(): Negative refs");
3034 if (sym->formal_ns != NULL && sym->refs == 1)
3036 /* As formal_ns contains a reference to sym, delete formal_ns just
3037 before the deletion of sym. */
3038 ns = sym->formal_ns;
3039 sym->formal_ns = NULL;
3040 gfc_free_namespace (ns);
3042 else if (sym->refs == 0)
3044 /* Go ahead and delete the symbol. */
3045 gfc_free_symbol (sym);
3048 gfc_free (sym_tree);
3052 /* Free the derived type list. */
3055 gfc_free_dt_list (void)
3057 gfc_dt_list *dt, *n;
3059 for (dt = gfc_derived_types; dt; dt = n)
3065 gfc_derived_types = NULL;
3069 /* Free the gfc_equiv_info's. */
3072 gfc_free_equiv_infos (gfc_equiv_info *s)
3076 gfc_free_equiv_infos (s->next);
3081 /* Free the gfc_equiv_lists. */
3084 gfc_free_equiv_lists (gfc_equiv_list *l)
3088 gfc_free_equiv_lists (l->next);
3089 gfc_free_equiv_infos (l->equiv);
3094 /* Free a finalizer procedure list. */
3097 gfc_free_finalizer (gfc_finalizer* el)
3103 --el->proc_sym->refs;
3104 if (!el->proc_sym->refs)
3105 gfc_free_symbol (el->proc_sym);
3113 gfc_free_finalizer_list (gfc_finalizer* list)
3117 gfc_finalizer* current = list;
3119 gfc_free_finalizer (current);
3124 /* Create a new gfc_charlen structure and add it to a namespace.
3125 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3128 gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3131 cl = gfc_get_charlen ();
3133 /* Put into namespace. */
3134 cl->next = ns->cl_list;
3140 cl->length = gfc_copy_expr (old_cl->length);
3141 cl->length_from_typespec = old_cl->length_from_typespec;
3142 cl->backend_decl = old_cl->backend_decl;
3143 cl->passed_length = old_cl->passed_length;
3144 cl->resolved = old_cl->resolved;
3151 /* Free the charlen list from cl to end (end is not freed).
3152 Free the whole list if end is NULL. */
3154 void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3158 for (; cl != end; cl = cl2)
3163 gfc_free_expr (cl->length);
3169 /* Free a namespace structure and everything below it. Interface
3170 lists associated with intrinsic operators are not freed. These are
3171 taken care of when a specific name is freed. */
3174 gfc_free_namespace (gfc_namespace *ns)
3176 gfc_namespace *p, *q;
3185 gcc_assert (ns->refs == 0);
3187 gfc_free_statements (ns->code);
3189 free_sym_tree (ns->sym_root);
3190 free_uop_tree (ns->uop_root);
3191 free_common_tree (ns->common_root);
3192 free_tb_tree (ns->tb_sym_root);
3193 free_tb_tree (ns->tb_uop_root);
3194 gfc_free_finalizer_list (ns->finalizers);
3195 gfc_free_charlen (ns->cl_list, NULL);
3196 free_st_labels (ns->st_labels);
3198 gfc_free_equiv (ns->equiv);
3199 gfc_free_equiv_lists (ns->equiv_lists);
3200 gfc_free_use_stmts (ns->use_stmts);
3202 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3203 gfc_free_interface (ns->op[i]);
3205 gfc_free_data (ns->data);
3209 /* Recursively free any contained namespaces. */
3214 gfc_free_namespace (q);
3220 gfc_symbol_init_2 (void)
3223 gfc_current_ns = gfc_get_namespace (NULL, 0);
3228 gfc_symbol_done_2 (void)
3231 gfc_free_namespace (gfc_current_ns);
3232 gfc_current_ns = NULL;
3233 gfc_free_dt_list ();
3237 /* Clear mark bits from symbol nodes associated with a symtree node. */
3240 clear_sym_mark (gfc_symtree *st)
3243 st->n.sym->mark = 0;
3247 /* Recursively traverse the symtree nodes. */
3250 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
3255 gfc_traverse_symtree (st->left, func);
3257 gfc_traverse_symtree (st->right, func);
3261 /* Recursive namespace traversal function. */
3264 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
3270 traverse_ns (st->left, func);
3272 if (st->n.sym->mark == 0)
3273 (*func) (st->n.sym);
3274 st->n.sym->mark = 1;
3276 traverse_ns (st->right, func);
3280 /* Call a given function for all symbols in the namespace. We take
3281 care that each gfc_symbol node is called exactly once. */
3284 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3287 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3289 traverse_ns (ns->sym_root, func);
3293 /* Return TRUE when name is the name of an intrinsic type. */
3296 gfc_is_intrinsic_typename (const char *name)
3298 if (strcmp (name, "integer") == 0
3299 || strcmp (name, "real") == 0
3300 || strcmp (name, "character") == 0
3301 || strcmp (name, "logical") == 0
3302 || strcmp (name, "complex") == 0
3303 || strcmp (name, "doubleprecision") == 0
3304 || strcmp (name, "doublecomplex") == 0)
3311 /* Return TRUE if the symbol is an automatic variable. */
3314 gfc_is_var_automatic (gfc_symbol *sym)
3316 /* Pointer and allocatable variables are never automatic. */
3317 if (sym->attr.pointer || sym->attr.allocatable)
3319 /* Check for arrays with non-constant size. */
3320 if (sym->attr.dimension && sym->as
3321 && !gfc_is_compile_time_shape (sym->as))
3323 /* Check for non-constant length character variables. */
3324 if (sym->ts.type == BT_CHARACTER
3326 && !gfc_is_constant_expr (sym->ts.u.cl->length))
3331 /* Given a symbol, mark it as SAVEd if it is allowed. */
3334 save_symbol (gfc_symbol *sym)
3337 if (sym->attr.use_assoc)
3340 if (sym->attr.in_common
3343 || sym->attr.flavor != FL_VARIABLE)
3345 /* Automatic objects are not saved. */
3346 if (gfc_is_var_automatic (sym))
3348 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3352 /* Mark those symbols which can be SAVEd as such. */
3355 gfc_save_all (gfc_namespace *ns)
3357 gfc_traverse_ns (ns, save_symbol);
3362 /* Make sure that no changes to symbols are pending. */
3365 gfc_symbol_state(void) {
3367 if (changed_syms != NULL)
3368 gfc_internal_error("Symbol changes still pending!");
3373 /************** Global symbol handling ************/
3376 /* Search a tree for the global symbol. */
3379 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3388 c = strcmp (name, symbol->name);
3392 symbol = (c < 0) ? symbol->left : symbol->right;
3399 /* Compare two global symbols. Used for managing the BB tree. */
3402 gsym_compare (void *_s1, void *_s2)
3404 gfc_gsymbol *s1, *s2;
3406 s1 = (gfc_gsymbol *) _s1;
3407 s2 = (gfc_gsymbol *) _s2;
3408 return strcmp (s1->name, s2->name);
3412 /* Get a global symbol, creating it if it doesn't exist. */
3415 gfc_get_gsymbol (const char *name)
3419 s = gfc_find_gsymbol (gfc_gsym_root, name);
3423 s = XCNEW (gfc_gsymbol);
3424 s->type = GSYM_UNKNOWN;
3425 s->name = gfc_get_string (name);
3427 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3434 get_iso_c_binding_dt (int sym_id)
3436 gfc_dt_list *dt_list;
3438 dt_list = gfc_derived_types;
3440 /* Loop through the derived types in the name list, searching for
3441 the desired symbol from iso_c_binding. Search the parent namespaces
3442 if necessary and requested to (parent_flag). */
3443 while (dt_list != NULL)
3445 if (dt_list->derived->from_intmod != INTMOD_NONE
3446 && dt_list->derived->intmod_sym_id == sym_id)
3447 return dt_list->derived;
3449 dt_list = dt_list->next;
3456 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3457 with C. This is necessary for any derived type that is BIND(C) and for
3458 derived types that are parameters to functions that are BIND(C). All
3459 fields of the derived type are required to be interoperable, and are tested
3460 for such. If an error occurs, the errors are reported here, allowing for
3461 multiple errors to be handled for a single derived type. */
3464 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3466 gfc_component *curr_comp = NULL;
3467 gfc_try is_c_interop = FAILURE;
3468 gfc_try retval = SUCCESS;
3470 if (derived_sym == NULL)
3471 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3472 "unexpectedly NULL");
3474 /* If we've already looked at this derived symbol, do not look at it again
3475 so we don't repeat warnings/errors. */
3476 if (derived_sym->ts.is_c_interop)
3479 /* The derived type must have the BIND attribute to be interoperable
3480 J3/04-007, Section 15.2.3. */
3481 if (derived_sym->attr.is_bind_c != 1)
3483 derived_sym->ts.is_c_interop = 0;
3484 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3485 "attribute to be C interoperable", derived_sym->name,
3486 &(derived_sym->declared_at));
3490 curr_comp = derived_sym->components;
3492 /* TODO: is this really an error? */
3493 if (curr_comp == NULL)
3495 gfc_error ("Derived type '%s' at %L is empty",
3496 derived_sym->name, &(derived_sym->declared_at));
3500 /* Initialize the derived type as being C interoperable.
3501 If we find an error in the components, this will be set false. */
3502 derived_sym->ts.is_c_interop = 1;
3504 /* Loop through the list of components to verify that the kind of
3505 each is a C interoperable type. */
3508 /* The components cannot be pointers (fortran sense).
3509 J3/04-007, Section 15.2.3, C1505. */
3510 if (curr_comp->attr.pointer != 0)
3512 gfc_error ("Component '%s' at %L cannot have the "
3513 "POINTER attribute because it is a member "
3514 "of the BIND(C) derived type '%s' at %L",
3515 curr_comp->name, &(curr_comp->loc),
3516 derived_sym->name, &(derived_sym->declared_at));
3520 if (curr_comp->attr.proc_pointer != 0)
3522 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3523 " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3524 &curr_comp->loc, derived_sym->name,
3525 &derived_sym->declared_at);
3529 /* The components cannot be allocatable.
3530 J3/04-007, Section 15.2.3, C1505. */
3531 if (curr_comp->attr.allocatable != 0)
3533 gfc_error ("Component '%s' at %L cannot have the "
3534 "ALLOCATABLE attribute because it is a member "
3535 "of the BIND(C) derived type '%s' at %L",
3536 curr_comp->name, &(curr_comp->loc),
3537 derived_sym->name, &(derived_sym->declared_at));
3541 /* BIND(C) derived types must have interoperable components. */
3542 if (curr_comp->ts.type == BT_DERIVED
3543 && curr_comp->ts.u.derived->ts.is_iso_c != 1
3544 && curr_comp->ts.u.derived != derived_sym)
3546 /* This should be allowed; the draft says a derived-type can not
3547 have type parameters if it is has the BIND attribute. Type
3548 parameters seem to be for making parameterized derived types.
3549 There's no need to verify the type if it is c_ptr/c_funptr. */
3550 retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3554 /* Grab the typespec for the given component and test the kind. */
3555 is_c_interop = verify_c_interop (&(curr_comp->ts));
3557 if (is_c_interop != SUCCESS)
3559 /* Report warning and continue since not fatal. The
3560 draft does specify a constraint that requires all fields
3561 to interoperate, but if the user says real(4), etc., it
3562 may interoperate with *something* in C, but the compiler
3563 most likely won't know exactly what. Further, it may not
3564 interoperate with the same data type(s) in C if the user
3565 recompiles with different flags (e.g., -m32 and -m64 on
3566 x86_64 and using integer(4) to claim interop with a
3568 if (derived_sym->attr.is_bind_c == 1)
3569 /* If the derived type is bind(c), all fields must be
3571 gfc_warning ("Component '%s' in derived type '%s' at %L "
3572 "may not be C interoperable, even though "
3573 "derived type '%s' is BIND(C)",
3574 curr_comp->name, derived_sym->name,
3575 &(curr_comp->loc), derived_sym->name);
3577 /* If derived type is param to bind(c) routine, or to one
3578 of the iso_c_binding procs, it must be interoperable, so
3579 all fields must interop too. */
3580 gfc_warning ("Component '%s' in derived type '%s' at %L "
3581 "may not be C interoperable",
3582 curr_comp->name, derived_sym->name,
3587 curr_comp = curr_comp->next;
3588 } while (curr_comp != NULL);
3591 /* Make sure we don't have conflicts with the attributes. */
3592 if (derived_sym->attr.access == ACCESS_PRIVATE)
3594 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3595 "PRIVATE and BIND(C) attributes", derived_sym->name,
3596 &(derived_sym->declared_at));
3600 if (derived_sym->attr.sequence != 0)
3602 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3603 "attribute because it is BIND(C)", derived_sym->name,
3604 &(derived_sym->declared_at));
3608 /* Mark the derived type as not being C interoperable if we found an
3609 error. If there were only warnings, proceed with the assumption
3610 it's interoperable. */
3611 if (retval == FAILURE)
3612 derived_sym->ts.is_c_interop = 0;
3618 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3621 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3622 const char *module_name)
3624 gfc_symtree *tmp_symtree;
3625 gfc_symbol *tmp_sym;
3627 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3629 if (tmp_symtree != NULL)
3630 tmp_sym = tmp_symtree->n.sym;
3634 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3635 "create symbol for %s", ptr_name);
3638 /* Set up the symbol's important fields. Save attr required so we can
3639 initialize the ptr to NULL. */
3640 tmp_sym->attr.save = SAVE_EXPLICIT;
3641 tmp_sym->ts.is_c_interop = 1;
3642 tmp_sym->attr.is_c_interop = 1;
3643 tmp_sym->ts.is_iso_c = 1;
3644 tmp_sym->ts.type = BT_DERIVED;
3646 /* The c_ptr and c_funptr derived types will provide the
3647 definition for c_null_ptr and c_null_funptr, respectively. */
3648 if (ptr_id == ISOCBINDING_NULL_PTR)
3649 tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3651 tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3652 if (tmp_sym->ts.u.derived == NULL)
3654 /* This can occur if the user forgot to declare c_ptr or
3655 c_funptr and they're trying to use one of the procedures
3656 that has arg(s) of the missing type. In this case, a
3657 regular version of the thing should have been put in the
3659 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3660 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3661 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3662 ? "_gfortran_iso_c_binding_c_ptr"
3663 : "_gfortran_iso_c_binding_c_funptr"));
3665 tmp_sym->ts.u.derived =
3666 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3667 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3670 /* Module name is some mangled version of iso_c_binding. */
3671 tmp_sym->module = gfc_get_string (module_name);
3673 /* Say it's from the iso_c_binding module. */
3674 tmp_sym->attr.is_iso_c = 1;
3676 tmp_sym->attr.use_assoc = 1;
3677 tmp_sym->attr.is_bind_c = 1;
3678 /* Set the binding_label. */
3679 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3681 /* Set the c_address field of c_null_ptr and c_null_funptr to
3682 the value of NULL. */
3683 tmp_sym->value = gfc_get_expr ();
3684 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3685 tmp_sym->value->ts.type = BT_DERIVED;
3686 tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
3687 tmp_sym->value->value.constructor = gfc_get_constructor ();
3688 tmp_sym->value->value.constructor->expr = gfc_get_expr ();
3689 tmp_sym->value->value.constructor->expr->expr_type = EXPR_NULL;
3690 tmp_sym->value->value.constructor->expr->ts.is_iso_c = 1;
3691 /* Must declare c_null_ptr and c_null_funptr as having the
3692 PARAMETER attribute so they can be used in init expressions. */
3693 tmp_sym->attr.flavor = FL_PARAMETER;
3699 /* Add a formal argument, gfc_formal_arglist, to the
3700 end of the given list of arguments. Set the reference to the
3701 provided symbol, param_sym, in the argument. */
3704 add_formal_arg (gfc_formal_arglist **head,
3705 gfc_formal_arglist **tail,
3706 gfc_formal_arglist *formal_arg,
3707 gfc_symbol *param_sym)
3709 /* Put in list, either as first arg or at the tail (curr arg). */
3711 *head = *tail = formal_arg;
3714 (*tail)->next = formal_arg;
3715 (*tail) = formal_arg;
3718 (*tail)->sym = param_sym;
3719 (*tail)->next = NULL;
3725 /* Generates a symbol representing the CPTR argument to an
3726 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3727 CPTR and add it to the provided argument list. */
3730 gen_cptr_param (gfc_formal_arglist **head,
3731 gfc_formal_arglist **tail,
3732 const char *module_name,
3733 gfc_namespace *ns, const char *c_ptr_name,
3736 gfc_symbol *param_sym = NULL;
3737 gfc_symbol *c_ptr_sym = NULL;
3738 gfc_symtree *param_symtree = NULL;
3739 gfc_formal_arglist *formal_arg = NULL;
3740 const char *c_ptr_in;
3741 const char *c_ptr_type = NULL;
3743 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3744 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3746 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3748 if(c_ptr_name == NULL)
3749 c_ptr_in = "gfc_cptr__";
3751 c_ptr_in = c_ptr_name;
3752 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree, false);
3753 if (param_symtree != NULL)
3754 param_sym = param_symtree->n.sym;
3756 gfc_internal_error ("gen_cptr_param(): Unable to "
3757 "create symbol for %s", c_ptr_in);
3759 /* Set up the appropriate fields for the new c_ptr param sym. */
3761 param_sym->attr.flavor = FL_DERIVED;
3762 param_sym->ts.type = BT_DERIVED;
3763 param_sym->attr.intent = INTENT_IN;
3764 param_sym->attr.dummy = 1;
3766 /* This will pass the ptr to the iso_c routines as a (void *). */
3767 param_sym->attr.value = 1;
3768 param_sym->attr.use_assoc = 1;
3770 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3772 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3773 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3775 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3776 if (c_ptr_sym == NULL)
3778 /* This can happen if the user did not define c_ptr but they are
3779 trying to use one of the iso_c_binding functions that need it. */
3780 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3781 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3782 (const char *)c_ptr_type);
3784 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3785 (const char *)c_ptr_type);
3787 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3790 param_sym->ts.u.derived = c_ptr_sym;
3791 param_sym->module = gfc_get_string (module_name);
3793 /* Make new formal arg. */
3794 formal_arg = gfc_get_formal_arglist ();
3795 /* Add arg to list of formal args (the CPTR arg). */
3796 add_formal_arg (head, tail, formal_arg, param_sym);
3800 /* Generates a symbol representing the FPTR argument to an
3801 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3802 FPTR and add it to the provided argument list. */
3805 gen_fptr_param (gfc_formal_arglist **head,
3806 gfc_formal_arglist **tail,
3807 const char *module_name,
3808 gfc_namespace *ns, const char *f_ptr_name, int proc)
3810 gfc_symbol *param_sym = NULL;
3811 gfc_symtree *param_symtree = NULL;
3812 gfc_formal_arglist *formal_arg = NULL;
3813 const char *f_ptr_out = "gfc_fptr__";
3815 if (f_ptr_name != NULL)
3816 f_ptr_out = f_ptr_name;
3818 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree, false);
3819 if (param_symtree != NULL)
3820 param_sym = param_symtree->n.sym;
3822 gfc_internal_error ("generateFPtrParam(): Unable to "
3823 "create symbol for %s", f_ptr_out);
3825 /* Set up the necessary fields for the fptr output param sym. */
3828 param_sym->attr.proc_pointer = 1;
3830 param_sym->attr.pointer = 1;
3831 param_sym->attr.dummy = 1;
3832 param_sym->attr.use_assoc = 1;
3834 /* ISO C Binding type to allow any pointer type as actual param. */
3835 param_sym->ts.type = BT_VOID;
3836 param_sym->module = gfc_get_string (module_name);
3839 formal_arg = gfc_get_formal_arglist ();
3840 /* Add arg to list of formal args. */
3841 add_formal_arg (head, tail, formal_arg, param_sym);
3845 /* Generates a symbol representing the optional SHAPE argument for the
3846 iso_c_binding c_f_pointer() procedure. Also, create a
3847 gfc_formal_arglist for the SHAPE and add it to the provided
3851 gen_shape_param (gfc_formal_arglist **head,
3852 gfc_formal_arglist **tail,
3853 const char *module_name,
3854 gfc_namespace *ns, const char *shape_param_name)
3856 gfc_symbol *param_sym = NULL;
3857 gfc_symtree *param_symtree = NULL;
3858 gfc_formal_arglist *formal_arg = NULL;
3859 const char *shape_param = "gfc_shape_array__";
3862 if (shape_param_name != NULL)
3863 shape_param = shape_param_name;
3865 gfc_get_sym_tree (shape_param, ns, ¶m_symtree, false);
3866 if (param_symtree != NULL)
3867 param_sym = param_symtree->n.sym;
3869 gfc_internal_error ("generateShapeParam(): Unable to "
3870 "create symbol for %s", shape_param);
3872 /* Set up the necessary fields for the shape input param sym. */
3874 param_sym->attr.dummy = 1;
3875 param_sym->attr.use_assoc = 1;
3877 /* Integer array, rank 1, describing the shape of the object. Make it's
3878 type BT_VOID initially so we can accept any type/kind combination of
3879 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3880 of BT_INTEGER type. */
3881 param_sym->ts.type = BT_VOID;
3883 /* Initialize the kind to default integer. However, it will be overridden
3884 during resolution to match the kind of the SHAPE parameter given as
3885 the actual argument (to allow for any valid integer kind). */
3886 param_sym->ts.kind = gfc_default_integer_kind;
3887 param_sym->as = gfc_get_array_spec ();
3889 /* Clear out the dimension info for the array. */
3890 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3892 param_sym->as->lower[i] = NULL;
3893 param_sym->as->upper[i] = NULL;
3895 param_sym->as->rank = 1;
3896 param_sym->as->lower[0] = gfc_int_expr (1);
3898 /* The extent is unknown until we get it. The length give us
3899 the rank the incoming pointer. */
3900 param_sym->as->type = AS_ASSUMED_SHAPE;
3902 /* The arg is also optional; it is required iff the second arg
3903 (fptr) is to an array, otherwise, it's ignored. */
3904 param_sym->attr.optional = 1;
3905 param_sym->attr.intent = INTENT_IN;
3906 param_sym->attr.dimension = 1;
3907 param_sym->module = gfc_get_string (module_name);
3910 formal_arg = gfc_get_formal_arglist ();
3911 /* Add arg to list of formal args. */
3912 add_formal_arg (head, tail, formal_arg, param_sym);
3916 /* Add a procedure interface to the given symbol (i.e., store a
3917 reference to the list of formal arguments). */
3920 add_proc_interface (gfc_symbol *sym, ifsrc source,
3921 gfc_formal_arglist *formal)
3924 sym->formal = formal;
3925 sym->attr.if_source = source;
3929 /* Copy the formal args from an existing symbol, src, into a new
3930 symbol, dest. New formal args are created, and the description of
3931 each arg is set according to the existing ones. This function is
3932 used when creating procedure declaration variables from a procedure
3933 declaration statement (see match_proc_decl()) to create the formal
3934 args based on the args of a given named interface. */
3937 gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
3939 gfc_formal_arglist *head = NULL;
3940 gfc_formal_arglist *tail = NULL;
3941 gfc_formal_arglist *formal_arg = NULL;
3942 gfc_formal_arglist *curr_arg = NULL;
3943 gfc_formal_arglist *formal_prev = NULL;
3944 /* Save current namespace so we can change it for formal args. */
3945 gfc_namespace *parent_ns = gfc_current_ns;
3947 /* Create a new namespace, which will be the formal ns (namespace
3948 of the formal args). */
3949 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3950 gfc_current_ns->proc_name = dest;
3952 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3954 formal_arg = gfc_get_formal_arglist ();
3955 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
3957 /* May need to copy more info for the symbol. */
3958 formal_arg->sym->attr = curr_arg->sym->attr;
3959 formal_arg->sym->ts = curr_arg->sym->ts;
3960 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
3961 gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
3963 /* If this isn't the first arg, set up the next ptr. For the
3964 last arg built, the formal_arg->next will never get set to
3965 anything other than NULL. */
3966 if (formal_prev != NULL)
3967 formal_prev->next = formal_arg;
3969 formal_arg->next = NULL;
3971 formal_prev = formal_arg;
3973 /* Add arg to list of formal args. */
3974 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3977 /* Add the interface to the symbol. */
3978 add_proc_interface (dest, IFSRC_DECL, head);
3980 /* Store the formal namespace information. */
3981 if (dest->formal != NULL)
3982 /* The current ns should be that for the dest proc. */
3983 dest->formal_ns = gfc_current_ns;
3984 /* Restore the current namespace to what it was on entry. */
3985 gfc_current_ns = parent_ns;
3990 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
3992 gfc_formal_arglist *head = NULL;
3993 gfc_formal_arglist *tail = NULL;
3994 gfc_formal_arglist *formal_arg = NULL;
3995 gfc_intrinsic_arg *curr_arg = NULL;
3996 gfc_formal_arglist *formal_prev = NULL;
3997 /* Save current namespace so we can change it for formal args. */
3998 gfc_namespace *parent_ns = gfc_current_ns;
4000 /* Create a new namespace, which will be the formal ns (namespace
4001 of the formal args). */
4002 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4003 gfc_current_ns->proc_name = dest;
4005 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4007 formal_arg = gfc_get_formal_arglist ();
4008 gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4010 /* May need to copy more info for the symbol. */
4011 formal_arg->sym->ts = curr_arg->ts;
4012 formal_arg->sym->attr.optional = curr_arg->optional;
4013 formal_arg->sym->attr.intent = curr_arg->intent;
4014 formal_arg->sym->attr.flavor = FL_VARIABLE;
4015 formal_arg->sym->attr.dummy = 1;
4017 if (formal_arg->sym->ts.type == BT_CHARACTER)
4018 formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4020 /* If this isn't the first arg, set up the next ptr. For the
4021 last arg built, the formal_arg->next will never get set to
4022 anything other than NULL. */
4023 if (formal_prev != NULL)
4024 formal_prev->next = formal_arg;
4026 formal_arg->next = NULL;
4028 formal_prev = formal_arg;
4030 /* Add arg to list of formal args. */
4031 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4034 /* Add the interface to the symbol. */
4035 add_proc_interface (dest, IFSRC_DECL, head);
4037 /* Store the formal namespace information. */
4038 if (dest->formal != NULL)
4039 /* The current ns should be that for the dest proc. */
4040 dest->formal_ns = gfc_current_ns;
4041 /* Restore the current namespace to what it was on entry. */
4042 gfc_current_ns = parent_ns;
4047 gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
4049 gfc_formal_arglist *head = NULL;
4050 gfc_formal_arglist *tail = NULL;
4051 gfc_formal_arglist *formal_arg = NULL;
4052 gfc_formal_arglist *curr_arg = NULL;
4053 gfc_formal_arglist *formal_prev = NULL;
4054 /* Save current namespace so we can change it for formal args. */
4055 gfc_namespace *parent_ns = gfc_current_ns;
4057 /* Create a new namespace, which will be the formal ns (namespace
4058 of the formal args). */
4059 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4060 /* TODO: gfc_current_ns->proc_name = dest;*/
4062 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4064 formal_arg = gfc_get_formal_arglist ();
4065 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
4067 /* May need to copy more info for the symbol. */
4068 formal_arg->sym->attr = curr_arg->sym->attr;
4069 formal_arg->sym->ts = curr_arg->sym->ts;
4070 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
4071 gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
4073 /* If this isn't the first arg, set up the next ptr. For the
4074 last arg built, the formal_arg->next will never get set to
4075 anything other than NULL. */
4076 if (formal_prev != NULL)
4077 formal_prev->next = formal_arg;
4079 formal_arg->next = NULL;
4081 formal_prev = formal_arg;
4083 /* Add arg to list of formal args. */
4084 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4087 /* Add the interface to the symbol. */
4088 dest->formal = head;
4089 dest->attr.if_source = IFSRC_DECL;
4091 /* Store the formal namespace information. */
4092 if (dest->formal != NULL)
4093 /* The current ns should be that for the dest proc. */
4094 dest->formal_ns = gfc_current_ns;
4095 /* Restore the current namespace to what it was on entry. */
4096 gfc_current_ns = parent_ns;
4100 /* Builds the parameter list for the iso_c_binding procedure
4101 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
4102 generic version of either the c_f_pointer or c_f_procpointer
4103 functions. The new_proc_sym represents a "resolved" version of the
4104 symbol. The functions are resolved to match the types of their
4105 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4106 something similar to c_f_pointer_i4 if the type of data object fptr
4107 pointed to was a default integer. The actual name of the resolved
4108 procedure symbol is further mangled with the module name, etc., but
4109 the idea holds true. */
4112 build_formal_args (gfc_symbol *new_proc_sym,
4113 gfc_symbol *old_sym, int add_optional_arg)
4115 gfc_formal_arglist *head = NULL, *tail = NULL;
4116 gfc_namespace *parent_ns = NULL;
4118 parent_ns = gfc_current_ns;
4119 /* Create a new namespace, which will be the formal ns (namespace
4120 of the formal args). */
4121 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
4122 gfc_current_ns->proc_name = new_proc_sym;
4124 /* Generate the params. */
4125 if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
4127 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4128 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4129 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4130 gfc_current_ns, "fptr", 1);
4132 else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
4134 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4135 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4136 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4137 gfc_current_ns, "fptr", 0);
4138 /* If we're dealing with c_f_pointer, it has an optional third arg. */
4139 gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
4140 gfc_current_ns, "shape");
4143 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
4145 /* c_associated has one required arg and one optional; both
4147 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4148 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
4149 if (add_optional_arg)
4151 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4152 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
4153 /* The last param is optional so mark it as such. */
4154 tail->sym->attr.optional = 1;
4158 /* Add the interface (store formal args to new_proc_sym). */
4159 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
4161 /* Set up the formal_ns pointer to the one created for the
4162 new procedure so it'll get cleaned up during gfc_free_symbol(). */
4163 new_proc_sym->formal_ns = gfc_current_ns;
4165 gfc_current_ns = parent_ns;
4169 std_for_isocbinding_symbol (int id)
4173 #define NAMED_INTCST(a,b,c,d) \
4176 #include "iso-c-binding.def"
4179 return GFC_STD_F2003;
4183 /* Generate the given set of C interoperable kind objects, or all
4184 interoperable kinds. This function will only be given kind objects
4185 for valid iso_c_binding defined types because this is verified when
4186 the 'use' statement is parsed. If the user gives an 'only' clause,
4187 the specific kinds are looked up; if they don't exist, an error is
4188 reported. If the user does not give an 'only' clause, all
4189 iso_c_binding symbols are generated. If a list of specific kinds
4190 is given, it must have a NULL in the first empty spot to mark the
4195 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4196 const char *local_name)
4198 const char *const name = (local_name && local_name[0]) ? local_name
4199 : c_interop_kinds_table[s].name;
4200 gfc_symtree *tmp_symtree = NULL;
4201 gfc_symbol *tmp_sym = NULL;
4202 gfc_dt_list **dt_list_ptr = NULL;
4203 gfc_component *tmp_comp = NULL;
4204 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
4207 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4209 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4211 /* Already exists in this scope so don't re-add it.
4212 TODO: we should probably check that it's really the same symbol. */
4213 if (tmp_symtree != NULL)
4216 /* Create the sym tree in the current ns. */
4217 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4219 tmp_sym = tmp_symtree->n.sym;
4221 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4224 /* Say what module this symbol belongs to. */
4225 tmp_sym->module = gfc_get_string (mod_name);
4226 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4227 tmp_sym->intmod_sym_id = s;
4232 #define NAMED_INTCST(a,b,c,d) case a :
4233 #define NAMED_REALCST(a,b,c) case a :
4234 #define NAMED_CMPXCST(a,b,c) case a :
4235 #define NAMED_LOGCST(a,b,c) case a :
4236 #define NAMED_CHARKNDCST(a,b,c) case a :
4237 #include "iso-c-binding.def"
4239 tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
4241 /* Initialize an integer constant expression node. */
4242 tmp_sym->attr.flavor = FL_PARAMETER;
4243 tmp_sym->ts.type = BT_INTEGER;
4244 tmp_sym->ts.kind = gfc_default_integer_kind;
4246 /* Mark this type as a C interoperable one. */
4247 tmp_sym->ts.is_c_interop = 1;
4248 tmp_sym->ts.is_iso_c = 1;
4249 tmp_sym->value->ts.is_c_interop = 1;
4250 tmp_sym->value->ts.is_iso_c = 1;
4251 tmp_sym->attr.is_c_interop = 1;
4253 /* Tell what f90 type this c interop kind is valid. */
4254 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4256 /* Say it's from the iso_c_binding module. */
4257 tmp_sym->attr.is_iso_c = 1;
4259 /* Make it use associated. */
4260 tmp_sym->attr.use_assoc = 1;
4264 #define NAMED_CHARCST(a,b,c) case a :
4265 #include "iso-c-binding.def"
4267 /* Initialize an integer constant expression node for the
4268 length of the character. */
4269 tmp_sym->value = gfc_get_expr ();
4270 tmp_sym->value->expr_type = EXPR_CONSTANT;
4271 tmp_sym->value->ts.type = BT_CHARACTER;
4272 tmp_sym->value->ts.kind = gfc_default_character_kind;
4273 tmp_sym->value->where = gfc_current_locus;
4274 tmp_sym->value->ts.is_c_interop = 1;
4275 tmp_sym->value->ts.is_iso_c = 1;
4276 tmp_sym->value->value.character.length = 1;
4277 tmp_sym->value->value.character.string = gfc_get_wide_string (2);
4278 tmp_sym->value->value.character.string[0]
4279 = (gfc_char_t) c_interop_kinds_table[s].value;
4280 tmp_sym->value->value.character.string[1] = '\0';
4281 tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4282 tmp_sym->ts.u.cl->length = gfc_int_expr (1);
4284 /* May not need this in both attr and ts, but do need in
4285 attr for writing module file. */
4286 tmp_sym->attr.is_c_interop = 1;
4288 tmp_sym->attr.flavor = FL_PARAMETER;
4289 tmp_sym->ts.type = BT_CHARACTER;
4291 /* Need to set it to the C_CHAR kind. */
4292 tmp_sym->ts.kind = gfc_default_character_kind;
4294 /* Mark this type as a C interoperable one. */
4295 tmp_sym->ts.is_c_interop = 1;
4296 tmp_sym->ts.is_iso_c = 1;
4298 /* Tell what f90 type this c interop kind is valid. */
4299 tmp_sym->ts.f90_type = BT_CHARACTER;
4301 /* Say it's from the iso_c_binding module. */
4302 tmp_sym->attr.is_iso_c = 1;
4304 /* Make it use associated. */
4305 tmp_sym->attr.use_assoc = 1;
4308 case ISOCBINDING_PTR:
4309 case ISOCBINDING_FUNPTR:
4311 /* Initialize an integer constant expression node. */
4312 tmp_sym->attr.flavor = FL_DERIVED;
4313 tmp_sym->ts.is_c_interop = 1;
4314 tmp_sym->attr.is_c_interop = 1;
4315 tmp_sym->attr.is_iso_c = 1;
4316 tmp_sym->ts.is_iso_c = 1;
4317 tmp_sym->ts.type = BT_DERIVED;
4319 /* A derived type must have the bind attribute to be
4320 interoperable (J3/04-007, Section 15.2.3), even though
4321 the binding label is not used. */
4322 tmp_sym->attr.is_bind_c = 1;
4324 tmp_sym->attr.referenced = 1;
4326 tmp_sym->ts.u.derived = tmp_sym;
4328 /* Add the symbol created for the derived type to the current ns. */
4329 dt_list_ptr = &(gfc_derived_types);
4330 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4331 dt_list_ptr = &((*dt_list_ptr)->next);
4333 /* There is already at least one derived type in the list, so append
4334 the one we're currently building for c_ptr or c_funptr. */
4335 if (*dt_list_ptr != NULL)
4336 dt_list_ptr = &((*dt_list_ptr)->next);
4337 (*dt_list_ptr) = gfc_get_dt_list ();
4338 (*dt_list_ptr)->derived = tmp_sym;
4339 (*dt_list_ptr)->next = NULL;
4341 /* Set up the component of the derived type, which will be
4342 an integer with kind equal to c_ptr_size. Mangle the name of
4343 the field for the c_address to prevent the curious user from
4344 trying to access it from Fortran. */
4345 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
4346 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
4347 if (tmp_comp == NULL)
4348 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4349 "create component for c_address");
4351 tmp_comp->ts.type = BT_INTEGER;
4353 /* Set this because the module will need to read/write this field. */
4354 tmp_comp->ts.f90_type = BT_INTEGER;
4356 /* The kinds for c_ptr and c_funptr are the same. */
4357 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4358 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4360 tmp_comp->attr.pointer = 0;
4361 tmp_comp->attr.dimension = 0;
4363 /* Mark the component as C interoperable. */
4364 tmp_comp->ts.is_c_interop = 1;
4366 /* Make it use associated (iso_c_binding module). */
4367 tmp_sym->attr.use_assoc = 1;
4370 case ISOCBINDING_NULL_PTR:
4371 case ISOCBINDING_NULL_FUNPTR:
4372 gen_special_c_interop_ptr (s, name, mod_name);
4375 case ISOCBINDING_F_POINTER:
4376 case ISOCBINDING_ASSOCIATED:
4377 case ISOCBINDING_LOC:
4378 case ISOCBINDING_FUNLOC:
4379 case ISOCBINDING_F_PROCPOINTER:
4381 tmp_sym->attr.proc = PROC_MODULE;
4383 /* Use the procedure's name as it is in the iso_c_binding module for
4384 setting the binding label in case the user renamed the symbol. */
4385 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
4386 c_interop_kinds_table[s].name);
4387 tmp_sym->attr.is_iso_c = 1;
4388 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4389 tmp_sym->attr.subroutine = 1;
4392 /* TODO! This needs to be finished more for the expr of the
4393 function or something!
4394 This may not need to be here, because trying to do c_loc
4396 if (s == ISOCBINDING_ASSOCIATED)
4398 tmp_sym->attr.function = 1;
4399 tmp_sym->ts.type = BT_LOGICAL;
4400 tmp_sym->ts.kind = gfc_default_logical_kind;
4401 tmp_sym->result = tmp_sym;
4405 /* Here, we're taking the simple approach. We're defining
4406 c_loc as an external identifier so the compiler will put
4407 what we expect on the stack for the address we want the
4409 tmp_sym->ts.type = BT_DERIVED;
4410 if (s == ISOCBINDING_LOC)
4411 tmp_sym->ts.u.derived =
4412 get_iso_c_binding_dt (ISOCBINDING_PTR);
4414 tmp_sym->ts.u.derived =
4415 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4417 if (tmp_sym->ts.u.derived == NULL)
4419 /* Create the necessary derived type so we can continue
4420 processing the file. */
4421 generate_isocbinding_symbol
4422 (mod_name, s == ISOCBINDING_FUNLOC
4423 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4424 (const char *)(s == ISOCBINDING_FUNLOC
4425 ? "_gfortran_iso_c_binding_c_funptr"
4426 : "_gfortran_iso_c_binding_c_ptr"));
4427 tmp_sym->ts.u.derived =
4428 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4429 ? ISOCBINDING_FUNPTR
4433 /* The function result is itself (no result clause). */
4434 tmp_sym->result = tmp_sym;
4435 tmp_sym->attr.external = 1;
4436 tmp_sym->attr.use_assoc = 0;
4437 tmp_sym->attr.pure = 1;
4438 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4439 tmp_sym->attr.proc = PROC_UNKNOWN;
4443 tmp_sym->attr.flavor = FL_PROCEDURE;
4444 tmp_sym->attr.contained = 0;
4446 /* Try using this builder routine, with the new and old symbols
4447 both being the generic iso_c proc sym being created. This
4448 will create the formal args (and the new namespace for them).
4449 Don't build an arg list for c_loc because we're going to treat
4450 c_loc as an external procedure. */
4451 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4452 /* The 1 says to add any optional args, if applicable. */
4453 build_formal_args (tmp_sym, tmp_sym, 1);
4455 /* Set this after setting up the symbol, to prevent error messages. */
4456 tmp_sym->attr.use_assoc = 1;
4458 /* This symbol will not be referenced directly. It will be
4459 resolved to the implementation for the given f90 kind. */
4460 tmp_sym->attr.referenced = 0;
4470 /* Creates a new symbol based off of an old iso_c symbol, with a new
4471 binding label. This function can be used to create a new,
4472 resolved, version of a procedure symbol for c_f_pointer or
4473 c_f_procpointer that is based on the generic symbols. A new
4474 parameter list is created for the new symbol using
4475 build_formal_args(). The add_optional_flag specifies whether the
4476 to add the optional SHAPE argument. The new symbol is
4480 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4481 char *new_binding_label, int add_optional_arg)
4483 gfc_symtree *new_symtree = NULL;
4485 /* See if we have a symbol by that name already available, looking
4486 through any parent namespaces. */
4487 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4488 if (new_symtree != NULL)
4489 /* Return the existing symbol. */
4490 return new_symtree->n.sym;
4492 /* Create the symtree/symbol, with attempted host association. */
4493 gfc_get_ha_sym_tree (new_name, &new_symtree);
4494 if (new_symtree == NULL)
4495 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4496 "symtree for '%s'", new_name);
4498 /* Now fill in the fields of the resolved symbol with the old sym. */
4499 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4500 new_symtree->n.sym->attr = old_sym->attr;
4501 new_symtree->n.sym->ts = old_sym->ts;
4502 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4503 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4504 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4505 /* Build the formal arg list. */
4506 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4508 gfc_commit_symbol (new_symtree->n.sym);
4510 return new_symtree->n.sym;
4514 /* Check that a symbol is already typed. If strict is not set, an untyped
4515 symbol is acceptable for non-standard-conforming mode. */
4518 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4519 bool strict, locus where)
4523 if (gfc_matching_prefix)
4526 /* Check for the type and try to give it an implicit one. */
4527 if (sym->ts.type == BT_UNKNOWN
4528 && gfc_set_default_type (sym, 0, ns) == FAILURE)
4532 gfc_error ("Symbol '%s' is used before it is typed at %L",
4537 if (gfc_notify_std (GFC_STD_GNU,
4538 "Extension: Symbol '%s' is used before"
4539 " it is typed at %L", sym->name, &where) == FAILURE)
4543 /* Everything is ok. */
4548 /* Construct a typebound-procedure structure. Those are stored in a tentative
4549 list and marked `error' until symbols are committed. */
4552 gfc_get_typebound_proc (void)
4554 gfc_typebound_proc *result;
4555 tentative_tbp *list_node;
4557 result = XCNEW (gfc_typebound_proc);
4560 list_node = XCNEW (tentative_tbp);
4561 list_node->next = tentative_tbp_list;
4562 list_node->proc = result;
4563 tentative_tbp_list = list_node;
4569 /* Get the super-type of a given derived type. */
4572 gfc_get_derived_super_type (gfc_symbol* derived)
4574 if (!derived->attr.extension)
4577 gcc_assert (derived->components);
4578 gcc_assert (derived->components->ts.type == BT_DERIVED);
4579 gcc_assert (derived->components->ts.u.derived);
4581 return derived->components->ts.u.derived;
4585 /* Get the ultimate super-type of a given derived type. */
4588 gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
4590 if (!derived->attr.extension)
4593 derived = gfc_get_derived_super_type (derived);
4595 if (derived->attr.extension)
4596 return gfc_get_ultimate_derived_super_type (derived);
4602 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4605 gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
4607 while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
4608 t2 = gfc_get_derived_super_type (t2);
4609 return gfc_compare_derived_types (t1, t2);
4613 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4614 If ts1 is nonpolymorphic, ts2 must be the same type.
4615 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4618 gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
4620 gfc_component *cmp1, *cmp2;
4622 bool is_class1 = (ts1->type == BT_CLASS);
4623 bool is_class2 = (ts2->type == BT_CLASS);
4624 bool is_derived1 = (ts1->type == BT_DERIVED);
4625 bool is_derived2 = (ts2->type == BT_DERIVED);
4627 if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
4628 return (ts1->type == ts2->type);
4630 if (is_derived1 && is_derived2)
4631 return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
4637 cmp1 = gfc_find_component (ts1->u.derived, "$data", true, false);
4644 cmp2 = gfc_find_component (ts2->u.derived, "$data", true, false);
4649 if (is_class1 && is_derived2)
4650 return gfc_type_is_extension_of (cmp1->ts.u.derived, ts2->u.derived);
4652 else if (is_class1 && is_class2)
4653 return gfc_type_is_extension_of (cmp1->ts.u.derived, cmp2->ts.u.derived);
4660 /* Build a polymorphic CLASS entity, using the symbol that comes from
4661 build_sym. A CLASS entity is represented by an encapsulating type,
4662 which contains the declared type as '$data' component, plus a pointer
4663 component '$vptr' which determines the dynamic type. */
4666 gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
4667 gfc_array_spec **as)
4669 char name[GFC_MAX_SYMBOL_LEN + 5];
4674 /* Determine the name of the encapsulating type. */
4675 if ((*as) && (*as)->rank && attr->allocatable)
4676 sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
4677 else if ((*as) && (*as)->rank)
4678 sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
4679 else if (attr->allocatable)
4680 sprintf (name, ".class.%s.a", ts->u.derived->name);
4682 sprintf (name, ".class.%s", ts->u.derived->name);
4684 gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
4688 /* If not there, create a new symbol. */
4689 fclass = gfc_new_symbol (name, ts->u.derived->ns);
4690 st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
4692 gfc_set_sym_referenced (fclass);
4694 fclass->ts.type = BT_UNKNOWN;
4695 fclass->attr.abstract = ts->u.derived->attr.abstract;
4696 if (ts->u.derived->f2k_derived)
4697 fclass->f2k_derived = gfc_get_namespace (NULL, 0);
4698 if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
4699 NULL, &gfc_current_locus) == FAILURE)
4702 /* Add component '$data'. */
4703 if (gfc_add_component (fclass, "$data", &c) == FAILURE)
4706 c->ts.type = BT_DERIVED;
4707 c->attr.access = ACCESS_PRIVATE;
4708 c->ts.u.derived = ts->u.derived;
4709 c->attr.class_pointer = attr->pointer;
4710 c->attr.pointer = attr->pointer || attr->dummy;
4711 c->attr.allocatable = attr->allocatable;
4712 c->attr.dimension = attr->dimension;
4713 c->attr.abstract = ts->u.derived->attr.abstract;
4715 c->initializer = gfc_get_expr ();
4716 c->initializer->expr_type = EXPR_NULL;
4718 /* Add component '$vptr'. */
4719 if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
4721 c->ts.type = BT_DERIVED;
4722 vtab = gfc_find_derived_vtab (ts->u.derived);
4724 c->ts.u.derived = vtab->ts.u.derived;
4725 c->attr.pointer = 1;
4726 c->initializer = gfc_get_expr ();
4727 c->initializer->expr_type = EXPR_NULL;
4730 /* Since the extension field is 8 bit wide, we can only have
4731 up to 255 extension levels. */
4732 if (ts->u.derived->attr.extension == 255)
4734 gfc_error ("Maximum extension level reached with type '%s' at %L",
4735 ts->u.derived->name, &ts->u.derived->declared_at);
4739 fclass->attr.extension = ts->u.derived->attr.extension + 1;
4740 fclass->attr.is_class = 1;
4741 ts->u.derived = fclass;
4742 attr->allocatable = attr->pointer = attr->dimension = 0;
4743 (*as) = NULL; /* XXX */
4748 /* Find the symbol for a derived type's vtab. */
4751 gfc_find_derived_vtab (gfc_symbol *derived)
4754 gfc_symbol *vtab = NULL, *vtype = NULL;
4755 char name[2 * GFC_MAX_SYMBOL_LEN + 8];
4757 ns = gfc_current_ns;
4759 for (; ns; ns = ns->parent)
4765 sprintf (name, "vtab$%s", derived->name);
4766 gfc_find_symbol (name, ns, 0, &vtab);
4770 gfc_get_symbol (name, ns, &vtab);
4771 vtab->ts.type = BT_DERIVED;
4772 vtab->attr.flavor = FL_VARIABLE;
4773 vtab->attr.target = 1;
4774 vtab->attr.save = SAVE_EXPLICIT;
4775 vtab->attr.vtab = 1;
4776 vtab->attr.access = ACCESS_PRIVATE;
4778 gfc_set_sym_referenced (vtab);
4779 sprintf (name, "vtype$%s", derived->name);
4781 gfc_find_symbol (name, ns, 0, &vtype);
4785 gfc_symbol *parent = NULL, *parent_vtab = NULL;
4787 gfc_get_symbol (name, ns, &vtype);
4788 if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
4789 NULL, &gfc_current_locus) == FAILURE)
4792 gfc_set_sym_referenced (vtype);
4793 vtype->attr.access = ACCESS_PRIVATE;
4795 /* Add component '$hash'. */
4796 if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
4798 c->ts.type = BT_INTEGER;
4800 c->attr.access = ACCESS_PRIVATE;
4801 c->initializer = gfc_int_expr (derived->hash_value);
4803 /* Add component '$size'. */
4804 if (gfc_add_component (vtype, "$size", &c) == FAILURE)
4806 c->ts.type = BT_INTEGER;
4808 c->attr.access = ACCESS_PRIVATE;
4809 /* Remember the derived type in ts.u.derived,
4810 so that the correct initializer can be set later on
4811 (in gfc_conv_structure). */
4812 c->ts.u.derived = derived;
4813 c->initializer = gfc_int_expr (0);
4815 /* Add component $extends. */
4816 if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
4818 c->attr.pointer = 1;
4819 c->attr.access = ACCESS_PRIVATE;
4820 c->initializer = gfc_get_expr ();
4821 parent = gfc_get_derived_super_type (derived);
4824 parent_vtab = gfc_find_derived_vtab (parent);
4825 c->ts.type = BT_DERIVED;
4826 c->ts.u.derived = parent_vtab->ts.u.derived;
4827 c->initializer->expr_type = EXPR_VARIABLE;
4828 gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
4829 &c->initializer->symtree);
4833 c->ts.type = BT_DERIVED;
4834 c->ts.u.derived = vtype;
4835 c->initializer->expr_type = EXPR_NULL;
4838 vtab->ts.u.derived = vtype;
4840 vtab->value = gfc_default_initializer (&vtab->ts);
4848 /* General worker function to find either a type-bound procedure or a
4849 type-bound user operator. */
4852 find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
4853 const char* name, bool noaccess, bool uop,
4859 /* Set correct symbol-root. */
4860 gcc_assert (derived->f2k_derived);
4861 root = (uop ? derived->f2k_derived->tb_uop_root
4862 : derived->f2k_derived->tb_sym_root);
4864 /* Set default to failure. */
4868 /* Try to find it in the current type's namespace. */
4869 res = gfc_find_symtree (root, name);
4870 if (res && res->n.tb && !res->n.tb->error)
4876 if (!noaccess && derived->attr.use_assoc
4877 && res->n.tb->access == ACCESS_PRIVATE)
4880 gfc_error ("'%s' of '%s' is PRIVATE at %L",
4881 name, derived->name, where);
4889 /* Otherwise, recurse on parent type if derived is an extension. */
4890 if (derived->attr.extension)
4892 gfc_symbol* super_type;
4893 super_type = gfc_get_derived_super_type (derived);
4894 gcc_assert (super_type);
4896 return find_typebound_proc_uop (super_type, t, name,
4897 noaccess, uop, where);
4900 /* Nothing found. */
4905 /* Find a type-bound procedure or user operator by name for a derived-type
4906 (looking recursively through the super-types). */
4909 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
4910 const char* name, bool noaccess, locus* where)
4912 return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
4916 gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
4917 const char* name, bool noaccess, locus* where)
4919 return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
4923 /* Find a type-bound intrinsic operator looking recursively through the
4924 super-type hierarchy. */
4927 gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
4928 gfc_intrinsic_op op, bool noaccess,
4931 gfc_typebound_proc* res;
4933 /* Set default to failure. */
4937 /* Try to find it in the current type's namespace. */
4938 if (derived->f2k_derived)
4939 res = derived->f2k_derived->tb_op[op];
4944 if (res && !res->error)
4950 if (!noaccess && derived->attr.use_assoc
4951 && res->access == ACCESS_PRIVATE)
4954 gfc_error ("'%s' of '%s' is PRIVATE at %L",
4955 gfc_op2string (op), derived->name, where);
4963 /* Otherwise, recurse on parent type if derived is an extension. */
4964 if (derived->attr.extension)
4966 gfc_symbol* super_type;
4967 super_type = gfc_get_derived_super_type (derived);
4968 gcc_assert (super_type);
4970 return gfc_find_typebound_intrinsic_op (super_type, t, op,
4974 /* Nothing found. */
4979 /* Get a typebound-procedure symtree or create and insert it if not yet
4980 present. This is like a very simplified version of gfc_get_sym_tree for
4981 tbp-symtrees rather than regular ones. */
4984 gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
4986 gfc_symtree *result;
4988 result = gfc_find_symtree (*root, name);
4991 result = gfc_new_symtree (root, name);
4992 gcc_assert (result);
4993 result->n.tb = NULL;