1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000-2013 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 3, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING3. If not see
19 <http://www.gnu.org/licenses/>. */
24 #include "coretypes.h"
29 #include "constructor.h"
32 /* Strings for all symbol attributes. We use these for dumping the
33 parse tree, in error messages, and also when reading and writing
36 const mstring flavors[] =
38 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
39 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
40 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
41 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
42 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
46 const mstring procedures[] =
48 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
49 minit ("MODULE-PROC", PROC_MODULE),
50 minit ("INTERNAL-PROC", PROC_INTERNAL),
51 minit ("DUMMY-PROC", PROC_DUMMY),
52 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
53 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
54 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
58 const mstring intents[] =
60 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
61 minit ("IN", INTENT_IN),
62 minit ("OUT", INTENT_OUT),
63 minit ("INOUT", INTENT_INOUT),
67 const mstring access_types[] =
69 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
70 minit ("PUBLIC", ACCESS_PUBLIC),
71 minit ("PRIVATE", ACCESS_PRIVATE),
75 const mstring ifsrc_types[] =
77 minit ("UNKNOWN", IFSRC_UNKNOWN),
78 minit ("DECL", IFSRC_DECL),
79 minit ("BODY", IFSRC_IFBODY)
82 const mstring save_status[] =
84 minit ("UNKNOWN", SAVE_NONE),
85 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
86 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
89 /* This is to make sure the backend generates setup code in the correct
92 static int next_dummy_order = 1;
95 gfc_namespace *gfc_current_ns;
96 gfc_namespace *gfc_global_ns_list;
98 gfc_gsymbol *gfc_gsym_root = NULL;
100 gfc_dt_list *gfc_derived_types;
102 static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL };
103 static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
106 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
108 /* The following static variable indicates whether a particular element has
109 been explicitly set or not. */
111 static int new_flag[GFC_LETTERS];
114 /* Handle a correctly parsed IMPLICIT NONE. */
117 gfc_set_implicit_none (void)
121 if (gfc_current_ns->seen_implicit_none)
123 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
127 gfc_current_ns->seen_implicit_none = 1;
129 for (i = 0; i < GFC_LETTERS; i++)
131 gfc_clear_ts (&gfc_current_ns->default_type[i]);
132 gfc_current_ns->set_flag[i] = 1;
137 /* Reset the implicit range flags. */
140 gfc_clear_new_implicit (void)
144 for (i = 0; i < GFC_LETTERS; i++)
149 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
152 gfc_add_new_implicit_range (int c1, int c2)
159 for (i = c1; i <= c2; i++)
163 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
175 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
176 the new implicit types back into the existing types will work. */
179 gfc_merge_new_implicit (gfc_typespec *ts)
183 if (gfc_current_ns->seen_implicit_none)
185 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
189 for (i = 0; i < GFC_LETTERS; i++)
193 if (gfc_current_ns->set_flag[i])
195 gfc_error ("Letter %c already has an IMPLICIT type at %C",
200 gfc_current_ns->default_type[i] = *ts;
201 gfc_current_ns->implicit_loc[i] = gfc_current_locus;
202 gfc_current_ns->set_flag[i] = 1;
209 /* Given a symbol, return a pointer to the typespec for its default type. */
212 gfc_get_default_type (const char *name, gfc_namespace *ns)
218 if (gfc_option.flag_allow_leading_underscore && letter == '_')
219 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
220 "gfortran developers, and should not be used for "
221 "implicitly typed variables");
223 if (letter < 'a' || letter > 'z')
224 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
229 return &ns->default_type[letter - 'a'];
233 /* Given a pointer to a symbol, set its type according to the first
234 letter of its name. Fails if the letter in question has no default
238 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
242 if (sym->ts.type != BT_UNKNOWN)
243 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
245 ts = gfc_get_default_type (sym->name, ns);
247 if (ts->type == BT_UNKNOWN)
249 if (error_flag && !sym->attr.untyped)
251 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
252 sym->name, &sym->declared_at);
253 sym->attr.untyped = 1; /* Ensure we only give an error once. */
260 sym->attr.implicit_type = 1;
262 if (ts->type == BT_CHARACTER && ts->u.cl)
263 sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
265 if (sym->attr.is_bind_c == 1 && gfc_option.warn_c_binding_type)
267 /* BIND(C) variables should not be implicitly declared. */
268 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
269 "not be C interoperable", sym->name, &sym->declared_at);
270 sym->ts.f90_type = sym->ts.type;
273 if (sym->attr.dummy != 0)
275 if (sym->ns->proc_name != NULL
276 && (sym->ns->proc_name->attr.subroutine != 0
277 || sym->ns->proc_name->attr.function != 0)
278 && sym->ns->proc_name->attr.is_bind_c != 0
279 && gfc_option.warn_c_binding_type)
281 /* Dummy args to a BIND(C) routine may not be interoperable if
282 they are implicitly typed. */
283 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
284 "be C interoperable but it is a dummy argument to "
285 "the BIND(C) procedure '%s' at %L", sym->name,
286 &(sym->declared_at), sym->ns->proc_name->name,
287 &(sym->ns->proc_name->declared_at));
288 sym->ts.f90_type = sym->ts.type;
296 /* This function is called from parse.c(parse_progunit) to check the
297 type of the function is not implicitly typed in the host namespace
298 and to implicitly type the function result, if necessary. */
301 gfc_check_function_type (gfc_namespace *ns)
303 gfc_symbol *proc = ns->proc_name;
305 if (!proc->attr.contained || proc->result->attr.implicit_type)
308 if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
310 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
313 if (proc->result != proc)
315 proc->ts = proc->result->ts;
316 proc->as = gfc_copy_array_spec (proc->result->as);
317 proc->attr.dimension = proc->result->attr.dimension;
318 proc->attr.pointer = proc->result->attr.pointer;
319 proc->attr.allocatable = proc->result->attr.allocatable;
322 else if (!proc->result->attr.proc_pointer)
324 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
325 proc->result->name, &proc->result->declared_at);
326 proc->result->attr.untyped = 1;
332 /******************** Symbol attribute stuff *********************/
334 /* This is a generic conflict-checker. We do this to avoid having a
335 single conflict in two places. */
337 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
338 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
339 #define conf_std(a, b, std) if (attr->a && attr->b)\
348 check_conflict (symbol_attribute *attr, const char *name, locus *where)
350 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
351 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
352 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
353 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
354 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
355 *privat = "PRIVATE", *recursive = "RECURSIVE",
356 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
357 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
358 *function = "FUNCTION", *subroutine = "SUBROUTINE",
359 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
360 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
361 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
362 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
363 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
364 *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
365 *contiguous = "CONTIGUOUS", *generic = "GENERIC";
366 static const char *threadprivate = "THREADPRIVATE";
372 where = &gfc_current_locus;
374 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
378 standard = GFC_STD_F2003;
382 if (attr->in_namelist && (attr->allocatable || attr->pointer))
385 a2 = attr->allocatable ? allocatable : pointer;
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);
437 gfc_error ("Namelist group name at %L cannot have the "
438 "SAVE attribute", where);
442 /* Conflicts between SAVE and PROCEDURE will be checked at
443 resolution stage, see "resolve_fl_procedure". */
451 conf (dummy, intrinsic);
452 conf (dummy, threadprivate);
453 conf (pointer, target);
454 conf (pointer, intrinsic);
455 conf (pointer, elemental);
456 conf (allocatable, elemental);
458 conf (target, external);
459 conf (target, intrinsic);
461 if (!attr->if_source)
462 conf (external, dimension); /* See Fortran 95's R504. */
464 conf (external, intrinsic);
465 conf (entry, intrinsic);
467 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
468 conf (external, subroutine);
470 if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
471 "Procedure pointer at %C") == FAILURE)
474 conf (allocatable, pointer);
475 conf_std (allocatable, dummy, GFC_STD_F2003);
476 conf_std (allocatable, function, GFC_STD_F2003);
477 conf_std (allocatable, result, GFC_STD_F2003);
478 conf (elemental, recursive);
480 conf (in_common, dummy);
481 conf (in_common, allocatable);
482 conf (in_common, codimension);
483 conf (in_common, result);
485 conf (in_equivalence, use_assoc);
486 conf (in_equivalence, codimension);
487 conf (in_equivalence, dummy);
488 conf (in_equivalence, target);
489 conf (in_equivalence, pointer);
490 conf (in_equivalence, function);
491 conf (in_equivalence, result);
492 conf (in_equivalence, entry);
493 conf (in_equivalence, allocatable);
494 conf (in_equivalence, threadprivate);
496 conf (dummy, result);
497 conf (entry, result);
498 conf (generic, result);
500 conf (function, subroutine);
502 if (!function && !subroutine)
503 conf (is_bind_c, dummy);
505 conf (is_bind_c, cray_pointer);
506 conf (is_bind_c, cray_pointee);
507 conf (is_bind_c, codimension);
508 conf (is_bind_c, allocatable);
509 conf (is_bind_c, elemental);
511 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
512 Parameter conflict caught below. Also, value cannot be specified
513 for a dummy procedure. */
515 /* Cray pointer/pointee conflicts. */
516 conf (cray_pointer, cray_pointee);
517 conf (cray_pointer, dimension);
518 conf (cray_pointer, codimension);
519 conf (cray_pointer, contiguous);
520 conf (cray_pointer, pointer);
521 conf (cray_pointer, target);
522 conf (cray_pointer, allocatable);
523 conf (cray_pointer, external);
524 conf (cray_pointer, intrinsic);
525 conf (cray_pointer, in_namelist);
526 conf (cray_pointer, function);
527 conf (cray_pointer, subroutine);
528 conf (cray_pointer, entry);
530 conf (cray_pointee, allocatable);
531 conf (cray_pointer, contiguous);
532 conf (cray_pointer, codimension);
533 conf (cray_pointee, intent);
534 conf (cray_pointee, optional);
535 conf (cray_pointee, dummy);
536 conf (cray_pointee, target);
537 conf (cray_pointee, intrinsic);
538 conf (cray_pointee, pointer);
539 conf (cray_pointee, entry);
540 conf (cray_pointee, in_common);
541 conf (cray_pointee, in_equivalence);
542 conf (cray_pointee, threadprivate);
545 conf (data, function);
547 conf (data, allocatable);
549 conf (value, pointer)
550 conf (value, allocatable)
551 conf (value, subroutine)
552 conf (value, function)
553 conf (value, volatile_)
554 conf (value, dimension)
555 conf (value, codimension)
556 conf (value, external)
558 conf (codimension, result)
561 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
564 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
568 conf (is_protected, intrinsic)
569 conf (is_protected, in_common)
571 conf (asynchronous, intrinsic)
572 conf (asynchronous, external)
574 conf (volatile_, intrinsic)
575 conf (volatile_, external)
577 if (attr->volatile_ && attr->intent == INTENT_IN)
584 conf (procedure, allocatable)
585 conf (procedure, dimension)
586 conf (procedure, codimension)
587 conf (procedure, intrinsic)
588 conf (procedure, target)
589 conf (procedure, value)
590 conf (procedure, volatile_)
591 conf (procedure, asynchronous)
592 conf (procedure, entry)
594 a1 = gfc_code2string (flavors, attr->flavor);
596 if (attr->in_namelist
597 && attr->flavor != FL_VARIABLE
598 && attr->flavor != FL_PROCEDURE
599 && attr->flavor != FL_UNKNOWN)
605 switch (attr->flavor)
615 conf2 (asynchronous);
618 conf2 (is_protected);
628 conf2 (threadprivate);
630 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
632 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
633 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
640 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
654 /* Conflicts with INTENT, SAVE and RESULT will be checked
655 at resolution stage, see "resolve_fl_procedure". */
657 if (attr->subroutine)
663 conf2 (asynchronous);
668 if (!attr->proc_pointer)
669 conf2 (threadprivate);
672 if (!attr->proc_pointer)
677 case PROC_ST_FUNCTION:
688 conf2 (threadprivate);
708 conf2 (threadprivate);
711 if (attr->intent != INTENT_UNKNOWN)
728 conf2 (is_protected);
734 conf2 (asynchronous);
735 conf2 (threadprivate);
751 gfc_error ("%s attribute conflicts with %s attribute at %L",
754 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
755 a1, a2, name, where);
762 return gfc_notify_std (standard, "%s attribute "
763 "with %s attribute at %L", a1, a2,
768 return gfc_notify_std (standard, "%s attribute "
769 "with %s attribute in '%s' at %L",
770 a1, a2, name, where);
779 /* Mark a symbol as referenced. */
782 gfc_set_sym_referenced (gfc_symbol *sym)
785 if (sym->attr.referenced)
788 sym->attr.referenced = 1;
790 /* Remember which order dummy variables are accessed in. */
792 sym->dummy_order = next_dummy_order++;
796 /* Common subroutine called by attribute changing subroutines in order
797 to prevent them from changing a symbol that has been
798 use-associated. Returns zero if it is OK to change the symbol,
802 check_used (symbol_attribute *attr, const char *name, locus *where)
805 if (attr->use_assoc == 0)
809 where = &gfc_current_locus;
812 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
815 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
822 /* Generate an error because of a duplicate attribute. */
825 duplicate_attr (const char *attr, locus *where)
829 where = &gfc_current_locus;
831 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
836 gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
837 locus *where ATTRIBUTE_UNUSED)
839 attr->ext_attr |= 1 << ext_attr;
844 /* Called from decl.c (attr_decl1) to check attributes, when declared
848 gfc_add_attribute (symbol_attribute *attr, locus *where)
850 if (check_used (attr, NULL, where))
853 return check_conflict (attr, NULL, where);
858 gfc_add_allocatable (symbol_attribute *attr, locus *where)
861 if (check_used (attr, NULL, where))
864 if (attr->allocatable)
866 duplicate_attr ("ALLOCATABLE", where);
870 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
871 && gfc_find_state (COMP_INTERFACE) == FAILURE)
873 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
878 attr->allocatable = 1;
879 return check_conflict (attr, NULL, where);
884 gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
887 if (check_used (attr, name, where))
890 if (attr->codimension)
892 duplicate_attr ("CODIMENSION", where);
896 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
897 && gfc_find_state (COMP_INTERFACE) == FAILURE)
899 gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
900 "at %L", name, where);
904 attr->codimension = 1;
905 return check_conflict (attr, name, where);
910 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
913 if (check_used (attr, name, where))
918 duplicate_attr ("DIMENSION", where);
922 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
923 && gfc_find_state (COMP_INTERFACE) == FAILURE)
925 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
926 "at %L", name, where);
931 return check_conflict (attr, name, where);
936 gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
939 if (check_used (attr, name, where))
942 attr->contiguous = 1;
943 return check_conflict (attr, name, where);
948 gfc_add_external (symbol_attribute *attr, locus *where)
951 if (check_used (attr, NULL, where))
956 duplicate_attr ("EXTERNAL", where);
960 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
963 attr->proc_pointer = 1;
968 return check_conflict (attr, NULL, where);
973 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
976 if (check_used (attr, NULL, where))
981 duplicate_attr ("INTRINSIC", where);
987 return check_conflict (attr, NULL, where);
992 gfc_add_optional (symbol_attribute *attr, locus *where)
995 if (check_used (attr, NULL, where))
1000 duplicate_attr ("OPTIONAL", where);
1005 return check_conflict (attr, NULL, where);
1010 gfc_add_pointer (symbol_attribute *attr, locus *where)
1013 if (check_used (attr, NULL, where))
1016 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
1017 && gfc_find_state (COMP_INTERFACE) == FAILURE))
1019 duplicate_attr ("POINTER", where);
1023 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
1024 || (attr->if_source == IFSRC_IFBODY
1025 && gfc_find_state (COMP_INTERFACE) == FAILURE))
1026 attr->proc_pointer = 1;
1030 return check_conflict (attr, NULL, where);
1035 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
1038 if (check_used (attr, NULL, where))
1041 attr->cray_pointer = 1;
1042 return check_conflict (attr, NULL, where);
1047 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
1050 if (check_used (attr, NULL, where))
1053 if (attr->cray_pointee)
1055 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1056 " statements", where);
1060 attr->cray_pointee = 1;
1061 return check_conflict (attr, NULL, where);
1066 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1068 if (check_used (attr, name, where))
1071 if (attr->is_protected)
1073 if (gfc_notify_std (GFC_STD_LEGACY,
1074 "Duplicate PROTECTED attribute specified at %L",
1080 attr->is_protected = 1;
1081 return check_conflict (attr, name, where);
1086 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1089 if (check_used (attr, name, where))
1093 return check_conflict (attr, name, where);
1098 gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
1102 if (check_used (attr, name, where))
1105 if (s == SAVE_EXPLICIT && gfc_pure (NULL))
1108 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1113 if (s == SAVE_EXPLICIT && gfc_implicit_pure (NULL))
1114 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1116 if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
1118 if (gfc_notify_std (GFC_STD_LEGACY,
1119 "Duplicate SAVE attribute specified at %L",
1126 return check_conflict (attr, name, where);
1131 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1134 if (check_used (attr, name, where))
1139 if (gfc_notify_std (GFC_STD_LEGACY,
1140 "Duplicate VALUE attribute specified at %L",
1147 return check_conflict (attr, name, where);
1152 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1154 /* No check_used needed as 11.2.1 of the F2003 standard allows
1155 that the local identifier made accessible by a use statement can be
1156 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1158 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1159 if (gfc_notify_std (GFC_STD_LEGACY,
1160 "Duplicate VOLATILE attribute specified at %L", where)
1164 attr->volatile_ = 1;
1165 attr->volatile_ns = gfc_current_ns;
1166 return check_conflict (attr, name, where);
1171 gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1173 /* No check_used needed as 11.2.1 of the F2003 standard allows
1174 that the local identifier made accessible by a use statement can be
1175 given a ASYNCHRONOUS attribute. */
1177 if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
1178 if (gfc_notify_std (GFC_STD_LEGACY,
1179 "Duplicate ASYNCHRONOUS attribute specified at %L",
1183 attr->asynchronous = 1;
1184 attr->asynchronous_ns = gfc_current_ns;
1185 return check_conflict (attr, name, where);
1190 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1193 if (check_used (attr, name, where))
1196 if (attr->threadprivate)
1198 duplicate_attr ("THREADPRIVATE", where);
1202 attr->threadprivate = 1;
1203 return check_conflict (attr, name, where);
1208 gfc_add_target (symbol_attribute *attr, locus *where)
1211 if (check_used (attr, NULL, where))
1216 duplicate_attr ("TARGET", where);
1221 return check_conflict (attr, NULL, where);
1226 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1229 if (check_used (attr, name, where))
1232 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1234 return check_conflict (attr, name, where);
1239 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1242 if (check_used (attr, name, where))
1245 /* Duplicate attribute already checked for. */
1246 attr->in_common = 1;
1247 return check_conflict (attr, name, where);
1252 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1255 /* Duplicate attribute already checked for. */
1256 attr->in_equivalence = 1;
1257 if (check_conflict (attr, name, where) == FAILURE)
1260 if (attr->flavor == FL_VARIABLE)
1263 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1268 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1271 if (check_used (attr, name, where))
1275 return check_conflict (attr, name, where);
1280 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1283 attr->in_namelist = 1;
1284 return check_conflict (attr, name, where);
1289 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1292 if (check_used (attr, name, where))
1296 return check_conflict (attr, name, where);
1301 gfc_add_elemental (symbol_attribute *attr, locus *where)
1304 if (check_used (attr, NULL, where))
1307 if (attr->elemental)
1309 duplicate_attr ("ELEMENTAL", where);
1313 attr->elemental = 1;
1314 return check_conflict (attr, NULL, where);
1319 gfc_add_pure (symbol_attribute *attr, locus *where)
1322 if (check_used (attr, NULL, where))
1327 duplicate_attr ("PURE", where);
1332 return check_conflict (attr, NULL, where);
1337 gfc_add_recursive (symbol_attribute *attr, locus *where)
1340 if (check_used (attr, NULL, where))
1343 if (attr->recursive)
1345 duplicate_attr ("RECURSIVE", where);
1349 attr->recursive = 1;
1350 return check_conflict (attr, NULL, where);
1355 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1358 if (check_used (attr, name, where))
1363 duplicate_attr ("ENTRY", where);
1368 return check_conflict (attr, name, where);
1373 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1376 if (attr->flavor != FL_PROCEDURE
1377 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1381 return check_conflict (attr, name, where);
1386 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1389 if (attr->flavor != FL_PROCEDURE
1390 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1393 attr->subroutine = 1;
1394 return check_conflict (attr, name, where);
1399 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1402 if (attr->flavor != FL_PROCEDURE
1403 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1407 return check_conflict (attr, name, where);
1412 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1415 if (check_used (attr, NULL, where))
1418 if (attr->flavor != FL_PROCEDURE
1419 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1422 if (attr->procedure)
1424 duplicate_attr ("PROCEDURE", where);
1428 attr->procedure = 1;
1430 return check_conflict (attr, NULL, where);
1435 gfc_add_abstract (symbol_attribute* attr, locus* where)
1439 duplicate_attr ("ABSTRACT", where);
1448 /* Flavors are special because some flavors are not what Fortran
1449 considers attributes and can be reaffirmed multiple times. */
1452 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1456 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1457 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1458 || f == FL_NAMELIST) && check_used (attr, name, where))
1461 if (attr->flavor == f && f == FL_VARIABLE)
1464 if (attr->flavor != FL_UNKNOWN)
1467 where = &gfc_current_locus;
1470 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1471 gfc_code2string (flavors, attr->flavor), name,
1472 gfc_code2string (flavors, f), where);
1474 gfc_error ("%s attribute conflicts with %s attribute at %L",
1475 gfc_code2string (flavors, attr->flavor),
1476 gfc_code2string (flavors, f), where);
1483 return check_conflict (attr, name, where);
1488 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1489 const char *name, locus *where)
1492 if (check_used (attr, name, where))
1495 if (attr->flavor != FL_PROCEDURE
1496 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1500 where = &gfc_current_locus;
1502 if (attr->proc != PROC_UNKNOWN)
1504 gfc_error ("%s procedure at %L is already declared as %s procedure",
1505 gfc_code2string (procedures, t), where,
1506 gfc_code2string (procedures, attr->proc));
1513 /* Statement functions are always scalar and functions. */
1514 if (t == PROC_ST_FUNCTION
1515 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1516 || attr->dimension))
1519 return check_conflict (attr, name, where);
1524 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1527 if (check_used (attr, NULL, where))
1530 if (attr->intent == INTENT_UNKNOWN)
1532 attr->intent = intent;
1533 return check_conflict (attr, NULL, where);
1537 where = &gfc_current_locus;
1539 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1540 gfc_intent_string (attr->intent),
1541 gfc_intent_string (intent), where);
1547 /* No checks for use-association in public and private statements. */
1550 gfc_add_access (symbol_attribute *attr, gfc_access access,
1551 const char *name, locus *where)
1554 if (attr->access == ACCESS_UNKNOWN
1555 || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1557 attr->access = access;
1558 return check_conflict (attr, name, where);
1562 where = &gfc_current_locus;
1563 gfc_error ("ACCESS specification at %L was already specified", where);
1569 /* Set the is_bind_c field for the given symbol_attribute. */
1572 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1573 int is_proc_lang_bind_spec)
1576 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1577 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1578 "variables or common blocks", where);
1579 else if (attr->is_bind_c)
1580 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1582 attr->is_bind_c = 1;
1585 where = &gfc_current_locus;
1587 if (gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where)
1591 return check_conflict (attr, name, where);
1595 /* Set the extension field for the given symbol_attribute. */
1598 gfc_add_extension (symbol_attribute *attr, locus *where)
1601 where = &gfc_current_locus;
1603 if (attr->extension)
1604 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1606 attr->extension = 1;
1608 if (gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where)
1617 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1618 gfc_formal_arglist * formal, locus *where)
1621 if (check_used (&sym->attr, sym->name, where))
1625 where = &gfc_current_locus;
1627 if (sym->attr.if_source != IFSRC_UNKNOWN
1628 && sym->attr.if_source != IFSRC_DECL)
1630 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1635 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1637 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1638 "body", sym->name, where);
1642 sym->formal = formal;
1643 sym->attr.if_source = source;
1649 /* Add a type to a symbol. */
1652 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1658 where = &gfc_current_locus;
1661 type = sym->result->ts.type;
1663 type = sym->ts.type;
1665 if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
1666 type = sym->ns->proc_name->ts.type;
1668 if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
1670 if (sym->attr.use_assoc)
1671 gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
1672 "use-associated at %L", sym->name, where, sym->module,
1675 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1676 where, gfc_basic_typename (type));
1680 if (sym->attr.procedure && sym->ts.interface)
1682 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1683 sym->name, where, gfc_basic_typename (ts->type));
1687 flavor = sym->attr.flavor;
1689 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1690 || flavor == FL_LABEL
1691 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1692 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1694 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1703 /* Clears all attributes. */
1706 gfc_clear_attr (symbol_attribute *attr)
1708 memset (attr, 0, sizeof (symbol_attribute));
1712 /* Check for missing attributes in the new symbol. Currently does
1713 nothing, but it's not clear that it is unnecessary yet. */
1716 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1717 locus *where ATTRIBUTE_UNUSED)
1724 /* Copy an attribute to a symbol attribute, bit by bit. Some
1725 attributes have a lot of side-effects but cannot be present given
1726 where we are called from, so we ignore some bits. */
1729 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1731 int is_proc_lang_bind_spec;
1733 /* In line with the other attributes, we only add bits but do not remove
1734 them; cf. also PR 41034. */
1735 dest->ext_attr |= src->ext_attr;
1737 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1740 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1742 if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE)
1744 if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE)
1746 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1748 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1750 if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1752 if (src->save && gfc_add_save (dest, src->save, NULL, where) == FAILURE)
1754 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1756 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1758 if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
1760 if (src->threadprivate
1761 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1763 if (src->target && gfc_add_target (dest, where) == FAILURE)
1765 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1767 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1772 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1775 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1778 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1780 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1782 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1785 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1787 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1789 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1791 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1794 if (src->flavor != FL_UNKNOWN
1795 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1798 if (src->intent != INTENT_UNKNOWN
1799 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1802 if (src->access != ACCESS_UNKNOWN
1803 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1806 if (gfc_missing_attr (dest, where) == FAILURE)
1809 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1811 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1814 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1816 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1820 if (src->is_c_interop)
1821 dest->is_c_interop = 1;
1825 if (src->external && gfc_add_external (dest, where) == FAILURE)
1827 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1829 if (src->proc_pointer)
1830 dest->proc_pointer = 1;
1839 /************** Component name management ************/
1841 /* Component names of a derived type form their own little namespaces
1842 that are separate from all other spaces. The space is composed of
1843 a singly linked list of gfc_component structures whose head is
1844 located in the parent symbol. */
1847 /* Add a component name to a symbol. The call fails if the name is
1848 already present. On success, the component pointer is modified to
1849 point to the additional component structure. */
1852 gfc_add_component (gfc_symbol *sym, const char *name,
1853 gfc_component **component)
1855 gfc_component *p, *tail;
1859 for (p = sym->components; p; p = p->next)
1861 if (strcmp (p->name, name) == 0)
1863 gfc_error ("Component '%s' at %C already declared at %L",
1871 if (sym->attr.extension
1872 && gfc_find_component (sym->components->ts.u.derived, name, true, true))
1874 gfc_error ("Component '%s' at %C already in the parent type "
1875 "at %L", name, &sym->components->ts.u.derived->declared_at);
1879 /* Allocate a new component. */
1880 p = gfc_get_component ();
1883 sym->components = p;
1887 p->name = gfc_get_string (name);
1888 p->loc = gfc_current_locus;
1889 p->ts.type = BT_UNKNOWN;
1896 /* Recursive function to switch derived types of all symbol in a
1900 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1908 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
1909 sym->ts.u.derived = to;
1911 switch_types (st->left, from, to);
1912 switch_types (st->right, from, to);
1916 /* This subroutine is called when a derived type is used in order to
1917 make the final determination about which version to use. The
1918 standard requires that a type be defined before it is 'used', but
1919 such types can appear in IMPLICIT statements before the actual
1920 definition. 'Using' in this context means declaring a variable to
1921 be that type or using the type constructor.
1923 If a type is used and the components haven't been defined, then we
1924 have to have a derived type in a parent unit. We find the node in
1925 the other namespace and point the symtree node in this namespace to
1926 that node. Further reference to this name point to the correct
1927 node. If we can't find the node in a parent namespace, then we have
1930 This subroutine takes a pointer to a symbol node and returns a
1931 pointer to the translated node or NULL for an error. Usually there
1932 is no translation and we return the node we were passed. */
1935 gfc_use_derived (gfc_symbol *sym)
1945 if (sym->attr.unlimited_polymorphic)
1948 if (sym->attr.generic)
1949 sym = gfc_find_dt_in_generic (sym);
1951 if (sym->components != NULL || sym->attr.zero_comp)
1952 return sym; /* Already defined. */
1954 if (sym->ns->parent == NULL)
1957 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1959 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1963 if (s == NULL || s->attr.flavor != FL_DERIVED)
1966 /* Get rid of symbol sym, translating all references to s. */
1967 for (i = 0; i < GFC_LETTERS; i++)
1969 t = &sym->ns->default_type[i];
1970 if (t->u.derived == sym)
1974 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1979 /* Unlink from list of modified symbols. */
1980 gfc_commit_symbol (sym);
1982 switch_types (sym->ns->sym_root, sym, s);
1984 /* TODO: Also have to replace sym -> s in other lists like
1985 namelists, common lists and interface lists. */
1986 gfc_free_symbol (sym);
1991 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1997 /* Given a derived type node and a component name, try to locate the
1998 component structure. Returns the NULL pointer if the component is
1999 not found or the components are private. If noaccess is set, no access
2003 gfc_find_component (gfc_symbol *sym, const char *name,
2004 bool noaccess, bool silent)
2008 if (name == NULL || sym == NULL)
2011 sym = gfc_use_derived (sym);
2016 for (p = sym->components; p; p = p->next)
2017 if (strcmp (p->name, name) == 0)
2020 if (p && sym->attr.use_assoc && !noaccess)
2022 bool is_parent_comp = sym->attr.extension && (p == sym->components);
2023 if (p->attr.access == ACCESS_PRIVATE ||
2024 (p->attr.access != ACCESS_PUBLIC
2025 && sym->component_access == ACCESS_PRIVATE
2026 && !is_parent_comp))
2029 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2036 && sym->attr.extension
2037 && sym->components->ts.type == BT_DERIVED)
2039 p = gfc_find_component (sym->components->ts.u.derived, name,
2041 /* Do not overwrite the error. */
2046 if (p == NULL && !silent)
2047 gfc_error ("'%s' at %C is not a member of the '%s' structure",
2054 /* Given a symbol, free all of the component structures and everything
2058 free_components (gfc_component *p)
2066 gfc_free_array_spec (p->as);
2067 gfc_free_expr (p->initializer);
2075 /******************** Statement label management ********************/
2077 /* Comparison function for statement labels, used for managing the
2081 compare_st_labels (void *a1, void *b1)
2083 int a = ((gfc_st_label *) a1)->value;
2084 int b = ((gfc_st_label *) b1)->value;
2090 /* Free a single gfc_st_label structure, making sure the tree is not
2091 messed up. This function is called only when some parse error
2095 gfc_free_st_label (gfc_st_label *label)
2101 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
2103 if (label->format != NULL)
2104 gfc_free_expr (label->format);
2110 /* Free a whole tree of gfc_st_label structures. */
2113 free_st_labels (gfc_st_label *label)
2119 free_st_labels (label->left);
2120 free_st_labels (label->right);
2122 if (label->format != NULL)
2123 gfc_free_expr (label->format);
2128 /* Given a label number, search for and return a pointer to the label
2129 structure, creating it if it does not exist. */
2132 gfc_get_st_label (int labelno)
2137 if (gfc_current_state () == COMP_DERIVED)
2138 ns = gfc_current_block ()->f2k_derived;
2141 /* Find the namespace of the scoping unit:
2142 If we're in a BLOCK construct, jump to the parent namespace. */
2143 ns = gfc_current_ns;
2144 while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2148 /* First see if the label is already in this namespace. */
2152 if (lp->value == labelno)
2155 if (lp->value < labelno)
2161 lp = XCNEW (gfc_st_label);
2163 lp->value = labelno;
2164 lp->defined = ST_LABEL_UNKNOWN;
2165 lp->referenced = ST_LABEL_UNKNOWN;
2167 gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2173 /* Called when a statement with a statement label is about to be
2174 accepted. We add the label to the list of the current namespace,
2175 making sure it hasn't been defined previously and referenced
2179 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2183 labelno = lp->value;
2185 if (lp->defined != ST_LABEL_UNKNOWN)
2186 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2187 &lp->where, label_locus);
2190 lp->where = *label_locus;
2194 case ST_LABEL_FORMAT:
2195 if (lp->referenced == ST_LABEL_TARGET
2196 || lp->referenced == ST_LABEL_DO_TARGET)
2197 gfc_error ("Label %d at %C already referenced as branch target",
2200 lp->defined = ST_LABEL_FORMAT;
2204 case ST_LABEL_TARGET:
2205 case ST_LABEL_DO_TARGET:
2206 if (lp->referenced == ST_LABEL_FORMAT)
2207 gfc_error ("Label %d at %C already referenced as a format label",
2212 if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
2213 && gfc_notify_std (GFC_STD_F95_OBS, "DO termination statement "
2214 "which is not END DO or CONTINUE with label "
2215 "%d at %C", labelno) == FAILURE)
2220 lp->defined = ST_LABEL_BAD_TARGET;
2221 lp->referenced = ST_LABEL_BAD_TARGET;
2227 /* Reference a label. Given a label and its type, see if that
2228 reference is consistent with what is known about that label,
2229 updating the unknown state. Returns FAILURE if something goes
2233 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2235 gfc_sl_type label_type;
2242 labelno = lp->value;
2244 if (lp->defined != ST_LABEL_UNKNOWN)
2245 label_type = lp->defined;
2248 label_type = lp->referenced;
2249 lp->where = gfc_current_locus;
2252 if (label_type == ST_LABEL_FORMAT
2253 && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
2255 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2260 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
2261 || label_type == ST_LABEL_BAD_TARGET)
2262 && type == ST_LABEL_FORMAT)
2264 gfc_error ("Label %d at %C previously used as branch target", labelno);
2269 if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
2270 && gfc_notify_std (GFC_STD_F95_OBS, "Shared DO termination label %d "
2271 "at %C", labelno) == FAILURE)
2274 if (lp->referenced != ST_LABEL_DO_TARGET)
2275 lp->referenced = type;
2283 /************** Symbol table management subroutines ****************/
2285 /* Basic details: Fortran 95 requires a potentially unlimited number
2286 of distinct namespaces when compiling a program unit. This case
2287 occurs during a compilation of internal subprograms because all of
2288 the internal subprograms must be read before we can start
2289 generating code for the host.
2291 Given the tricky nature of the Fortran grammar, we must be able to
2292 undo changes made to a symbol table if the current interpretation
2293 of a statement is found to be incorrect. Whenever a symbol is
2294 looked up, we make a copy of it and link to it. All of these
2295 symbols are kept in a vector so that we can commit or
2296 undo the changes at a later time.
2298 A symtree may point to a symbol node outside of its namespace. In
2299 this case, that symbol has been used as a host associated variable
2300 at some previous time. */
2302 /* Allocate a new namespace structure. Copies the implicit types from
2303 PARENT if PARENT_TYPES is set. */
2306 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2313 ns = XCNEW (gfc_namespace);
2314 ns->sym_root = NULL;
2315 ns->uop_root = NULL;
2316 ns->tb_sym_root = NULL;
2317 ns->finalizers = NULL;
2318 ns->default_access = ACCESS_UNKNOWN;
2319 ns->parent = parent;
2321 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2323 ns->operator_access[in] = ACCESS_UNKNOWN;
2324 ns->tb_op[in] = NULL;
2327 /* Initialize default implicit types. */
2328 for (i = 'a'; i <= 'z'; i++)
2330 ns->set_flag[i - 'a'] = 0;
2331 ts = &ns->default_type[i - 'a'];
2333 if (parent_types && ns->parent != NULL)
2335 /* Copy parent settings. */
2336 *ts = ns->parent->default_type[i - 'a'];
2340 if (gfc_option.flag_implicit_none != 0)
2346 if ('i' <= i && i <= 'n')
2348 ts->type = BT_INTEGER;
2349 ts->kind = gfc_default_integer_kind;
2354 ts->kind = gfc_default_real_kind;
2364 /* Comparison function for symtree nodes. */
2367 compare_symtree (void *_st1, void *_st2)
2369 gfc_symtree *st1, *st2;
2371 st1 = (gfc_symtree *) _st1;
2372 st2 = (gfc_symtree *) _st2;
2374 return strcmp (st1->name, st2->name);
2378 /* Allocate a new symtree node and associate it with the new symbol. */
2381 gfc_new_symtree (gfc_symtree **root, const char *name)
2385 st = XCNEW (gfc_symtree);
2386 st->name = gfc_get_string (name);
2388 gfc_insert_bbt (root, st, compare_symtree);
2393 /* Delete a symbol from the tree. Does not free the symbol itself! */
2396 gfc_delete_symtree (gfc_symtree **root, const char *name)
2398 gfc_symtree st, *st0;
2400 st0 = gfc_find_symtree (*root, name);
2402 st.name = gfc_get_string (name);
2403 gfc_delete_bbt (root, &st, compare_symtree);
2409 /* Given a root symtree node and a name, try to find the symbol within
2410 the namespace. Returns NULL if the symbol is not found. */
2413 gfc_find_symtree (gfc_symtree *st, const char *name)
2419 c = strcmp (name, st->name);
2423 st = (c < 0) ? st->left : st->right;
2430 /* Return a symtree node with a name that is guaranteed to be unique
2431 within the namespace and corresponds to an illegal fortran name. */
2434 gfc_get_unique_symtree (gfc_namespace *ns)
2436 char name[GFC_MAX_SYMBOL_LEN + 1];
2437 static int serial = 0;
2439 sprintf (name, "@%d", serial++);
2440 return gfc_new_symtree (&ns->sym_root, name);
2444 /* Given a name find a user operator node, creating it if it doesn't
2445 exist. These are much simpler than symbols because they can't be
2446 ambiguous with one another. */
2449 gfc_get_uop (const char *name)
2454 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2458 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2460 uop = st->n.uop = XCNEW (gfc_user_op);
2461 uop->name = gfc_get_string (name);
2462 uop->access = ACCESS_UNKNOWN;
2463 uop->ns = gfc_current_ns;
2469 /* Given a name find the user operator node. Returns NULL if it does
2473 gfc_find_uop (const char *name, gfc_namespace *ns)
2478 ns = gfc_current_ns;
2480 st = gfc_find_symtree (ns->uop_root, name);
2481 return (st == NULL) ? NULL : st->n.uop;
2485 /* Remove a gfc_symbol structure and everything it points to. */
2488 gfc_free_symbol (gfc_symbol *sym)
2494 gfc_free_array_spec (sym->as);
2496 free_components (sym->components);
2498 gfc_free_expr (sym->value);
2500 gfc_free_namelist (sym->namelist);
2502 if (sym->ns != sym->formal_ns)
2503 gfc_free_namespace (sym->formal_ns);
2505 if (!sym->attr.generic_copy)
2506 gfc_free_interface (sym->generic);
2508 gfc_free_formal_arglist (sym->formal);
2510 gfc_free_namespace (sym->f2k_derived);
2512 if (sym->common_block && sym->common_block->name[0] != '\0')
2514 sym->common_block->refs--;
2515 if (sym->common_block->refs == 0)
2516 free (sym->common_block);
2523 /* Decrease the reference counter and free memory when we reach zero. */
2526 gfc_release_symbol (gfc_symbol *sym)
2531 if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns
2532 && (!sym->attr.entry || !sym->module))
2534 /* As formal_ns contains a reference to sym, delete formal_ns just
2535 before the deletion of sym. */
2536 gfc_namespace *ns = sym->formal_ns;
2537 sym->formal_ns = NULL;
2538 gfc_free_namespace (ns);
2545 gcc_assert (sym->refs == 0);
2546 gfc_free_symbol (sym);
2550 /* Allocate and initialize a new symbol node. */
2553 gfc_new_symbol (const char *name, gfc_namespace *ns)
2557 p = XCNEW (gfc_symbol);
2559 gfc_clear_ts (&p->ts);
2560 gfc_clear_attr (&p->attr);
2563 p->declared_at = gfc_current_locus;
2565 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2566 gfc_internal_error ("new_symbol(): Symbol name too long");
2568 p->name = gfc_get_string (name);
2570 /* Make sure flags for symbol being C bound are clear initially. */
2571 p->attr.is_bind_c = 0;
2572 p->attr.is_iso_c = 0;
2574 /* Clear the ptrs we may need. */
2575 p->common_block = NULL;
2576 p->f2k_derived = NULL;
2583 /* Generate an error if a symbol is ambiguous. */
2586 ambiguous_symbol (const char *name, gfc_symtree *st)
2589 if (st->n.sym->module)
2590 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2591 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2593 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2594 "from current program unit", name, st->n.sym->name);
2598 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2599 selector on the stack. If yes, replace it by the corresponding temporary. */
2602 select_type_insert_tmp (gfc_symtree **st)
2604 gfc_select_type_stack *stack = select_type_stack;
2605 for (; stack; stack = stack->prev)
2606 if ((*st)->n.sym == stack->selector && stack->tmp)
2611 /* Look for a symtree in the current procedure -- that is, go up to
2612 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
2615 gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
2619 gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
2623 if (!ns->construct_entities)
2632 /* Search for a symtree starting in the current namespace, resorting to
2633 any parent namespaces if requested by a nonzero parent_flag.
2634 Returns nonzero if the name is ambiguous. */
2637 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2638 gfc_symtree **result)
2643 ns = gfc_current_ns;
2647 st = gfc_find_symtree (ns->sym_root, name);
2650 select_type_insert_tmp (&st);
2653 /* Ambiguous generic interfaces are permitted, as long
2654 as the specific interfaces are different. */
2655 if (st->ambiguous && !st->n.sym->attr.generic)
2657 ambiguous_symbol (name, st);
2667 /* Don't escape an interface block. */
2668 if (ns && !ns->has_import_set
2669 && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
2681 /* Same, but returns the symbol instead. */
2684 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2685 gfc_symbol **result)
2690 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2695 *result = st->n.sym;
2701 /* Tells whether there is only one set of changes in the stack. */
2704 single_undo_checkpoint_p (void)
2706 if (latest_undo_chgset == &default_undo_chgset_var)
2708 gcc_assert (latest_undo_chgset->previous == NULL);
2713 gcc_assert (latest_undo_chgset->previous != NULL);
2718 /* Save symbol with the information necessary to back it out. */
2721 save_symbol_data (gfc_symbol *sym)
2726 if (!single_undo_checkpoint_p ())
2728 /* If there is more than one change set, look for the symbol in the
2729 current one. If it is found there, we can reuse it. */
2730 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
2733 gcc_assert (sym->gfc_new || sym->old_symbol != NULL);
2737 else if (sym->gfc_new || sym->old_symbol != NULL)
2740 s = XCNEW (gfc_symbol);
2742 sym->old_symbol = s;
2745 latest_undo_chgset->syms.safe_push (sym);
2749 /* Given a name, find a symbol, or create it if it does not exist yet
2750 in the current namespace. If the symbol is found we make sure that
2753 The integer return code indicates
2755 1 The symbol name was ambiguous
2756 2 The name meant to be established was already host associated.
2758 So if the return value is nonzero, then an error was issued. */
2761 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2762 bool allow_subroutine)
2767 /* This doesn't usually happen during resolution. */
2769 ns = gfc_current_ns;
2771 /* Try to find the symbol in ns. */
2772 st = gfc_find_symtree (ns->sym_root, name);
2776 /* If not there, create a new symbol. */
2777 p = gfc_new_symbol (name, ns);
2779 /* Add to the list of tentative symbols. */
2780 p->old_symbol = NULL;
2783 latest_undo_chgset->syms.safe_push (p);
2785 st = gfc_new_symtree (&ns->sym_root, name);
2792 /* Make sure the existing symbol is OK. Ambiguous
2793 generic interfaces are permitted, as long as the
2794 specific interfaces are different. */
2795 if (st->ambiguous && !st->n.sym->attr.generic)
2797 ambiguous_symbol (name, st);
2802 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2803 && !(allow_subroutine && p->attr.subroutine)
2804 && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2805 && (ns->has_import_set || p->attr.imported)))
2807 /* Symbol is from another namespace. */
2808 gfc_error ("Symbol '%s' at %C has already been host associated",
2815 /* Copy in case this symbol is changed. */
2816 save_symbol_data (p);
2825 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2830 i = gfc_get_sym_tree (name, ns, &st, false);
2835 *result = st->n.sym;
2842 /* Subroutine that searches for a symbol, creating it if it doesn't
2843 exist, but tries to host-associate the symbol if possible. */
2846 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2851 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2855 save_symbol_data (st->n.sym);
2860 i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st);
2870 return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2875 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2880 i = gfc_get_ha_sym_tree (name, &st);
2883 *result = st->n.sym;
2891 /* Search for the symtree belonging to a gfc_common_head; we cannot use
2892 head->name as the common_root symtree's name might be mangled. */
2894 static gfc_symtree *
2895 find_common_symtree (gfc_symtree *st, gfc_common_head *head)
2898 gfc_symtree *result;
2903 if (st->n.common == head)
2906 result = find_common_symtree (st->left, head);
2908 result = find_common_symtree (st->right, head);
2914 /* Clear the given storage, and make it the current change set for registering
2915 changed symbols. Its contents are freed after a call to
2916 gfc_restore_last_undo_checkpoint or gfc_drop_last_undo_checkpoint, but
2917 it is up to the caller to free the storage itself. It is usually a local
2918 variable, so there is nothing to do anyway. */
2921 gfc_new_undo_checkpoint (gfc_undo_change_set &chg_syms)
2923 chg_syms.syms = vNULL;
2924 chg_syms.tbps = vNULL;
2925 chg_syms.previous = latest_undo_chgset;
2926 latest_undo_chgset = &chg_syms;
2930 /* Restore previous state of symbol. Just copy simple stuff. */
2933 restore_old_symbol (gfc_symbol *p)
2938 old = p->old_symbol;
2940 p->ts.type = old->ts.type;
2941 p->ts.kind = old->ts.kind;
2943 p->attr = old->attr;
2945 if (p->value != old->value)
2947 gcc_checking_assert (old->value == NULL);
2948 gfc_free_expr (p->value);
2952 if (p->as != old->as)
2955 gfc_free_array_spec (p->as);
2959 p->generic = old->generic;
2960 p->component_access = old->component_access;
2962 if (p->namelist != NULL && old->namelist == NULL)
2964 gfc_free_namelist (p->namelist);
2969 if (p->namelist_tail != old->namelist_tail)
2971 gfc_free_namelist (old->namelist_tail->next);
2972 old->namelist_tail->next = NULL;
2976 p->namelist_tail = old->namelist_tail;
2978 if (p->formal != old->formal)
2980 gfc_free_formal_arglist (p->formal);
2981 p->formal = old->formal;
2984 p->old_symbol = old->old_symbol;
2989 /* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
2990 the structure itself. */
2993 free_undo_change_set_data (gfc_undo_change_set &cs)
3000 /* Given a change set pointer, free its target's contents and update it with
3001 the address of the previous change set. Note that only the contents are
3002 freed, not the target itself (the contents' container). It is not a problem
3003 as the latter will be a local variable usually. */
3006 pop_undo_change_set (gfc_undo_change_set *&cs)
3008 free_undo_change_set_data (*cs);
3013 static void free_old_symbol (gfc_symbol *sym);
3016 /* Merges the current change set into the previous one. The changes themselves
3017 are left untouched; only one checkpoint is forgotten. */
3020 gfc_drop_last_undo_checkpoint (void)
3025 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)
3027 /* No need to loop in this case. */
3028 if (s->old_symbol == NULL)
3031 /* Remove the duplicate symbols. */
3032 FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)
3035 latest_undo_chgset->previous->syms.unordered_remove (j);
3037 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3038 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3039 shall contain from now on the backup symbol for S as it was
3040 at the checkpoint before. */
3041 if (s->old_symbol->gfc_new)
3043 gcc_assert (s->old_symbol->old_symbol == NULL);
3044 s->gfc_new = s->old_symbol->gfc_new;
3045 free_old_symbol (s);
3048 restore_old_symbol (s->old_symbol);
3053 latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
3054 latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);
3056 pop_undo_change_set (latest_undo_chgset);
3060 /* Undoes all the changes made to symbols since the previous checkpoint.
3061 This subroutine is made simpler due to the fact that attributes are
3062 never removed once added. */
3065 gfc_restore_last_undo_checkpoint (void)
3070 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3074 /* Symbol was new. */
3075 if (p->attr.in_common && p->common_block && p->common_block->head)
3077 /* If the symbol was added to any common block, it
3078 needs to be removed to stop the resolver looking
3079 for a (possibly) dead symbol. */
3081 if (p->common_block->head == p && !p->common_next)
3083 gfc_symtree st, *st0;
3084 st0 = find_common_symtree (p->ns->common_root,
3088 st.name = st0->name;
3089 gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
3094 if (p->common_block->head == p)
3095 p->common_block->head = p->common_next;
3098 gfc_symbol *cparent, *csym;
3100 cparent = p->common_block->head;
3101 csym = cparent->common_next;
3106 csym = csym->common_next;
3109 gcc_assert(cparent->common_next == p);
3111 cparent->common_next = csym->common_next;
3115 /* The derived type is saved in the symtree with the first
3116 letter capitalized; the all lower-case version to the
3117 derived type contains its associated generic function. */
3118 if (p->attr.flavor == FL_DERIVED)
3119 gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
3120 (char) TOUPPER ((unsigned char) p->name[0]),
3123 gfc_delete_symtree (&p->ns->sym_root, p->name);
3125 gfc_release_symbol (p);
3128 restore_old_symbol (p);
3131 latest_undo_chgset->syms.truncate (0);
3132 latest_undo_chgset->tbps.truncate (0);
3134 if (!single_undo_checkpoint_p ())
3135 pop_undo_change_set (latest_undo_chgset);
3139 /* Makes sure that there is only one set of changes; in other words we haven't
3140 forgotten to pair a call to gfc_new_checkpoint with a call to either
3141 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3144 enforce_single_undo_checkpoint (void)
3146 gcc_checking_assert (single_undo_checkpoint_p ());
3150 /* Undoes all the changes made to symbols in the current statement. */
3153 gfc_undo_symbols (void)
3155 enforce_single_undo_checkpoint ();
3156 gfc_restore_last_undo_checkpoint ();
3160 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3161 components of old_symbol that might need deallocation are the "allocatables"
3162 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3163 namelist_tail. In case these differ between old_symbol and sym, it's just
3164 because sym->namelist has gotten a few more items. */
3167 free_old_symbol (gfc_symbol *sym)
3170 if (sym->old_symbol == NULL)
3173 if (sym->old_symbol->as != sym->as)
3174 gfc_free_array_spec (sym->old_symbol->as);
3176 if (sym->old_symbol->value != sym->value)
3177 gfc_free_expr (sym->old_symbol->value);
3179 if (sym->old_symbol->formal != sym->formal)
3180 gfc_free_formal_arglist (sym->old_symbol->formal);
3182 free (sym->old_symbol);
3183 sym->old_symbol = NULL;
3187 /* Makes the changes made in the current statement permanent-- gets
3188 rid of undo information. */
3191 gfc_commit_symbols (void)
3194 gfc_typebound_proc *tbp;
3197 enforce_single_undo_checkpoint ();
3199 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3203 free_old_symbol (p);
3205 latest_undo_chgset->syms.truncate (0);
3207 FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)
3209 latest_undo_chgset->tbps.truncate (0);
3213 /* Makes the changes made in one symbol permanent -- gets rid of undo
3217 gfc_commit_symbol (gfc_symbol *sym)
3222 enforce_single_undo_checkpoint ();
3224 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)
3227 latest_undo_chgset->syms.unordered_remove (i);
3234 free_old_symbol (sym);
3238 /* Recursively free trees containing type-bound procedures. */
3241 free_tb_tree (gfc_symtree *t)
3246 free_tb_tree (t->left);
3247 free_tb_tree (t->right);
3249 /* TODO: Free type-bound procedure structs themselves; probably needs some
3250 sort of ref-counting mechanism. */
3256 /* Recursive function that deletes an entire tree and all the common
3257 head structures it points to. */
3260 free_common_tree (gfc_symtree * common_tree)
3262 if (common_tree == NULL)
3265 free_common_tree (common_tree->left);
3266 free_common_tree (common_tree->right);
3272 /* Recursive function that deletes an entire tree and all the user
3273 operator nodes that it contains. */
3276 free_uop_tree (gfc_symtree *uop_tree)
3278 if (uop_tree == NULL)
3281 free_uop_tree (uop_tree->left);
3282 free_uop_tree (uop_tree->right);
3284 gfc_free_interface (uop_tree->n.uop->op);
3285 free (uop_tree->n.uop);
3290 /* Recursive function that deletes an entire tree and all the symbols
3291 that it contains. */
3294 free_sym_tree (gfc_symtree *sym_tree)
3296 if (sym_tree == NULL)
3299 free_sym_tree (sym_tree->left);
3300 free_sym_tree (sym_tree->right);
3302 gfc_release_symbol (sym_tree->n.sym);
3307 /* Free the derived type list. */
3310 gfc_free_dt_list (void)
3312 gfc_dt_list *dt, *n;
3314 for (dt = gfc_derived_types; dt; dt = n)
3320 gfc_derived_types = NULL;
3324 /* Free the gfc_equiv_info's. */
3327 gfc_free_equiv_infos (gfc_equiv_info *s)
3331 gfc_free_equiv_infos (s->next);
3336 /* Free the gfc_equiv_lists. */
3339 gfc_free_equiv_lists (gfc_equiv_list *l)
3343 gfc_free_equiv_lists (l->next);
3344 gfc_free_equiv_infos (l->equiv);
3349 /* Free a finalizer procedure list. */
3352 gfc_free_finalizer (gfc_finalizer* el)
3356 gfc_release_symbol (el->proc_sym);
3362 gfc_free_finalizer_list (gfc_finalizer* list)
3366 gfc_finalizer* current = list;
3368 gfc_free_finalizer (current);
3373 /* Create a new gfc_charlen structure and add it to a namespace.
3374 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3377 gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3380 cl = gfc_get_charlen ();
3385 /* Put into namespace, but don't allow reject_statement
3386 to free it if old_cl is given. */
3387 gfc_charlen **prev = &ns->cl_list;
3388 cl->next = ns->old_cl_list;
3389 while (*prev != ns->old_cl_list)
3390 prev = &(*prev)->next;
3392 ns->old_cl_list = cl;
3393 cl->length = gfc_copy_expr (old_cl->length);
3394 cl->length_from_typespec = old_cl->length_from_typespec;
3395 cl->backend_decl = old_cl->backend_decl;
3396 cl->passed_length = old_cl->passed_length;
3397 cl->resolved = old_cl->resolved;
3401 /* Put into namespace. */
3402 cl->next = ns->cl_list;
3410 /* Free the charlen list from cl to end (end is not freed).
3411 Free the whole list if end is NULL. */
3414 gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3418 for (; cl != end; cl = cl2)
3423 gfc_free_expr (cl->length);
3429 /* Free entry list structs. */
3432 free_entry_list (gfc_entry_list *el)
3434 gfc_entry_list *next;
3441 free_entry_list (next);
3445 /* Free a namespace structure and everything below it. Interface
3446 lists associated with intrinsic operators are not freed. These are
3447 taken care of when a specific name is freed. */
3450 gfc_free_namespace (gfc_namespace *ns)
3452 gfc_namespace *p, *q;
3461 gcc_assert (ns->refs == 0);
3463 gfc_free_statements (ns->code);
3465 free_sym_tree (ns->sym_root);
3466 free_uop_tree (ns->uop_root);
3467 free_common_tree (ns->common_root);
3468 free_tb_tree (ns->tb_sym_root);
3469 free_tb_tree (ns->tb_uop_root);
3470 gfc_free_finalizer_list (ns->finalizers);
3471 gfc_free_charlen (ns->cl_list, NULL);
3472 free_st_labels (ns->st_labels);
3474 free_entry_list (ns->entries);
3475 gfc_free_equiv (ns->equiv);
3476 gfc_free_equiv_lists (ns->equiv_lists);
3477 gfc_free_use_stmts (ns->use_stmts);
3479 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3480 gfc_free_interface (ns->op[i]);
3482 gfc_free_data (ns->data);
3486 /* Recursively free any contained namespaces. */
3491 gfc_free_namespace (q);
3497 gfc_symbol_init_2 (void)
3500 gfc_current_ns = gfc_get_namespace (NULL, 0);
3505 gfc_symbol_done_2 (void)
3507 gfc_free_namespace (gfc_current_ns);
3508 gfc_current_ns = NULL;
3509 gfc_free_dt_list ();
3511 enforce_single_undo_checkpoint ();
3512 free_undo_change_set_data (*latest_undo_chgset);
3516 /* Count how many nodes a symtree has. */
3519 count_st_nodes (const gfc_symtree *st)
3525 nodes = count_st_nodes (st->left);
3527 nodes += count_st_nodes (st->right);
3533 /* Convert symtree tree into symtree vector. */
3536 fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
3541 node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
3542 st_vec[node_cntr++] = st;
3543 node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
3549 /* Traverse namespace. As the functions might modify the symtree, we store the
3550 symtree as a vector and operate on this vector. Note: We assume that
3551 sym_func or st_func never deletes nodes from the symtree - only adding is
3552 allowed. Additionally, newly added nodes are not traversed. */
3555 do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
3556 void (*sym_func) (gfc_symbol *))
3558 gfc_symtree **st_vec;
3559 unsigned nodes, i, node_cntr;
3561 gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
3562 nodes = count_st_nodes (st);
3563 st_vec = XALLOCAVEC (gfc_symtree *, nodes);
3565 fill_st_vector (st, st_vec, node_cntr);
3570 for (i = 0; i < nodes; i++)
3571 st_vec[i]->n.sym->mark = 0;
3572 for (i = 0; i < nodes; i++)
3573 if (!st_vec[i]->n.sym->mark)
3575 (*sym_func) (st_vec[i]->n.sym);
3576 st_vec[i]->n.sym->mark = 1;
3580 for (i = 0; i < nodes; i++)
3581 (*st_func) (st_vec[i]);
3585 /* Recursively traverse the symtree nodes. */
3588 gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
3590 do_traverse_symtree (st, st_func, NULL);
3594 /* Call a given function for all symbols in the namespace. We take
3595 care that each gfc_symbol node is called exactly once. */
3598 gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
3600 do_traverse_symtree (ns->sym_root, NULL, sym_func);
3604 /* Return TRUE when name is the name of an intrinsic type. */
3607 gfc_is_intrinsic_typename (const char *name)
3609 if (strcmp (name, "integer") == 0
3610 || strcmp (name, "real") == 0
3611 || strcmp (name, "character") == 0
3612 || strcmp (name, "logical") == 0
3613 || strcmp (name, "complex") == 0
3614 || strcmp (name, "doubleprecision") == 0
3615 || strcmp (name, "doublecomplex") == 0)
3622 /* Return TRUE if the symbol is an automatic variable. */
3625 gfc_is_var_automatic (gfc_symbol *sym)
3627 /* Pointer and allocatable variables are never automatic. */
3628 if (sym->attr.pointer || sym->attr.allocatable)
3630 /* Check for arrays with non-constant size. */
3631 if (sym->attr.dimension && sym->as
3632 && !gfc_is_compile_time_shape (sym->as))
3634 /* Check for non-constant length character variables. */
3635 if (sym->ts.type == BT_CHARACTER
3637 && !gfc_is_constant_expr (sym->ts.u.cl->length))
3642 /* Given a symbol, mark it as SAVEd if it is allowed. */
3645 save_symbol (gfc_symbol *sym)
3648 if (sym->attr.use_assoc)
3651 if (sym->attr.in_common
3654 || sym->attr.flavor != FL_VARIABLE)
3656 /* Automatic objects are not saved. */
3657 if (gfc_is_var_automatic (sym))
3659 gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
3663 /* Mark those symbols which can be SAVEd as such. */
3666 gfc_save_all (gfc_namespace *ns)
3668 gfc_traverse_ns (ns, save_symbol);
3672 /* Make sure that no changes to symbols are pending. */
3675 gfc_enforce_clean_symbol_state(void)
3677 enforce_single_undo_checkpoint ();
3678 gcc_assert (latest_undo_chgset->syms.is_empty ());
3682 /************** Global symbol handling ************/
3685 /* Search a tree for the global symbol. */
3688 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3697 c = strcmp (name, symbol->name);
3701 symbol = (c < 0) ? symbol->left : symbol->right;
3708 /* Compare two global symbols. Used for managing the BB tree. */
3711 gsym_compare (void *_s1, void *_s2)
3713 gfc_gsymbol *s1, *s2;
3715 s1 = (gfc_gsymbol *) _s1;
3716 s2 = (gfc_gsymbol *) _s2;
3717 return strcmp (s1->name, s2->name);
3721 /* Get a global symbol, creating it if it doesn't exist. */
3724 gfc_get_gsymbol (const char *name)
3728 s = gfc_find_gsymbol (gfc_gsym_root, name);
3732 s = XCNEW (gfc_gsymbol);
3733 s->type = GSYM_UNKNOWN;
3734 s->name = gfc_get_string (name);
3736 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3743 get_iso_c_binding_dt (int sym_id)
3745 gfc_dt_list *dt_list;
3747 dt_list = gfc_derived_types;
3749 /* Loop through the derived types in the name list, searching for
3750 the desired symbol from iso_c_binding. Search the parent namespaces
3751 if necessary and requested to (parent_flag). */
3752 while (dt_list != NULL)
3754 if (dt_list->derived->from_intmod != INTMOD_NONE
3755 && dt_list->derived->intmod_sym_id == sym_id)
3756 return dt_list->derived;
3758 dt_list = dt_list->next;
3765 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3766 with C. This is necessary for any derived type that is BIND(C) and for
3767 derived types that are parameters to functions that are BIND(C). All
3768 fields of the derived type are required to be interoperable, and are tested
3769 for such. If an error occurs, the errors are reported here, allowing for
3770 multiple errors to be handled for a single derived type. */
3773 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3775 gfc_component *curr_comp = NULL;
3776 gfc_try is_c_interop = FAILURE;
3777 gfc_try retval = SUCCESS;
3779 if (derived_sym == NULL)
3780 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3781 "unexpectedly NULL");
3783 /* If we've already looked at this derived symbol, do not look at it again
3784 so we don't repeat warnings/errors. */
3785 if (derived_sym->ts.is_c_interop)
3788 /* The derived type must have the BIND attribute to be interoperable
3789 J3/04-007, Section 15.2.3. */
3790 if (derived_sym->attr.is_bind_c != 1)
3792 derived_sym->ts.is_c_interop = 0;
3793 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3794 "attribute to be C interoperable", derived_sym->name,
3795 &(derived_sym->declared_at));
3799 curr_comp = derived_sym->components;
3801 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
3802 empty struct. Section 15.2 in Fortran 2003 states: "The following
3803 subclauses define the conditions under which a Fortran entity is
3804 interoperable. If a Fortran entity is interoperable, an equivalent
3805 entity may be defined by means of C and the Fortran entity is said
3806 to be interoperable with the C entity. There does not have to be such
3807 an interoperating C entity."
3809 if (curr_comp == NULL)
3811 gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
3812 "and may be inaccessible by the C companion processor",
3813 derived_sym->name, &(derived_sym->declared_at));
3814 derived_sym->ts.is_c_interop = 1;
3815 derived_sym->attr.is_bind_c = 1;
3820 /* Initialize the derived type as being C interoperable.
3821 If we find an error in the components, this will be set false. */
3822 derived_sym->ts.is_c_interop = 1;
3824 /* Loop through the list of components to verify that the kind of
3825 each is a C interoperable type. */
3828 /* The components cannot be pointers (fortran sense).
3829 J3/04-007, Section 15.2.3, C1505. */
3830 if (curr_comp->attr.pointer != 0)
3832 gfc_error ("Component '%s' at %L cannot have the "
3833 "POINTER attribute because it is a member "
3834 "of the BIND(C) derived type '%s' at %L",
3835 curr_comp->name, &(curr_comp->loc),
3836 derived_sym->name, &(derived_sym->declared_at));
3840 if (curr_comp->attr.proc_pointer != 0)
3842 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3843 " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3844 &curr_comp->loc, derived_sym->name,
3845 &derived_sym->declared_at);
3849 /* The components cannot be allocatable.
3850 J3/04-007, Section 15.2.3, C1505. */
3851 if (curr_comp->attr.allocatable != 0)
3853 gfc_error ("Component '%s' at %L cannot have the "
3854 "ALLOCATABLE attribute because it is a member "
3855 "of the BIND(C) derived type '%s' at %L",
3856 curr_comp->name, &(curr_comp->loc),
3857 derived_sym->name, &(derived_sym->declared_at));
3861 /* BIND(C) derived types must have interoperable components. */
3862 if (curr_comp->ts.type == BT_DERIVED
3863 && curr_comp->ts.u.derived->ts.is_iso_c != 1
3864 && curr_comp->ts.u.derived != derived_sym)
3866 /* This should be allowed; the draft says a derived-type can not
3867 have type parameters if it is has the BIND attribute. Type
3868 parameters seem to be for making parameterized derived types.
3869 There's no need to verify the type if it is c_ptr/c_funptr. */
3870 retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3874 /* Grab the typespec for the given component and test the kind. */
3875 is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
3877 if (is_c_interop != SUCCESS)
3879 /* Report warning and continue since not fatal. The
3880 draft does specify a constraint that requires all fields
3881 to interoperate, but if the user says real(4), etc., it
3882 may interoperate with *something* in C, but the compiler
3883 most likely won't know exactly what. Further, it may not
3884 interoperate with the same data type(s) in C if the user
3885 recompiles with different flags (e.g., -m32 and -m64 on
3886 x86_64 and using integer(4) to claim interop with a
3888 if (derived_sym->attr.is_bind_c == 1
3889 && gfc_option.warn_c_binding_type)
3890 /* If the derived type is bind(c), all fields must be
3892 gfc_warning ("Component '%s' in derived type '%s' at %L "
3893 "may not be C interoperable, even though "
3894 "derived type '%s' is BIND(C)",
3895 curr_comp->name, derived_sym->name,
3896 &(curr_comp->loc), derived_sym->name);
3897 else if (gfc_option.warn_c_binding_type)
3898 /* If derived type is param to bind(c) routine, or to one
3899 of the iso_c_binding procs, it must be interoperable, so
3900 all fields must interop too. */
3901 gfc_warning ("Component '%s' in derived type '%s' at %L "
3902 "may not be C interoperable",
3903 curr_comp->name, derived_sym->name,
3908 curr_comp = curr_comp->next;
3909 } while (curr_comp != NULL);
3912 /* Make sure we don't have conflicts with the attributes. */
3913 if (derived_sym->attr.access == ACCESS_PRIVATE)
3915 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3916 "PRIVATE and BIND(C) attributes", derived_sym->name,
3917 &(derived_sym->declared_at));
3921 if (derived_sym->attr.sequence != 0)
3923 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3924 "attribute because it is BIND(C)", derived_sym->name,
3925 &(derived_sym->declared_at));
3929 /* Mark the derived type as not being C interoperable if we found an
3930 error. If there were only warnings, proceed with the assumption
3931 it's interoperable. */
3932 if (retval == FAILURE)
3933 derived_sym->ts.is_c_interop = 0;
3939 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3942 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3943 const char *module_name)
3945 gfc_symtree *tmp_symtree;
3946 gfc_symbol *tmp_sym;
3949 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3951 if (tmp_symtree != NULL)
3952 tmp_sym = tmp_symtree->n.sym;
3956 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3957 "create symbol for %s", ptr_name);
3960 tmp_sym->ts.is_c_interop = 1;
3961 tmp_sym->attr.is_c_interop = 1;
3962 tmp_sym->ts.is_iso_c = 1;
3963 tmp_sym->ts.type = BT_DERIVED;
3964 tmp_sym->attr.flavor = FL_PARAMETER;
3966 /* The c_ptr and c_funptr derived types will provide the
3967 definition for c_null_ptr and c_null_funptr, respectively. */
3968 if (ptr_id == ISOCBINDING_NULL_PTR)
3969 tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3971 tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3972 if (tmp_sym->ts.u.derived == NULL)
3974 /* This can occur if the user forgot to declare c_ptr or
3975 c_funptr and they're trying to use one of the procedures
3976 that has arg(s) of the missing type. In this case, a
3977 regular version of the thing should have been put in the
3980 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3981 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3982 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3985 tmp_sym->ts.u.derived =
3986 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3987 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3990 /* Module name is some mangled version of iso_c_binding. */
3991 tmp_sym->module = gfc_get_string (module_name);
3993 /* Say it's from the iso_c_binding module. */
3994 tmp_sym->attr.is_iso_c = 1;
3996 tmp_sym->attr.use_assoc = 1;
3997 tmp_sym->attr.is_bind_c = 1;
3998 /* Since we never generate a call to this symbol, don't set the
4001 /* Set the c_address field of c_null_ptr and c_null_funptr to
4002 the value of NULL. */
4003 tmp_sym->value = gfc_get_expr ();
4004 tmp_sym->value->expr_type = EXPR_STRUCTURE;
4005 tmp_sym->value->ts.type = BT_DERIVED;
4006 tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
4007 gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
4008 c = gfc_constructor_first (tmp_sym->value->value.constructor);
4009 c->expr = gfc_get_expr ();
4010 c->expr->expr_type = EXPR_NULL;
4011 c->expr->ts.is_iso_c = 1;
4017 /* Add a formal argument, gfc_formal_arglist, to the
4018 end of the given list of arguments. Set the reference to the
4019 provided symbol, param_sym, in the argument. */
4022 add_formal_arg (gfc_formal_arglist **head,
4023 gfc_formal_arglist **tail,
4024 gfc_formal_arglist *formal_arg,
4025 gfc_symbol *param_sym)
4027 /* Put in list, either as first arg or at the tail (curr arg). */
4029 *head = *tail = formal_arg;
4032 (*tail)->next = formal_arg;
4033 (*tail) = formal_arg;
4036 (*tail)->sym = param_sym;
4037 (*tail)->next = NULL;
4043 /* Generates a symbol representing the CPTR argument to an
4044 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
4045 CPTR and add it to the provided argument list. */
4048 gen_cptr_param (gfc_formal_arglist **head,
4049 gfc_formal_arglist **tail,
4050 const char *module_name,
4051 gfc_namespace *ns, const char *c_ptr_name,
4054 gfc_symbol *param_sym = NULL;
4055 gfc_symbol *c_ptr_sym = NULL;
4056 gfc_symtree *param_symtree = NULL;
4057 gfc_formal_arglist *formal_arg = NULL;
4058 const char *c_ptr_in;
4059 const char *c_ptr_type = NULL;
4061 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
4062 c_ptr_type = "c_funptr";
4064 c_ptr_type = "c_ptr";
4066 if(c_ptr_name == NULL)
4067 c_ptr_in = "gfc_cptr__";
4069 c_ptr_in = c_ptr_name;
4070 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree, false);
4071 if (param_symtree != NULL)
4072 param_sym = param_symtree->n.sym;
4074 gfc_internal_error ("gen_cptr_param(): Unable to "
4075 "create symbol for %s", c_ptr_in);
4077 /* Set up the appropriate fields for the new c_ptr param sym. */
4079 param_sym->attr.flavor = FL_DERIVED;
4080 param_sym->ts.type = BT_DERIVED;
4081 param_sym->attr.intent = INTENT_IN;
4082 param_sym->attr.dummy = 1;
4084 /* This will pass the ptr to the iso_c routines as a (void *). */
4085 param_sym->attr.value = 1;
4086 param_sym->attr.use_assoc = 1;
4088 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
4090 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
4091 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4093 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
4094 if (c_ptr_sym == NULL)
4096 /* This can happen if the user did not define c_ptr but they are
4097 trying to use one of the iso_c_binding functions that need it. */
4098 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
4099 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
4100 (const char *)c_ptr_type);
4102 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
4103 (const char *)c_ptr_type);
4105 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
4108 param_sym->ts.u.derived = c_ptr_sym;
4109 param_sym->module = gfc_get_string (module_name);
4111 /* Make new formal arg. */
4112 formal_arg = gfc_get_formal_arglist ();
4113 /* Add arg to list of formal args (the CPTR arg). */
4114 add_formal_arg (head, tail, formal_arg, param_sym);
4116 /* Validate changes. */
4117 gfc_commit_symbol (param_sym);
4121 /* Generates a symbol representing the FPTR argument to an
4122 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
4123 FPTR and add it to the provided argument list. */
4126 gen_fptr_param (gfc_formal_arglist **head,
4127 gfc_formal_arglist **tail,
4128 const char *module_name,
4129 gfc_namespace *ns, const char *f_ptr_name, int proc)
4131 gfc_symbol *param_sym = NULL;
4132 gfc_symtree *param_symtree = NULL;
4133 gfc_formal_arglist *formal_arg = NULL;
4134 const char *f_ptr_out = "gfc_fptr__";
4136 if (f_ptr_name != NULL)
4137 f_ptr_out = f_ptr_name;
4139 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree, false);
4140 if (param_symtree != NULL)
4141 param_sym = param_symtree->n.sym;
4143 gfc_internal_error ("generateFPtrParam(): Unable to "
4144 "create symbol for %s", f_ptr_out);
4146 /* Set up the necessary fields for the fptr output param sym. */
4149 param_sym->attr.proc_pointer = 1;
4151 param_sym->attr.pointer = 1;
4152 param_sym->attr.dummy = 1;
4153 param_sym->attr.use_assoc = 1;
4155 /* ISO C Binding type to allow any pointer type as actual param. */
4156 param_sym->ts.type = BT_VOID;
4157 param_sym->module = gfc_get_string (module_name);
4160 formal_arg = gfc_get_formal_arglist ();
4161 /* Add arg to list of formal args. */
4162 add_formal_arg (head, tail, formal_arg, param_sym);
4164 /* Validate changes. */
4165 gfc_commit_symbol (param_sym);
4169 /* Generates a symbol representing the optional SHAPE argument for the
4170 iso_c_binding c_f_pointer() procedure. Also, create a
4171 gfc_formal_arglist for the SHAPE and add it to the provided
4175 gen_shape_param (gfc_formal_arglist **head,
4176 gfc_formal_arglist **tail,
4177 const char *module_name,
4178 gfc_namespace *ns, const char *shape_param_name)
4180 gfc_symbol *param_sym = NULL;
4181 gfc_symtree *param_symtree = NULL;
4182 gfc_formal_arglist *formal_arg = NULL;
4183 const char *shape_param = "gfc_shape_array__";
4185 if (shape_param_name != NULL)
4186 shape_param = shape_param_name;
4188 gfc_get_sym_tree (shape_param, ns, ¶m_symtree, false);
4189 if (param_symtree != NULL)
4190 param_sym = param_symtree->n.sym;
4192 gfc_internal_error ("generateShapeParam(): Unable to "
4193 "create symbol for %s", shape_param);
4195 /* Set up the necessary fields for the shape input param sym. */
4197 param_sym->attr.dummy = 1;
4198 param_sym->attr.use_assoc = 1;
4200 /* Integer array, rank 1, describing the shape of the object. Make it's
4201 type BT_VOID initially so we can accept any type/kind combination of
4202 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
4203 of BT_INTEGER type. */
4204 param_sym->ts.type = BT_VOID;
4206 /* Initialize the kind to default integer. However, it will be overridden
4207 during resolution to match the kind of the SHAPE parameter given as
4208 the actual argument (to allow for any valid integer kind). */
4209 param_sym->ts.kind = gfc_default_integer_kind;
4210 param_sym->as = gfc_get_array_spec ();
4212 param_sym->as->rank = 1;
4213 param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
4216 /* The extent is unknown until we get it. The length give us
4217 the rank the incoming pointer. */
4218 param_sym->as->type = AS_ASSUMED_SHAPE;
4220 /* The arg is also optional; it is required iff the second arg
4221 (fptr) is to an array, otherwise, it's ignored. */
4222 param_sym->attr.optional = 1;
4223 param_sym->attr.intent = INTENT_IN;
4224 param_sym->attr.dimension = 1;
4225 param_sym->module = gfc_get_string (module_name);
4228 formal_arg = gfc_get_formal_arglist ();
4229 /* Add arg to list of formal args. */
4230 add_formal_arg (head, tail, formal_arg, param_sym);
4232 /* Validate changes. */
4233 gfc_commit_symbol (param_sym);
4237 /* Add a procedure interface to the given symbol (i.e., store a
4238 reference to the list of formal arguments). */
4241 add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
4244 sym->formal = formal;
4245 sym->attr.if_source = source;
4249 /* Copy the formal args from an existing symbol, src, into a new
4250 symbol, dest. New formal args are created, and the description of
4251 each arg is set according to the existing ones. This function is
4252 used when creating procedure declaration variables from a procedure
4253 declaration statement (see match_proc_decl()) to create the formal
4254 args based on the args of a given named interface. */
4257 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
4259 gfc_formal_arglist *head = NULL;
4260 gfc_formal_arglist *tail = NULL;
4261 gfc_formal_arglist *formal_arg = NULL;
4262 gfc_intrinsic_arg *curr_arg = NULL;
4263 gfc_formal_arglist *formal_prev = NULL;
4264 /* Save current namespace so we can change it for formal args. */
4265 gfc_namespace *parent_ns = gfc_current_ns;
4267 /* Create a new namespace, which will be the formal ns (namespace
4268 of the formal args). */
4269 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4270 gfc_current_ns->proc_name = dest;
4272 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4274 formal_arg = gfc_get_formal_arglist ();
4275 gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4277 /* May need to copy more info for the symbol. */
4278 formal_arg->sym->ts = curr_arg->ts;
4279 formal_arg->sym->attr.optional = curr_arg->optional;
4280 formal_arg->sym->attr.value = curr_arg->value;
4281 formal_arg->sym->attr.intent = curr_arg->intent;
4282 formal_arg->sym->attr.flavor = FL_VARIABLE;
4283 formal_arg->sym->attr.dummy = 1;
4285 if (formal_arg->sym->ts.type == BT_CHARACTER)
4286 formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4288 /* If this isn't the first arg, set up the next ptr. For the
4289 last arg built, the formal_arg->next will never get set to
4290 anything other than NULL. */
4291 if (formal_prev != NULL)
4292 formal_prev->next = formal_arg;
4294 formal_arg->next = NULL;
4296 formal_prev = formal_arg;
4298 /* Add arg to list of formal args. */
4299 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4301 /* Validate changes. */
4302 gfc_commit_symbol (formal_arg->sym);
4305 /* Add the interface to the symbol. */
4306 add_proc_interface (dest, IFSRC_DECL, head);
4308 /* Store the formal namespace information. */
4309 if (dest->formal != NULL)
4310 /* The current ns should be that for the dest proc. */
4311 dest->formal_ns = gfc_current_ns;
4312 /* Restore the current namespace to what it was on entry. */
4313 gfc_current_ns = parent_ns;
4317 /* Builds the parameter list for the iso_c_binding procedure
4318 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
4319 generic version of either the c_f_pointer or c_f_procpointer
4320 functions. The new_proc_sym represents a "resolved" version of the
4321 symbol. The functions are resolved to match the types of their
4322 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4323 something similar to c_f_pointer_i4 if the type of data object fptr
4324 pointed to was a default integer. The actual name of the resolved
4325 procedure symbol is further mangled with the module name, etc., but
4326 the idea holds true. */
4329 build_formal_args (gfc_symbol *new_proc_sym,
4330 gfc_symbol *old_sym, int add_optional_arg)
4332 gfc_formal_arglist *head = NULL, *tail = NULL;
4333 gfc_namespace *parent_ns = NULL;
4335 parent_ns = gfc_current_ns;
4336 /* Create a new namespace, which will be the formal ns (namespace
4337 of the formal args). */
4338 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
4339 gfc_current_ns->proc_name = new_proc_sym;
4341 /* Generate the params. */
4342 if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
4344 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4345 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4346 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4347 gfc_current_ns, "fptr", 1);
4349 else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
4351 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4352 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4353 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4354 gfc_current_ns, "fptr", 0);
4355 /* If we're dealing with c_f_pointer, it has an optional third arg. */
4356 gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
4357 gfc_current_ns, "shape");
4360 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
4362 /* c_associated has one required arg and one optional; both
4364 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4365 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
4366 if (add_optional_arg)
4368 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4369 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
4370 /* The last param is optional so mark it as such. */
4371 tail->sym->attr.optional = 1;
4375 /* Add the interface (store formal args to new_proc_sym). */
4376 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
4378 /* Set up the formal_ns pointer to the one created for the
4379 new procedure so it'll get cleaned up during gfc_free_symbol(). */
4380 new_proc_sym->formal_ns = gfc_current_ns;
4382 gfc_current_ns = parent_ns;
4386 std_for_isocbinding_symbol (int id)
4390 #define NAMED_INTCST(a,b,c,d) \
4393 #include "iso-c-binding.def"
4396 #define NAMED_FUNCTION(a,b,c,d) \
4399 #include "iso-c-binding.def"
4400 #undef NAMED_FUNCTION
4403 return GFC_STD_F2003;
4407 /* Generate the given set of C interoperable kind objects, or all
4408 interoperable kinds. This function will only be given kind objects
4409 for valid iso_c_binding defined types because this is verified when
4410 the 'use' statement is parsed. If the user gives an 'only' clause,
4411 the specific kinds are looked up; if they don't exist, an error is
4412 reported. If the user does not give an 'only' clause, all
4413 iso_c_binding symbols are generated. If a list of specific kinds
4414 is given, it must have a NULL in the first empty spot to mark the
4419 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4420 const char *local_name)
4422 const char *const name = (local_name && local_name[0]) ? local_name
4423 : c_interop_kinds_table[s].name;
4424 gfc_symtree *tmp_symtree = NULL;
4425 gfc_symbol *tmp_sym = NULL;
4428 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4431 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4433 /* Already exists in this scope so don't re-add it. */
4434 if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
4435 && (!tmp_sym->attr.generic
4436 || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
4437 && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
4439 if (tmp_sym->attr.flavor == FL_DERIVED
4440 && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
4442 gfc_dt_list *dt_list;
4443 dt_list = gfc_get_dt_list ();
4444 dt_list->derived = tmp_sym;
4445 dt_list->next = gfc_derived_types;
4446 gfc_derived_types = dt_list;
4452 /* Create the sym tree in the current ns. */
4453 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4455 tmp_sym = tmp_symtree->n.sym;
4457 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4460 /* Say what module this symbol belongs to. */
4461 tmp_sym->module = gfc_get_string (mod_name);
4462 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4463 tmp_sym->intmod_sym_id = s;
4468 #define NAMED_INTCST(a,b,c,d) case a :
4469 #define NAMED_REALCST(a,b,c,d) case a :
4470 #define NAMED_CMPXCST(a,b,c,d) case a :
4471 #define NAMED_LOGCST(a,b,c) case a :
4472 #define NAMED_CHARKNDCST(a,b,c) case a :
4473 #include "iso-c-binding.def"
4475 tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4476 c_interop_kinds_table[s].value);
4478 /* Initialize an integer constant expression node. */
4479 tmp_sym->attr.flavor = FL_PARAMETER;
4480 tmp_sym->ts.type = BT_INTEGER;
4481 tmp_sym->ts.kind = gfc_default_integer_kind;
4483 /* Mark this type as a C interoperable one. */
4484 tmp_sym->ts.is_c_interop = 1;
4485 tmp_sym->ts.is_iso_c = 1;
4486 tmp_sym->value->ts.is_c_interop = 1;
4487 tmp_sym->value->ts.is_iso_c = 1;
4488 tmp_sym->attr.is_c_interop = 1;
4490 /* Tell what f90 type this c interop kind is valid. */
4491 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4493 /* Say it's from the iso_c_binding module. */
4494 tmp_sym->attr.is_iso_c = 1;
4496 /* Make it use associated. */
4497 tmp_sym->attr.use_assoc = 1;
4501 #define NAMED_CHARCST(a,b,c) case a :
4502 #include "iso-c-binding.def"
4504 /* Initialize an integer constant expression node for the
4505 length of the character. */
4506 tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
4507 &gfc_current_locus, NULL, 1);
4508 tmp_sym->value->ts.is_c_interop = 1;
4509 tmp_sym->value->ts.is_iso_c = 1;
4510 tmp_sym->value->value.character.length = 1;
4511 tmp_sym->value->value.character.string[0]
4512 = (gfc_char_t) c_interop_kinds_table[s].value;
4513 tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4514 tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
4517 /* May not need this in both attr and ts, but do need in
4518 attr for writing module file. */
4519 tmp_sym->attr.is_c_interop = 1;
4521 tmp_sym->attr.flavor = FL_PARAMETER;
4522 tmp_sym->ts.type = BT_CHARACTER;
4524 /* Need to set it to the C_CHAR kind. */
4525 tmp_sym->ts.kind = gfc_default_character_kind;
4527 /* Mark this type as a C interoperable one. */
4528 tmp_sym->ts.is_c_interop = 1;
4529 tmp_sym->ts.is_iso_c = 1;
4531 /* Tell what f90 type this c interop kind is valid. */
4532 tmp_sym->ts.f90_type = BT_CHARACTER;
4534 /* Say it's from the iso_c_binding module. */
4535 tmp_sym->attr.is_iso_c = 1;
4537 /* Make it use associated. */
4538 tmp_sym->attr.use_assoc = 1;
4541 case ISOCBINDING_PTR:
4542 case ISOCBINDING_FUNPTR:
4544 gfc_interface *intr, *head;
4546 const char *hidden_name;
4547 gfc_dt_list **dt_list_ptr = NULL;
4548 gfc_component *tmp_comp = NULL;
4549 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
4551 hidden_name = gfc_get_string ("%c%s",
4552 (char) TOUPPER ((unsigned char) tmp_sym->name[0]),
4555 /* Generate real derived type. */
4556 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4559 if (tmp_symtree != NULL)
4561 gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
4563 dt_sym = tmp_symtree->n.sym;
4567 /* Generate an artificial generic function. */
4568 dt_sym->name = gfc_get_string (tmp_sym->name);
4569 head = tmp_sym->generic;
4570 intr = gfc_get_interface ();
4572 intr->where = gfc_current_locus;
4574 tmp_sym->generic = intr;
4576 if (!tmp_sym->attr.generic
4577 && gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
4581 if (!tmp_sym->attr.function
4582 && gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
4586 /* Say what module this symbol belongs to. */
4587 dt_sym->module = gfc_get_string (mod_name);
4588 dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
4589 dt_sym->intmod_sym_id = s;
4591 /* Initialize an integer constant expression node. */
4592 dt_sym->attr.flavor = FL_DERIVED;
4593 dt_sym->ts.is_c_interop = 1;
4594 dt_sym->attr.is_c_interop = 1;
4595 dt_sym->attr.is_iso_c = 1;
4596 dt_sym->ts.is_iso_c = 1;
4597 dt_sym->ts.type = BT_DERIVED;
4599 /* A derived type must have the bind attribute to be
4600 interoperable (J3/04-007, Section 15.2.3), even though
4601 the binding label is not used. */
4602 dt_sym->attr.is_bind_c = 1;
4604 dt_sym->attr.referenced = 1;
4605 dt_sym->ts.u.derived = dt_sym;
4607 /* Add the symbol created for the derived type to the current ns. */
4608 dt_list_ptr = &(gfc_derived_types);
4609 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4610 dt_list_ptr = &((*dt_list_ptr)->next);
4612 /* There is already at least one derived type in the list, so append
4613 the one we're currently building for c_ptr or c_funptr. */
4614 if (*dt_list_ptr != NULL)
4615 dt_list_ptr = &((*dt_list_ptr)->next);
4616 (*dt_list_ptr) = gfc_get_dt_list ();
4617 (*dt_list_ptr)->derived = dt_sym;
4618 (*dt_list_ptr)->next = NULL;
4620 /* Set up the component of the derived type, which will be
4621 an integer with kind equal to c_ptr_size. Mangle the name of
4622 the field for the c_address to prevent the curious user from
4623 trying to access it from Fortran. */
4624 sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address");
4625 gfc_add_component (dt_sym, comp_name, &tmp_comp);
4626 if (tmp_comp == NULL)
4627 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4628 "create component for c_address");
4630 tmp_comp->ts.type = BT_INTEGER;
4632 /* Set this because the module will need to read/write this field. */
4633 tmp_comp->ts.f90_type = BT_INTEGER;
4635 /* The kinds for c_ptr and c_funptr are the same. */
4636 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4637 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4639 tmp_comp->attr.pointer = 0;
4640 tmp_comp->attr.dimension = 0;
4642 /* Mark the component as C interoperable. */
4643 tmp_comp->ts.is_c_interop = 1;
4645 /* Make it use associated (iso_c_binding module). */
4646 dt_sym->attr.use_assoc = 1;
4651 case ISOCBINDING_NULL_PTR:
4652 case ISOCBINDING_NULL_FUNPTR:
4653 gen_special_c_interop_ptr (s, name, mod_name);
4656 case ISOCBINDING_F_POINTER:
4657 case ISOCBINDING_ASSOCIATED:
4658 case ISOCBINDING_LOC:
4659 case ISOCBINDING_FUNLOC:
4660 case ISOCBINDING_F_PROCPOINTER:
4662 tmp_sym->attr.proc = PROC_MODULE;
4664 /* Use the procedure's name as it is in the iso_c_binding module for
4665 setting the binding label in case the user renamed the symbol. */
4666 tmp_sym->binding_label =
4667 gfc_get_string ("%s_%s", mod_name,
4668 c_interop_kinds_table[s].name);
4669 tmp_sym->attr.is_iso_c = 1;
4670 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4671 tmp_sym->attr.subroutine = 1;
4674 /* TODO! This needs to be finished more for the expr of the
4675 function or something!
4676 This may not need to be here, because trying to do c_loc
4678 if (s == ISOCBINDING_ASSOCIATED)
4680 tmp_sym->attr.function = 1;
4681 tmp_sym->ts.type = BT_LOGICAL;
4682 tmp_sym->ts.kind = gfc_default_logical_kind;
4683 tmp_sym->result = tmp_sym;
4687 /* Here, we're taking the simple approach. We're defining
4688 c_loc as an external identifier so the compiler will put
4689 what we expect on the stack for the address we want the
4691 tmp_sym->ts.type = BT_DERIVED;
4692 if (s == ISOCBINDING_LOC)
4693 tmp_sym->ts.u.derived =
4694 get_iso_c_binding_dt (ISOCBINDING_PTR);
4696 tmp_sym->ts.u.derived =
4697 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4699 if (tmp_sym->ts.u.derived == NULL)
4701 /* Create the necessary derived type so we can continue
4702 processing the file. */
4703 generate_isocbinding_symbol
4704 (mod_name, s == ISOCBINDING_FUNLOC
4705 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4706 (const char *)(s == ISOCBINDING_FUNLOC
4707 ? "c_funptr" : "c_ptr"));
4708 tmp_sym->ts.u.derived =
4709 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4710 ? ISOCBINDING_FUNPTR
4714 /* The function result is itself (no result clause). */
4715 tmp_sym->result = tmp_sym;
4716 tmp_sym->attr.external = 1;
4717 tmp_sym->attr.use_assoc = 0;
4718 tmp_sym->attr.pure = 1;
4719 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4720 tmp_sym->attr.proc = PROC_UNKNOWN;
4724 tmp_sym->attr.flavor = FL_PROCEDURE;
4725 tmp_sym->attr.contained = 0;
4727 /* Try using this builder routine, with the new and old symbols
4728 both being the generic iso_c proc sym being created. This
4729 will create the formal args (and the new namespace for them).
4730 Don't build an arg list for c_loc because we're going to treat
4731 c_loc as an external procedure. */
4732 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4733 /* The 1 says to add any optional args, if applicable. */
4734 build_formal_args (tmp_sym, tmp_sym, 1);
4736 /* Set this after setting up the symbol, to prevent error messages. */
4737 tmp_sym->attr.use_assoc = 1;
4739 /* This symbol will not be referenced directly. It will be
4740 resolved to the implementation for the given f90 kind. */
4741 tmp_sym->attr.referenced = 0;
4748 gfc_commit_symbol (tmp_sym);
4752 /* Creates a new symbol based off of an old iso_c symbol, with a new
4753 binding label. This function can be used to create a new,
4754 resolved, version of a procedure symbol for c_f_pointer or
4755 c_f_procpointer that is based on the generic symbols. A new
4756 parameter list is created for the new symbol using
4757 build_formal_args(). The add_optional_flag specifies whether the
4758 to add the optional SHAPE argument. The new symbol is
4762 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4763 const char *new_binding_label, int add_optional_arg)
4765 gfc_symtree *new_symtree = NULL;
4767 /* See if we have a symbol by that name already available, looking
4768 through any parent namespaces. */
4769 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4770 if (new_symtree != NULL)
4771 /* Return the existing symbol. */
4772 return new_symtree->n.sym;
4774 /* Create the symtree/symbol, with attempted host association. */
4775 gfc_get_ha_sym_tree (new_name, &new_symtree);
4776 if (new_symtree == NULL)
4777 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4778 "symtree for '%s'", new_name);
4780 /* Now fill in the fields of the resolved symbol with the old sym. */
4781 new_symtree->n.sym->binding_label = new_binding_label;
4782 new_symtree->n.sym->attr = old_sym->attr;
4783 new_symtree->n.sym->ts = old_sym->ts;
4784 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4785 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4786 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4787 if (old_sym->attr.function)
4788 new_symtree->n.sym->result = new_symtree->n.sym;
4789 /* Build the formal arg list. */
4790 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4792 gfc_commit_symbol (new_symtree->n.sym);
4794 return new_symtree->n.sym;
4798 /* Check that a symbol is already typed. If strict is not set, an untyped
4799 symbol is acceptable for non-standard-conforming mode. */
4802 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4803 bool strict, locus where)
4807 if (gfc_matching_prefix)
4810 /* Check for the type and try to give it an implicit one. */
4811 if (sym->ts.type == BT_UNKNOWN
4812 && gfc_set_default_type (sym, 0, ns) == FAILURE)
4816 gfc_error ("Symbol '%s' is used before it is typed at %L",
4821 if (gfc_notify_std (GFC_STD_GNU,
4822 "Symbol '%s' is used before"
4823 " it is typed at %L", sym->name, &where) == FAILURE)
4827 /* Everything is ok. */
4832 /* Construct a typebound-procedure structure. Those are stored in a tentative
4833 list and marked `error' until symbols are committed. */
4836 gfc_get_typebound_proc (gfc_typebound_proc *tb0)
4838 gfc_typebound_proc *result;
4840 result = XCNEW (gfc_typebound_proc);
4845 latest_undo_chgset->tbps.safe_push (result);
4851 /* Get the super-type of a given derived type. */
4854 gfc_get_derived_super_type (gfc_symbol* derived)
4856 gcc_assert (derived);
4858 if (derived->attr.generic)
4859 derived = gfc_find_dt_in_generic (derived);
4861 if (!derived->attr.extension)
4864 gcc_assert (derived->components);
4865 gcc_assert (derived->components->ts.type == BT_DERIVED);
4866 gcc_assert (derived->components->ts.u.derived);
4868 if (derived->components->ts.u.derived->attr.generic)
4869 return gfc_find_dt_in_generic (derived->components->ts.u.derived);
4871 return derived->components->ts.u.derived;
4875 /* Get the ultimate super-type of a given derived type. */
4878 gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
4880 if (!derived->attr.extension)
4883 derived = gfc_get_derived_super_type (derived);
4885 if (derived->attr.extension)
4886 return gfc_get_ultimate_derived_super_type (derived);
4892 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4895 gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
4897 while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
4898 t2 = gfc_get_derived_super_type (t2);
4899 return gfc_compare_derived_types (t1, t2);
4903 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4904 If ts1 is nonpolymorphic, ts2 must be the same type.
4905 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4908 gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
4910 bool is_class1 = (ts1->type == BT_CLASS);
4911 bool is_class2 = (ts2->type == BT_CLASS);
4912 bool is_derived1 = (ts1->type == BT_DERIVED);
4913 bool is_derived2 = (ts2->type == BT_DERIVED);
4916 && ts1->u.derived->components
4917 && ts1->u.derived->components->ts.u.derived->attr.unlimited_polymorphic)
4920 if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
4921 return (ts1->type == ts2->type);
4923 if (is_derived1 && is_derived2)
4924 return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
4926 if (is_class1 && is_derived2)
4927 return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4929 else if (is_class1 && is_class2)
4930 return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4931 ts2->u.derived->components->ts.u.derived);
4937 /* Find the parent-namespace of the current function. If we're inside
4938 BLOCK constructs, it may not be the current one. */
4941 gfc_find_proc_namespace (gfc_namespace* ns)
4943 while (ns->construct_entities)
4953 /* Check if an associate-variable should be translated as an `implicit' pointer
4954 internally (if it is associated to a variable and not an array with
4958 gfc_is_associate_pointer (gfc_symbol* sym)
4963 if (sym->ts.type == BT_CLASS)
4966 if (!sym->assoc->variable)
4969 if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
4977 gfc_find_dt_in_generic (gfc_symbol *sym)
4979 gfc_interface *intr = NULL;
4981 if (!sym || sym->attr.flavor == FL_DERIVED)
4984 if (sym->attr.generic)
4985 for (intr = sym->generic; intr; intr = intr->next)
4986 if (intr->sym->attr.flavor == FL_DERIVED)
4988 return intr ? intr->sym : NULL;
4992 /* Get the dummy arguments from a procedure symbol. If it has been declared
4993 via a PROCEDURE statement with a named interface, ts.interface will be set
4994 and the arguments need to be taken from there. */
4996 gfc_formal_arglist *
4997 gfc_sym_get_dummy_args (gfc_symbol *sym)
4999 gfc_formal_arglist *dummies;
5001 dummies = sym->formal;
5002 if (dummies == NULL && sym->ts.interface != NULL)
5003 dummies = sym->ts.interface->formal;