1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
30 #include "constructor.h"
33 /* Strings for all symbol attributes. We use these for dumping the
34 parse tree, in error messages, and also when reading and writing
37 const mstring flavors[] =
39 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
40 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
41 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
42 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
43 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
47 const mstring procedures[] =
49 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
50 minit ("MODULE-PROC", PROC_MODULE),
51 minit ("INTERNAL-PROC", PROC_INTERNAL),
52 minit ("DUMMY-PROC", PROC_DUMMY),
53 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
54 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
55 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
59 const mstring intents[] =
61 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
62 minit ("IN", INTENT_IN),
63 minit ("OUT", INTENT_OUT),
64 minit ("INOUT", INTENT_INOUT),
68 const mstring access_types[] =
70 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
71 minit ("PUBLIC", ACCESS_PUBLIC),
72 minit ("PRIVATE", ACCESS_PRIVATE),
76 const mstring ifsrc_types[] =
78 minit ("UNKNOWN", IFSRC_UNKNOWN),
79 minit ("DECL", IFSRC_DECL),
80 minit ("BODY", IFSRC_IFBODY)
83 const mstring save_status[] =
85 minit ("UNKNOWN", SAVE_NONE),
86 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
87 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
90 /* This is to make sure the backend generates setup code in the correct
93 static int next_dummy_order = 1;
96 gfc_namespace *gfc_current_ns;
97 gfc_namespace *gfc_global_ns_list;
99 gfc_gsymbol *gfc_gsym_root = NULL;
101 static gfc_symbol *changed_syms = NULL;
103 gfc_dt_list *gfc_derived_types;
106 /* List of tentative typebound-procedures. */
108 typedef struct tentative_tbp
110 gfc_typebound_proc *proc;
111 struct tentative_tbp *next;
115 static tentative_tbp *tentative_tbp_list = NULL;
118 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
120 /* The following static variable indicates whether a particular element has
121 been explicitly set or not. */
123 static int new_flag[GFC_LETTERS];
126 /* Handle a correctly parsed IMPLICIT NONE. */
129 gfc_set_implicit_none (void)
133 if (gfc_current_ns->seen_implicit_none)
135 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
139 gfc_current_ns->seen_implicit_none = 1;
141 for (i = 0; i < GFC_LETTERS; i++)
143 gfc_clear_ts (&gfc_current_ns->default_type[i]);
144 gfc_current_ns->set_flag[i] = 1;
149 /* Reset the implicit range flags. */
152 gfc_clear_new_implicit (void)
156 for (i = 0; i < GFC_LETTERS; i++)
161 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
164 gfc_add_new_implicit_range (int c1, int c2)
171 for (i = c1; i <= c2; i++)
175 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
187 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
188 the new implicit types back into the existing types will work. */
191 gfc_merge_new_implicit (gfc_typespec *ts)
195 if (gfc_current_ns->seen_implicit_none)
197 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
201 for (i = 0; i < GFC_LETTERS; i++)
205 if (gfc_current_ns->set_flag[i])
207 gfc_error ("Letter %c already has an IMPLICIT type at %C",
212 gfc_current_ns->default_type[i] = *ts;
213 gfc_current_ns->implicit_loc[i] = gfc_current_locus;
214 gfc_current_ns->set_flag[i] = 1;
221 /* Given a symbol, return a pointer to the typespec for its default type. */
224 gfc_get_default_type (const char *name, gfc_namespace *ns)
230 if (gfc_option.flag_allow_leading_underscore && letter == '_')
231 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
232 "gfortran developers, and should not be used for "
233 "implicitly typed variables");
235 if (letter < 'a' || letter > 'z')
236 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
241 return &ns->default_type[letter - 'a'];
245 /* Given a pointer to a symbol, set its type according to the first
246 letter of its name. Fails if the letter in question has no default
250 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
254 if (sym->ts.type != BT_UNKNOWN)
255 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
257 ts = gfc_get_default_type (sym->name, ns);
259 if (ts->type == BT_UNKNOWN)
261 if (error_flag && !sym->attr.untyped)
263 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
264 sym->name, &sym->declared_at);
265 sym->attr.untyped = 1; /* Ensure we only give an error once. */
272 sym->attr.implicit_type = 1;
274 if (ts->type == BT_CHARACTER && ts->u.cl)
275 sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
277 if (sym->attr.is_bind_c == 1)
279 /* BIND(C) variables should not be implicitly declared. */
280 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
281 "not be C interoperable", sym->name, &sym->declared_at);
282 sym->ts.f90_type = sym->ts.type;
285 if (sym->attr.dummy != 0)
287 if (sym->ns->proc_name != NULL
288 && (sym->ns->proc_name->attr.subroutine != 0
289 || sym->ns->proc_name->attr.function != 0)
290 && sym->ns->proc_name->attr.is_bind_c != 0)
292 /* Dummy args to a BIND(C) routine may not be interoperable if
293 they are implicitly typed. */
294 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
295 "be C interoperable but it is a dummy argument to "
296 "the BIND(C) procedure '%s' at %L", sym->name,
297 &(sym->declared_at), sym->ns->proc_name->name,
298 &(sym->ns->proc_name->declared_at));
299 sym->ts.f90_type = sym->ts.type;
307 /* This function is called from parse.c(parse_progunit) to check the
308 type of the function is not implicitly typed in the host namespace
309 and to implicitly type the function result, if necessary. */
312 gfc_check_function_type (gfc_namespace *ns)
314 gfc_symbol *proc = ns->proc_name;
316 if (!proc->attr.contained || proc->result->attr.implicit_type)
319 if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
321 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
324 if (proc->result != proc)
326 proc->ts = proc->result->ts;
327 proc->as = gfc_copy_array_spec (proc->result->as);
328 proc->attr.dimension = proc->result->attr.dimension;
329 proc->attr.pointer = proc->result->attr.pointer;
330 proc->attr.allocatable = proc->result->attr.allocatable;
333 else if (!proc->result->attr.proc_pointer)
335 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
336 proc->result->name, &proc->result->declared_at);
337 proc->result->attr.untyped = 1;
343 /******************** Symbol attribute stuff *********************/
345 /* This is a generic conflict-checker. We do this to avoid having a
346 single conflict in two places. */
348 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
349 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
350 #define conf_std(a, b, std) if (attr->a && attr->b)\
359 check_conflict (symbol_attribute *attr, const char *name, locus *where)
361 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
362 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
363 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
364 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
365 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
366 *privat = "PRIVATE", *recursive = "RECURSIVE",
367 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
368 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
369 *function = "FUNCTION", *subroutine = "SUBROUTINE",
370 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
371 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
372 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
373 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
374 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
375 *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
376 *contiguous = "CONTIGUOUS", *generic = "GENERIC";
377 static const char *threadprivate = "THREADPRIVATE";
383 where = &gfc_current_locus;
385 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
389 standard = GFC_STD_F2003;
393 if (attr->in_namelist && (attr->allocatable || attr->pointer))
396 a2 = attr->allocatable ? allocatable : pointer;
397 standard = GFC_STD_F2003;
401 /* Check for attributes not allowed in a BLOCK DATA. */
402 if (gfc_current_state () == COMP_BLOCK_DATA)
406 if (attr->in_namelist)
408 if (attr->allocatable)
414 if (attr->access == ACCESS_PRIVATE)
416 if (attr->access == ACCESS_PUBLIC)
418 if (attr->intent != INTENT_UNKNOWN)
424 ("%s attribute not allowed in BLOCK DATA program unit at %L",
430 if (attr->save == SAVE_EXPLICIT)
433 conf (in_common, save);
436 switch (attr->flavor)
444 a1 = gfc_code2string (flavors, attr->flavor);
449 /* Conflicts between SAVE and PROCEDURE will be checked at
450 resolution stage, see "resolve_fl_procedure". */
459 conf (dummy, intrinsic);
460 conf (dummy, threadprivate);
461 conf (pointer, target);
462 conf (pointer, intrinsic);
463 conf (pointer, elemental);
464 conf (allocatable, elemental);
466 conf (target, external);
467 conf (target, intrinsic);
469 if (!attr->if_source)
470 conf (external, dimension); /* See Fortran 95's R504. */
472 conf (external, intrinsic);
473 conf (entry, intrinsic);
475 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
476 conf (external, subroutine);
478 if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
479 "Fortran 2003: Procedure pointer at %C") == FAILURE)
482 conf (allocatable, pointer);
483 conf_std (allocatable, dummy, GFC_STD_F2003);
484 conf_std (allocatable, function, GFC_STD_F2003);
485 conf_std (allocatable, result, GFC_STD_F2003);
486 conf (elemental, recursive);
488 conf (in_common, dummy);
489 conf (in_common, allocatable);
490 conf (in_common, codimension);
491 conf (in_common, result);
493 conf (in_equivalence, use_assoc);
494 conf (in_equivalence, codimension);
495 conf (in_equivalence, dummy);
496 conf (in_equivalence, target);
497 conf (in_equivalence, pointer);
498 conf (in_equivalence, function);
499 conf (in_equivalence, result);
500 conf (in_equivalence, entry);
501 conf (in_equivalence, allocatable);
502 conf (in_equivalence, threadprivate);
504 conf (dummy, result);
505 conf (entry, result);
506 conf (generic, result);
508 conf (function, subroutine);
510 if (!function && !subroutine)
511 conf (is_bind_c, dummy);
513 conf (is_bind_c, cray_pointer);
514 conf (is_bind_c, cray_pointee);
515 conf (is_bind_c, codimension);
516 conf (is_bind_c, allocatable);
517 conf (is_bind_c, elemental);
519 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
520 Parameter conflict caught below. Also, value cannot be specified
521 for a dummy procedure. */
523 /* Cray pointer/pointee conflicts. */
524 conf (cray_pointer, cray_pointee);
525 conf (cray_pointer, dimension);
526 conf (cray_pointer, codimension);
527 conf (cray_pointer, contiguous);
528 conf (cray_pointer, pointer);
529 conf (cray_pointer, target);
530 conf (cray_pointer, allocatable);
531 conf (cray_pointer, external);
532 conf (cray_pointer, intrinsic);
533 conf (cray_pointer, in_namelist);
534 conf (cray_pointer, function);
535 conf (cray_pointer, subroutine);
536 conf (cray_pointer, entry);
538 conf (cray_pointee, allocatable);
539 conf (cray_pointer, contiguous);
540 conf (cray_pointer, codimension);
541 conf (cray_pointee, intent);
542 conf (cray_pointee, optional);
543 conf (cray_pointee, dummy);
544 conf (cray_pointee, target);
545 conf (cray_pointee, intrinsic);
546 conf (cray_pointee, pointer);
547 conf (cray_pointee, entry);
548 conf (cray_pointee, in_common);
549 conf (cray_pointee, in_equivalence);
550 conf (cray_pointee, threadprivate);
553 conf (data, function);
555 conf (data, allocatable);
557 conf (value, pointer)
558 conf (value, allocatable)
559 conf (value, subroutine)
560 conf (value, function)
561 conf (value, volatile_)
562 conf (value, dimension)
563 conf (value, codimension)
564 conf (value, external)
566 conf (codimension, result)
569 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
572 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
576 conf (is_protected, intrinsic)
577 conf (is_protected, in_common)
579 conf (asynchronous, intrinsic)
580 conf (asynchronous, external)
582 conf (volatile_, intrinsic)
583 conf (volatile_, external)
585 if (attr->volatile_ && attr->intent == INTENT_IN)
592 conf (procedure, allocatable)
593 conf (procedure, dimension)
594 conf (procedure, codimension)
595 conf (procedure, intrinsic)
596 conf (procedure, target)
597 conf (procedure, value)
598 conf (procedure, volatile_)
599 conf (procedure, asynchronous)
600 conf (procedure, entry)
602 a1 = gfc_code2string (flavors, attr->flavor);
604 if (attr->in_namelist
605 && attr->flavor != FL_VARIABLE
606 && attr->flavor != FL_PROCEDURE
607 && attr->flavor != FL_UNKNOWN)
613 switch (attr->flavor)
623 conf2 (asynchronous);
626 conf2 (is_protected);
636 conf2 (threadprivate);
638 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
640 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
641 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
648 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
662 /* Conflicts with INTENT, SAVE and RESULT will be checked
663 at resolution stage, see "resolve_fl_procedure". */
665 if (attr->subroutine)
671 conf2 (asynchronous);
676 if (!attr->proc_pointer)
677 conf2 (threadprivate);
680 if (!attr->proc_pointer)
685 case PROC_ST_FUNCTION:
696 conf2 (threadprivate);
716 conf2 (threadprivate);
719 if (attr->intent != INTENT_UNKNOWN)
736 conf2 (is_protected);
742 conf2 (asynchronous);
743 conf2 (threadprivate);
758 gfc_error ("%s attribute conflicts with %s attribute at %L",
761 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
762 a1, a2, name, where);
769 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
770 "with %s attribute at %L", a1, a2,
775 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
776 "with %s attribute in '%s' at %L",
777 a1, a2, name, where);
786 /* Mark a symbol as referenced. */
789 gfc_set_sym_referenced (gfc_symbol *sym)
792 if (sym->attr.referenced)
795 sym->attr.referenced = 1;
797 /* Remember which order dummy variables are accessed in. */
799 sym->dummy_order = next_dummy_order++;
803 /* Common subroutine called by attribute changing subroutines in order
804 to prevent them from changing a symbol that has been
805 use-associated. Returns zero if it is OK to change the symbol,
809 check_used (symbol_attribute *attr, const char *name, locus *where)
812 if (attr->use_assoc == 0)
816 where = &gfc_current_locus;
819 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
822 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
829 /* Generate an error because of a duplicate attribute. */
832 duplicate_attr (const char *attr, locus *where)
836 where = &gfc_current_locus;
838 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
843 gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
844 locus *where ATTRIBUTE_UNUSED)
846 attr->ext_attr |= 1 << ext_attr;
851 /* Called from decl.c (attr_decl1) to check attributes, when declared
855 gfc_add_attribute (symbol_attribute *attr, locus *where)
857 if (check_used (attr, NULL, where))
860 return check_conflict (attr, NULL, where);
865 gfc_add_allocatable (symbol_attribute *attr, locus *where)
868 if (check_used (attr, NULL, where))
871 if (attr->allocatable)
873 duplicate_attr ("ALLOCATABLE", where);
877 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
878 && gfc_find_state (COMP_INTERFACE) == FAILURE)
880 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
885 attr->allocatable = 1;
886 return check_conflict (attr, NULL, where);
891 gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
894 if (check_used (attr, name, where))
897 if (attr->codimension)
899 duplicate_attr ("CODIMENSION", where);
903 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
904 && gfc_find_state (COMP_INTERFACE) == FAILURE)
906 gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
907 "at %L", name, where);
911 attr->codimension = 1;
912 return check_conflict (attr, name, where);
917 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
920 if (check_used (attr, name, where))
925 duplicate_attr ("DIMENSION", where);
929 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
930 && gfc_find_state (COMP_INTERFACE) == FAILURE)
932 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
933 "at %L", name, where);
938 return check_conflict (attr, name, where);
943 gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
946 if (check_used (attr, name, where))
949 attr->contiguous = 1;
950 return check_conflict (attr, name, where);
955 gfc_add_external (symbol_attribute *attr, locus *where)
958 if (check_used (attr, NULL, where))
963 duplicate_attr ("EXTERNAL", where);
967 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
970 attr->proc_pointer = 1;
975 return check_conflict (attr, NULL, where);
980 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
983 if (check_used (attr, NULL, where))
988 duplicate_attr ("INTRINSIC", where);
994 return check_conflict (attr, NULL, where);
999 gfc_add_optional (symbol_attribute *attr, locus *where)
1002 if (check_used (attr, NULL, where))
1007 duplicate_attr ("OPTIONAL", where);
1012 return check_conflict (attr, NULL, where);
1017 gfc_add_pointer (symbol_attribute *attr, locus *where)
1020 if (check_used (attr, NULL, where))
1023 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
1024 && gfc_find_state (COMP_INTERFACE) == FAILURE))
1026 duplicate_attr ("POINTER", where);
1030 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
1031 || (attr->if_source == IFSRC_IFBODY
1032 && gfc_find_state (COMP_INTERFACE) == FAILURE))
1033 attr->proc_pointer = 1;
1037 return check_conflict (attr, NULL, where);
1042 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
1045 if (check_used (attr, NULL, where))
1048 attr->cray_pointer = 1;
1049 return check_conflict (attr, NULL, where);
1054 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
1057 if (check_used (attr, NULL, where))
1060 if (attr->cray_pointee)
1062 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1063 " statements", where);
1067 attr->cray_pointee = 1;
1068 return check_conflict (attr, NULL, where);
1073 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1075 if (check_used (attr, name, where))
1078 if (attr->is_protected)
1080 if (gfc_notify_std (GFC_STD_LEGACY,
1081 "Duplicate PROTECTED attribute specified at %L",
1087 attr->is_protected = 1;
1088 return check_conflict (attr, name, where);
1093 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1096 if (check_used (attr, name, where))
1100 return check_conflict (attr, name, where);
1105 gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
1109 if (check_used (attr, name, where))
1112 if (s == SAVE_EXPLICIT && gfc_pure (NULL))
1115 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1120 if (s == SAVE_EXPLICIT && gfc_implicit_pure (NULL))
1121 gfc_current_ns->proc_name->attr.implicit_pure = 0;
1123 if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT)
1125 if (gfc_notify_std (GFC_STD_LEGACY,
1126 "Duplicate SAVE attribute specified at %L",
1133 return check_conflict (attr, name, where);
1138 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1141 if (check_used (attr, name, where))
1146 if (gfc_notify_std (GFC_STD_LEGACY,
1147 "Duplicate VALUE attribute specified at %L",
1154 return check_conflict (attr, name, where);
1159 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1161 /* No check_used needed as 11.2.1 of the F2003 standard allows
1162 that the local identifier made accessible by a use statement can be
1163 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1165 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1166 if (gfc_notify_std (GFC_STD_LEGACY,
1167 "Duplicate VOLATILE attribute specified at %L", where)
1171 attr->volatile_ = 1;
1172 attr->volatile_ns = gfc_current_ns;
1173 return check_conflict (attr, name, where);
1178 gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1180 /* No check_used needed as 11.2.1 of the F2003 standard allows
1181 that the local identifier made accessible by a use statement can be
1182 given a ASYNCHRONOUS attribute. */
1184 if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
1185 if (gfc_notify_std (GFC_STD_LEGACY,
1186 "Duplicate ASYNCHRONOUS attribute specified at %L",
1190 attr->asynchronous = 1;
1191 attr->asynchronous_ns = gfc_current_ns;
1192 return check_conflict (attr, name, where);
1197 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1200 if (check_used (attr, name, where))
1203 if (attr->threadprivate)
1205 duplicate_attr ("THREADPRIVATE", where);
1209 attr->threadprivate = 1;
1210 return check_conflict (attr, name, where);
1215 gfc_add_target (symbol_attribute *attr, locus *where)
1218 if (check_used (attr, NULL, where))
1223 duplicate_attr ("TARGET", where);
1228 return check_conflict (attr, NULL, where);
1233 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1236 if (check_used (attr, name, where))
1239 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1241 return check_conflict (attr, name, where);
1246 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1249 if (check_used (attr, name, where))
1252 /* Duplicate attribute already checked for. */
1253 attr->in_common = 1;
1254 return check_conflict (attr, name, where);
1259 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1262 /* Duplicate attribute already checked for. */
1263 attr->in_equivalence = 1;
1264 if (check_conflict (attr, name, where) == FAILURE)
1267 if (attr->flavor == FL_VARIABLE)
1270 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1275 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1278 if (check_used (attr, name, where))
1282 return check_conflict (attr, name, where);
1287 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1290 attr->in_namelist = 1;
1291 return check_conflict (attr, name, where);
1296 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1299 if (check_used (attr, name, where))
1303 return check_conflict (attr, name, where);
1308 gfc_add_elemental (symbol_attribute *attr, locus *where)
1311 if (check_used (attr, NULL, where))
1314 if (attr->elemental)
1316 duplicate_attr ("ELEMENTAL", where);
1320 attr->elemental = 1;
1321 return check_conflict (attr, NULL, where);
1326 gfc_add_pure (symbol_attribute *attr, locus *where)
1329 if (check_used (attr, NULL, where))
1334 duplicate_attr ("PURE", where);
1339 return check_conflict (attr, NULL, where);
1344 gfc_add_recursive (symbol_attribute *attr, locus *where)
1347 if (check_used (attr, NULL, where))
1350 if (attr->recursive)
1352 duplicate_attr ("RECURSIVE", where);
1356 attr->recursive = 1;
1357 return check_conflict (attr, NULL, where);
1362 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1365 if (check_used (attr, name, where))
1370 duplicate_attr ("ENTRY", where);
1375 return check_conflict (attr, name, where);
1380 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1383 if (attr->flavor != FL_PROCEDURE
1384 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1388 return check_conflict (attr, name, where);
1393 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1396 if (attr->flavor != FL_PROCEDURE
1397 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1400 attr->subroutine = 1;
1401 return check_conflict (attr, name, where);
1406 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1409 if (attr->flavor != FL_PROCEDURE
1410 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1414 return check_conflict (attr, name, where);
1419 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1422 if (check_used (attr, NULL, where))
1425 if (attr->flavor != FL_PROCEDURE
1426 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1429 if (attr->procedure)
1431 duplicate_attr ("PROCEDURE", where);
1435 attr->procedure = 1;
1437 return check_conflict (attr, NULL, where);
1442 gfc_add_abstract (symbol_attribute* attr, locus* where)
1446 duplicate_attr ("ABSTRACT", where);
1455 /* Flavors are special because some flavors are not what Fortran
1456 considers attributes and can be reaffirmed multiple times. */
1459 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1463 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1464 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1465 || f == FL_NAMELIST) && check_used (attr, name, where))
1468 if (attr->flavor == f && f == FL_VARIABLE)
1471 if (attr->flavor != FL_UNKNOWN)
1474 where = &gfc_current_locus;
1477 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1478 gfc_code2string (flavors, attr->flavor), name,
1479 gfc_code2string (flavors, f), where);
1481 gfc_error ("%s attribute conflicts with %s attribute at %L",
1482 gfc_code2string (flavors, attr->flavor),
1483 gfc_code2string (flavors, f), where);
1490 return check_conflict (attr, name, where);
1495 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1496 const char *name, locus *where)
1499 if (check_used (attr, name, where))
1502 if (attr->flavor != FL_PROCEDURE
1503 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1507 where = &gfc_current_locus;
1509 if (attr->proc != PROC_UNKNOWN)
1511 gfc_error ("%s procedure at %L is already declared as %s procedure",
1512 gfc_code2string (procedures, t), where,
1513 gfc_code2string (procedures, attr->proc));
1520 /* Statement functions are always scalar and functions. */
1521 if (t == PROC_ST_FUNCTION
1522 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1523 || attr->dimension))
1526 return check_conflict (attr, name, where);
1531 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1534 if (check_used (attr, NULL, where))
1537 if (attr->intent == INTENT_UNKNOWN)
1539 attr->intent = intent;
1540 return check_conflict (attr, NULL, where);
1544 where = &gfc_current_locus;
1546 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1547 gfc_intent_string (attr->intent),
1548 gfc_intent_string (intent), where);
1554 /* No checks for use-association in public and private statements. */
1557 gfc_add_access (symbol_attribute *attr, gfc_access access,
1558 const char *name, locus *where)
1561 if (attr->access == ACCESS_UNKNOWN
1562 || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1564 attr->access = access;
1565 return check_conflict (attr, name, where);
1569 where = &gfc_current_locus;
1570 gfc_error ("ACCESS specification at %L was already specified", where);
1576 /* Set the is_bind_c field for the given symbol_attribute. */
1579 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1580 int is_proc_lang_bind_spec)
1583 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1584 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1585 "variables or common blocks", where);
1586 else if (attr->is_bind_c)
1587 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1589 attr->is_bind_c = 1;
1592 where = &gfc_current_locus;
1594 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1598 return check_conflict (attr, name, where);
1602 /* Set the extension field for the given symbol_attribute. */
1605 gfc_add_extension (symbol_attribute *attr, locus *where)
1608 where = &gfc_current_locus;
1610 if (attr->extension)
1611 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1613 attr->extension = 1;
1615 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
1624 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1625 gfc_formal_arglist * formal, locus *where)
1628 if (check_used (&sym->attr, sym->name, where))
1632 where = &gfc_current_locus;
1634 if (sym->attr.if_source != IFSRC_UNKNOWN
1635 && sym->attr.if_source != IFSRC_DECL)
1637 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1642 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1644 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1645 "body", sym->name, where);
1649 sym->formal = formal;
1650 sym->attr.if_source = source;
1656 /* Add a type to a symbol. */
1659 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1665 where = &gfc_current_locus;
1668 type = sym->result->ts.type;
1670 type = sym->ts.type;
1672 if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
1673 type = sym->ns->proc_name->ts.type;
1675 if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
1677 if (sym->attr.use_assoc)
1678 gfc_error ("Symbol '%s' at %L conflicts with symbol from module '%s', "
1679 "use-associated at %L", sym->name, where, sym->module,
1682 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1683 where, gfc_basic_typename (type));
1687 if (sym->attr.procedure && sym->ts.interface)
1689 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1690 sym->name, where, gfc_basic_typename (ts->type));
1694 flavor = sym->attr.flavor;
1696 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1697 || flavor == FL_LABEL
1698 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1699 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1701 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1710 /* Clears all attributes. */
1713 gfc_clear_attr (symbol_attribute *attr)
1715 memset (attr, 0, sizeof (symbol_attribute));
1719 /* Check for missing attributes in the new symbol. Currently does
1720 nothing, but it's not clear that it is unnecessary yet. */
1723 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1724 locus *where ATTRIBUTE_UNUSED)
1731 /* Copy an attribute to a symbol attribute, bit by bit. Some
1732 attributes have a lot of side-effects but cannot be present given
1733 where we are called from, so we ignore some bits. */
1736 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1738 int is_proc_lang_bind_spec;
1740 /* In line with the other attributes, we only add bits but do not remove
1741 them; cf. also PR 41034. */
1742 dest->ext_attr |= src->ext_attr;
1744 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1747 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1749 if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE)
1751 if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE)
1753 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1755 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1757 if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1759 if (src->save && gfc_add_save (dest, src->save, NULL, where) == FAILURE)
1761 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1763 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1765 if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
1767 if (src->threadprivate
1768 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1770 if (src->target && gfc_add_target (dest, where) == FAILURE)
1772 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1774 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1779 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1782 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1785 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1787 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1789 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1792 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1794 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1796 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1798 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1801 if (src->flavor != FL_UNKNOWN
1802 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1805 if (src->intent != INTENT_UNKNOWN
1806 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1809 if (src->access != ACCESS_UNKNOWN
1810 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1813 if (gfc_missing_attr (dest, where) == FAILURE)
1816 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1818 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1821 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1823 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1827 if (src->is_c_interop)
1828 dest->is_c_interop = 1;
1832 if (src->external && gfc_add_external (dest, where) == FAILURE)
1834 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1836 if (src->proc_pointer)
1837 dest->proc_pointer = 1;
1846 /************** Component name management ************/
1848 /* Component names of a derived type form their own little namespaces
1849 that are separate from all other spaces. The space is composed of
1850 a singly linked list of gfc_component structures whose head is
1851 located in the parent symbol. */
1854 /* Add a component name to a symbol. The call fails if the name is
1855 already present. On success, the component pointer is modified to
1856 point to the additional component structure. */
1859 gfc_add_component (gfc_symbol *sym, const char *name,
1860 gfc_component **component)
1862 gfc_component *p, *tail;
1866 for (p = sym->components; p; p = p->next)
1868 if (strcmp (p->name, name) == 0)
1870 gfc_error ("Component '%s' at %C already declared at %L",
1878 if (sym->attr.extension
1879 && gfc_find_component (sym->components->ts.u.derived, name, true, true))
1881 gfc_error ("Component '%s' at %C already in the parent type "
1882 "at %L", name, &sym->components->ts.u.derived->declared_at);
1886 /* Allocate a new component. */
1887 p = gfc_get_component ();
1890 sym->components = p;
1894 p->name = gfc_get_string (name);
1895 p->loc = gfc_current_locus;
1896 p->ts.type = BT_UNKNOWN;
1903 /* Recursive function to switch derived types of all symbol in a
1907 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1915 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
1916 sym->ts.u.derived = to;
1918 switch_types (st->left, from, to);
1919 switch_types (st->right, from, to);
1923 /* This subroutine is called when a derived type is used in order to
1924 make the final determination about which version to use. The
1925 standard requires that a type be defined before it is 'used', but
1926 such types can appear in IMPLICIT statements before the actual
1927 definition. 'Using' in this context means declaring a variable to
1928 be that type or using the type constructor.
1930 If a type is used and the components haven't been defined, then we
1931 have to have a derived type in a parent unit. We find the node in
1932 the other namespace and point the symtree node in this namespace to
1933 that node. Further reference to this name point to the correct
1934 node. If we can't find the node in a parent namespace, then we have
1937 This subroutine takes a pointer to a symbol node and returns a
1938 pointer to the translated node or NULL for an error. Usually there
1939 is no translation and we return the node we were passed. */
1942 gfc_use_derived (gfc_symbol *sym)
1952 if (sym->components != NULL || sym->attr.zero_comp)
1953 return sym; /* Already defined. */
1955 if (sym->ns->parent == NULL)
1958 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1960 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1964 if (s == NULL || s->attr.flavor != FL_DERIVED)
1967 /* Get rid of symbol sym, translating all references to s. */
1968 for (i = 0; i < GFC_LETTERS; i++)
1970 t = &sym->ns->default_type[i];
1971 if (t->u.derived == sym)
1975 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1980 /* Unlink from list of modified symbols. */
1981 gfc_commit_symbol (sym);
1983 switch_types (sym->ns->sym_root, sym, s);
1985 /* TODO: Also have to replace sym -> s in other lists like
1986 namelists, common lists and interface lists. */
1987 gfc_free_symbol (sym);
1992 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1998 /* Given a derived type node and a component name, try to locate the
1999 component structure. Returns the NULL pointer if the component is
2000 not found or the components are private. If noaccess is set, no access
2004 gfc_find_component (gfc_symbol *sym, const char *name,
2005 bool noaccess, bool silent)
2009 if (name == NULL || sym == NULL)
2012 sym = gfc_use_derived (sym);
2017 for (p = sym->components; p; p = p->next)
2018 if (strcmp (p->name, name) == 0)
2022 && sym->attr.extension
2023 && sym->components->ts.type == BT_DERIVED)
2025 p = gfc_find_component (sym->components->ts.u.derived, name,
2027 /* Do not overwrite the error. */
2032 if (p == NULL && !silent)
2033 gfc_error ("'%s' at %C is not a member of the '%s' structure",
2036 else if (sym->attr.use_assoc && !noaccess)
2038 bool is_parent_comp = sym->attr.extension && (p == sym->components);
2039 if (p->attr.access == ACCESS_PRIVATE ||
2040 (p->attr.access != ACCESS_PUBLIC
2041 && sym->component_access == ACCESS_PRIVATE
2042 && !is_parent_comp))
2045 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2055 /* Given a symbol, free all of the component structures and everything
2059 free_components (gfc_component *p)
2067 gfc_free_array_spec (p->as);
2068 gfc_free_expr (p->initializer);
2070 gfc_free_formal_arglist (p->formal);
2071 gfc_free_namespace (p->formal_ns);
2078 /******************** Statement label management ********************/
2080 /* Comparison function for statement labels, used for managing the
2084 compare_st_labels (void *a1, void *b1)
2086 int a = ((gfc_st_label *) a1)->value;
2087 int b = ((gfc_st_label *) b1)->value;
2093 /* Free a single gfc_st_label structure, making sure the tree is not
2094 messed up. This function is called only when some parse error
2098 gfc_free_st_label (gfc_st_label *label)
2104 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
2106 if (label->format != NULL)
2107 gfc_free_expr (label->format);
2113 /* Free a whole tree of gfc_st_label structures. */
2116 free_st_labels (gfc_st_label *label)
2122 free_st_labels (label->left);
2123 free_st_labels (label->right);
2125 if (label->format != NULL)
2126 gfc_free_expr (label->format);
2131 /* Given a label number, search for and return a pointer to the label
2132 structure, creating it if it does not exist. */
2135 gfc_get_st_label (int labelno)
2140 if (gfc_current_state () == COMP_DERIVED)
2141 ns = gfc_current_block ()->f2k_derived;
2144 /* Find the namespace of the scoping unit:
2145 If we're in a BLOCK construct, jump to the parent namespace. */
2146 ns = gfc_current_ns;
2147 while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2151 /* First see if the label is already in this namespace. */
2155 if (lp->value == labelno)
2158 if (lp->value < labelno)
2164 lp = XCNEW (gfc_st_label);
2166 lp->value = labelno;
2167 lp->defined = ST_LABEL_UNKNOWN;
2168 lp->referenced = ST_LABEL_UNKNOWN;
2170 gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2176 /* Called when a statement with a statement label is about to be
2177 accepted. We add the label to the list of the current namespace,
2178 making sure it hasn't been defined previously and referenced
2182 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2186 labelno = lp->value;
2188 if (lp->defined != ST_LABEL_UNKNOWN)
2189 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2190 &lp->where, label_locus);
2193 lp->where = *label_locus;
2197 case ST_LABEL_FORMAT:
2198 if (lp->referenced == ST_LABEL_TARGET)
2199 gfc_error ("Label %d at %C already referenced as branch target",
2202 lp->defined = ST_LABEL_FORMAT;
2206 case ST_LABEL_TARGET:
2207 if (lp->referenced == ST_LABEL_FORMAT)
2208 gfc_error ("Label %d at %C already referenced as a format label",
2211 lp->defined = ST_LABEL_TARGET;
2216 lp->defined = ST_LABEL_BAD_TARGET;
2217 lp->referenced = ST_LABEL_BAD_TARGET;
2223 /* Reference a label. Given a label and its type, see if that
2224 reference is consistent with what is known about that label,
2225 updating the unknown state. Returns FAILURE if something goes
2229 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2231 gfc_sl_type label_type;
2238 labelno = lp->value;
2240 if (lp->defined != ST_LABEL_UNKNOWN)
2241 label_type = lp->defined;
2244 label_type = lp->referenced;
2245 lp->where = gfc_current_locus;
2248 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2250 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2255 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2256 && type == ST_LABEL_FORMAT)
2258 gfc_error ("Label %d at %C previously used as branch target", labelno);
2263 lp->referenced = type;
2271 /************** Symbol table management subroutines ****************/
2273 /* Basic details: Fortran 95 requires a potentially unlimited number
2274 of distinct namespaces when compiling a program unit. This case
2275 occurs during a compilation of internal subprograms because all of
2276 the internal subprograms must be read before we can start
2277 generating code for the host.
2279 Given the tricky nature of the Fortran grammar, we must be able to
2280 undo changes made to a symbol table if the current interpretation
2281 of a statement is found to be incorrect. Whenever a symbol is
2282 looked up, we make a copy of it and link to it. All of these
2283 symbols are kept in a singly linked list so that we can commit or
2284 undo the changes at a later time.
2286 A symtree may point to a symbol node outside of its namespace. In
2287 this case, that symbol has been used as a host associated variable
2288 at some previous time. */
2290 /* Allocate a new namespace structure. Copies the implicit types from
2291 PARENT if PARENT_TYPES is set. */
2294 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2301 ns = XCNEW (gfc_namespace);
2302 ns->sym_root = NULL;
2303 ns->uop_root = NULL;
2304 ns->tb_sym_root = NULL;
2305 ns->finalizers = NULL;
2306 ns->default_access = ACCESS_UNKNOWN;
2307 ns->parent = parent;
2309 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2311 ns->operator_access[in] = ACCESS_UNKNOWN;
2312 ns->tb_op[in] = NULL;
2315 /* Initialize default implicit types. */
2316 for (i = 'a'; i <= 'z'; i++)
2318 ns->set_flag[i - 'a'] = 0;
2319 ts = &ns->default_type[i - 'a'];
2321 if (parent_types && ns->parent != NULL)
2323 /* Copy parent settings. */
2324 *ts = ns->parent->default_type[i - 'a'];
2328 if (gfc_option.flag_implicit_none != 0)
2334 if ('i' <= i && i <= 'n')
2336 ts->type = BT_INTEGER;
2337 ts->kind = gfc_default_integer_kind;
2342 ts->kind = gfc_default_real_kind;
2352 /* Comparison function for symtree nodes. */
2355 compare_symtree (void *_st1, void *_st2)
2357 gfc_symtree *st1, *st2;
2359 st1 = (gfc_symtree *) _st1;
2360 st2 = (gfc_symtree *) _st2;
2362 return strcmp (st1->name, st2->name);
2366 /* Allocate a new symtree node and associate it with the new symbol. */
2369 gfc_new_symtree (gfc_symtree **root, const char *name)
2373 st = XCNEW (gfc_symtree);
2374 st->name = gfc_get_string (name);
2376 gfc_insert_bbt (root, st, compare_symtree);
2381 /* Delete a symbol from the tree. Does not free the symbol itself! */
2384 gfc_delete_symtree (gfc_symtree **root, const char *name)
2386 gfc_symtree st, *st0;
2388 st0 = gfc_find_symtree (*root, name);
2390 st.name = gfc_get_string (name);
2391 gfc_delete_bbt (root, &st, compare_symtree);
2397 /* Given a root symtree node and a name, try to find the symbol within
2398 the namespace. Returns NULL if the symbol is not found. */
2401 gfc_find_symtree (gfc_symtree *st, const char *name)
2407 c = strcmp (name, st->name);
2411 st = (c < 0) ? st->left : st->right;
2418 /* Return a symtree node with a name that is guaranteed to be unique
2419 within the namespace and corresponds to an illegal fortran name. */
2422 gfc_get_unique_symtree (gfc_namespace *ns)
2424 char name[GFC_MAX_SYMBOL_LEN + 1];
2425 static int serial = 0;
2427 sprintf (name, "@%d", serial++);
2428 return gfc_new_symtree (&ns->sym_root, name);
2432 /* Given a name find a user operator node, creating it if it doesn't
2433 exist. These are much simpler than symbols because they can't be
2434 ambiguous with one another. */
2437 gfc_get_uop (const char *name)
2442 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2446 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2448 uop = st->n.uop = XCNEW (gfc_user_op);
2449 uop->name = gfc_get_string (name);
2450 uop->access = ACCESS_UNKNOWN;
2451 uop->ns = gfc_current_ns;
2457 /* Given a name find the user operator node. Returns NULL if it does
2461 gfc_find_uop (const char *name, gfc_namespace *ns)
2466 ns = gfc_current_ns;
2468 st = gfc_find_symtree (ns->uop_root, name);
2469 return (st == NULL) ? NULL : st->n.uop;
2473 /* Remove a gfc_symbol structure and everything it points to. */
2476 gfc_free_symbol (gfc_symbol *sym)
2482 gfc_free_array_spec (sym->as);
2484 free_components (sym->components);
2486 gfc_free_expr (sym->value);
2488 gfc_free_namelist (sym->namelist);
2490 gfc_free_namespace (sym->formal_ns);
2492 if (!sym->attr.generic_copy)
2493 gfc_free_interface (sym->generic);
2495 gfc_free_formal_arglist (sym->formal);
2497 gfc_free_namespace (sym->f2k_derived);
2503 /* Decrease the reference counter and free memory when we reach zero. */
2506 gfc_release_symbol (gfc_symbol *sym)
2511 if (sym->formal_ns != NULL && sym->refs == 2)
2513 /* As formal_ns contains a reference to sym, delete formal_ns just
2514 before the deletion of sym. */
2515 gfc_namespace *ns = sym->formal_ns;
2516 sym->formal_ns = NULL;
2517 gfc_free_namespace (ns);
2524 gcc_assert (sym->refs == 0);
2525 gfc_free_symbol (sym);
2529 /* Allocate and initialize a new symbol node. */
2532 gfc_new_symbol (const char *name, gfc_namespace *ns)
2536 p = XCNEW (gfc_symbol);
2538 gfc_clear_ts (&p->ts);
2539 gfc_clear_attr (&p->attr);
2542 p->declared_at = gfc_current_locus;
2544 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2545 gfc_internal_error ("new_symbol(): Symbol name too long");
2547 p->name = gfc_get_string (name);
2549 /* Make sure flags for symbol being C bound are clear initially. */
2550 p->attr.is_bind_c = 0;
2551 p->attr.is_iso_c = 0;
2552 /* Make sure the binding label field has a Nul char to start. */
2553 p->binding_label[0] = '\0';
2555 /* Clear the ptrs we may need. */
2556 p->common_block = NULL;
2557 p->f2k_derived = NULL;
2564 /* Generate an error if a symbol is ambiguous. */
2567 ambiguous_symbol (const char *name, gfc_symtree *st)
2570 if (st->n.sym->module)
2571 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2572 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2574 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2575 "from current program unit", name, st->n.sym->name);
2579 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2580 selector on the stack. If yes, replace it by the corresponding temporary. */
2583 select_type_insert_tmp (gfc_symtree **st)
2585 gfc_select_type_stack *stack = select_type_stack;
2586 for (; stack; stack = stack->prev)
2587 if ((*st)->n.sym == stack->selector && stack->tmp)
2592 /* Look for a symtree in the current procedure -- that is, go up to
2593 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
2596 gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
2600 gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
2604 if (!ns->construct_entities)
2613 /* Search for a symtree starting in the current namespace, resorting to
2614 any parent namespaces if requested by a nonzero parent_flag.
2615 Returns nonzero if the name is ambiguous. */
2618 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2619 gfc_symtree **result)
2624 ns = gfc_current_ns;
2628 st = gfc_find_symtree (ns->sym_root, name);
2631 select_type_insert_tmp (&st);
2634 /* Ambiguous generic interfaces are permitted, as long
2635 as the specific interfaces are different. */
2636 if (st->ambiguous && !st->n.sym->attr.generic)
2638 ambiguous_symbol (name, st);
2657 /* Same, but returns the symbol instead. */
2660 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2661 gfc_symbol **result)
2666 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2671 *result = st->n.sym;
2677 /* Save symbol with the information necessary to back it out. */
2680 save_symbol_data (gfc_symbol *sym)
2683 if (sym->gfc_new || sym->old_symbol != NULL)
2686 sym->old_symbol = XCNEW (gfc_symbol);
2687 *(sym->old_symbol) = *sym;
2689 sym->tlink = changed_syms;
2694 /* Given a name, find a symbol, or create it if it does not exist yet
2695 in the current namespace. If the symbol is found we make sure that
2698 The integer return code indicates
2700 1 The symbol name was ambiguous
2701 2 The name meant to be established was already host associated.
2703 So if the return value is nonzero, then an error was issued. */
2706 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2707 bool allow_subroutine)
2712 /* This doesn't usually happen during resolution. */
2714 ns = gfc_current_ns;
2716 /* Try to find the symbol in ns. */
2717 st = gfc_find_symtree (ns->sym_root, name);
2721 /* If not there, create a new symbol. */
2722 p = gfc_new_symbol (name, ns);
2724 /* Add to the list of tentative symbols. */
2725 p->old_symbol = NULL;
2726 p->tlink = changed_syms;
2731 st = gfc_new_symtree (&ns->sym_root, name);
2738 /* Make sure the existing symbol is OK. Ambiguous
2739 generic interfaces are permitted, as long as the
2740 specific interfaces are different. */
2741 if (st->ambiguous && !st->n.sym->attr.generic)
2743 ambiguous_symbol (name, st);
2748 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2749 && !(allow_subroutine && p->attr.subroutine)
2750 && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2751 && (ns->has_import_set || p->attr.imported)))
2753 /* Symbol is from another namespace. */
2754 gfc_error ("Symbol '%s' at %C has already been host associated",
2761 /* Copy in case this symbol is changed. */
2762 save_symbol_data (p);
2771 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2776 i = gfc_get_sym_tree (name, ns, &st, false);
2781 *result = st->n.sym;
2788 /* Subroutine that searches for a symbol, creating it if it doesn't
2789 exist, but tries to host-associate the symbol if possible. */
2792 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2797 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2801 save_symbol_data (st->n.sym);
2806 if (gfc_current_ns->parent != NULL)
2808 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2819 return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2824 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2829 i = gfc_get_ha_sym_tree (name, &st);
2832 *result = st->n.sym;
2839 /* Undoes all the changes made to symbols in the current statement.
2840 This subroutine is made simpler due to the fact that attributes are
2841 never removed once added. */
2844 gfc_undo_symbols (void)
2846 gfc_symbol *p, *q, *old;
2847 tentative_tbp *tbp, *tbq;
2849 for (p = changed_syms; p; p = q)
2855 /* Symbol was new. */
2856 if (p->attr.in_common && p->common_block && p->common_block->head)
2858 /* If the symbol was added to any common block, it
2859 needs to be removed to stop the resolver looking
2860 for a (possibly) dead symbol. */
2862 if (p->common_block->head == p)
2863 p->common_block->head = p->common_next;
2866 gfc_symbol *cparent, *csym;
2868 cparent = p->common_block->head;
2869 csym = cparent->common_next;
2874 csym = csym->common_next;
2877 gcc_assert(cparent->common_next == p);
2879 cparent->common_next = csym->common_next;
2883 gfc_delete_symtree (&p->ns->sym_root, p->name);
2885 gfc_release_symbol (p);
2889 /* Restore previous state of symbol. Just copy simple stuff. */
2891 old = p->old_symbol;
2893 p->ts.type = old->ts.type;
2894 p->ts.kind = old->ts.kind;
2896 p->attr = old->attr;
2898 if (p->value != old->value)
2900 gfc_free_expr (old->value);
2904 if (p->as != old->as)
2907 gfc_free_array_spec (p->as);
2911 p->generic = old->generic;
2912 p->component_access = old->component_access;
2914 if (p->namelist != NULL && old->namelist == NULL)
2916 gfc_free_namelist (p->namelist);
2921 if (p->namelist_tail != old->namelist_tail)
2923 gfc_free_namelist (old->namelist_tail);
2924 old->namelist_tail->next = NULL;
2928 p->namelist_tail = old->namelist_tail;
2930 if (p->formal != old->formal)
2932 gfc_free_formal_arglist (p->formal);
2933 p->formal = old->formal;
2936 free (p->old_symbol);
2937 p->old_symbol = NULL;
2941 changed_syms = NULL;
2943 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2946 /* Procedure is already marked `error' by default. */
2949 tentative_tbp_list = NULL;
2953 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2954 components of old_symbol that might need deallocation are the "allocatables"
2955 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2956 namelist_tail. In case these differ between old_symbol and sym, it's just
2957 because sym->namelist has gotten a few more items. */
2960 free_old_symbol (gfc_symbol *sym)
2963 if (sym->old_symbol == NULL)
2966 if (sym->old_symbol->as != sym->as)
2967 gfc_free_array_spec (sym->old_symbol->as);
2969 if (sym->old_symbol->value != sym->value)
2970 gfc_free_expr (sym->old_symbol->value);
2972 if (sym->old_symbol->formal != sym->formal)
2973 gfc_free_formal_arglist (sym->old_symbol->formal);
2975 free (sym->old_symbol);
2976 sym->old_symbol = NULL;
2980 /* Makes the changes made in the current statement permanent-- gets
2981 rid of undo information. */
2984 gfc_commit_symbols (void)
2987 tentative_tbp *tbp, *tbq;
2989 for (p = changed_syms; p; p = q)
2995 free_old_symbol (p);
2997 changed_syms = NULL;
2999 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
3002 tbp->proc->error = 0;
3005 tentative_tbp_list = NULL;
3009 /* Makes the changes made in one symbol permanent -- gets rid of undo
3013 gfc_commit_symbol (gfc_symbol *sym)
3017 if (changed_syms == sym)
3018 changed_syms = sym->tlink;
3021 for (p = changed_syms; p; p = p->tlink)
3022 if (p->tlink == sym)
3024 p->tlink = sym->tlink;
3033 free_old_symbol (sym);
3037 /* Recursively free trees containing type-bound procedures. */
3040 free_tb_tree (gfc_symtree *t)
3045 free_tb_tree (t->left);
3046 free_tb_tree (t->right);
3048 /* TODO: Free type-bound procedure structs themselves; probably needs some
3049 sort of ref-counting mechanism. */
3055 /* Recursive function that deletes an entire tree and all the common
3056 head structures it points to. */
3059 free_common_tree (gfc_symtree * common_tree)
3061 if (common_tree == NULL)
3064 free_common_tree (common_tree->left);
3065 free_common_tree (common_tree->right);
3071 /* Recursive function that deletes an entire tree and all the user
3072 operator nodes that it contains. */
3075 free_uop_tree (gfc_symtree *uop_tree)
3077 if (uop_tree == NULL)
3080 free_uop_tree (uop_tree->left);
3081 free_uop_tree (uop_tree->right);
3083 gfc_free_interface (uop_tree->n.uop->op);
3084 free (uop_tree->n.uop);
3089 /* Recursive function that deletes an entire tree and all the symbols
3090 that it contains. */
3093 free_sym_tree (gfc_symtree *sym_tree)
3095 if (sym_tree == NULL)
3098 free_sym_tree (sym_tree->left);
3099 free_sym_tree (sym_tree->right);
3101 gfc_release_symbol (sym_tree->n.sym);
3106 /* Free the derived type list. */
3109 gfc_free_dt_list (void)
3111 gfc_dt_list *dt, *n;
3113 for (dt = gfc_derived_types; dt; dt = n)
3119 gfc_derived_types = NULL;
3123 /* Free the gfc_equiv_info's. */
3126 gfc_free_equiv_infos (gfc_equiv_info *s)
3130 gfc_free_equiv_infos (s->next);
3135 /* Free the gfc_equiv_lists. */
3138 gfc_free_equiv_lists (gfc_equiv_list *l)
3142 gfc_free_equiv_lists (l->next);
3143 gfc_free_equiv_infos (l->equiv);
3148 /* Free a finalizer procedure list. */
3151 gfc_free_finalizer (gfc_finalizer* el)
3155 gfc_release_symbol (el->proc_sym);
3161 gfc_free_finalizer_list (gfc_finalizer* list)
3165 gfc_finalizer* current = list;
3167 gfc_free_finalizer (current);
3172 /* Create a new gfc_charlen structure and add it to a namespace.
3173 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3176 gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3179 cl = gfc_get_charlen ();
3184 /* Put into namespace, but don't allow reject_statement
3185 to free it if old_cl is given. */
3186 gfc_charlen **prev = &ns->cl_list;
3187 cl->next = ns->old_cl_list;
3188 while (*prev != ns->old_cl_list)
3189 prev = &(*prev)->next;
3191 ns->old_cl_list = cl;
3192 cl->length = gfc_copy_expr (old_cl->length);
3193 cl->length_from_typespec = old_cl->length_from_typespec;
3194 cl->backend_decl = old_cl->backend_decl;
3195 cl->passed_length = old_cl->passed_length;
3196 cl->resolved = old_cl->resolved;
3200 /* Put into namespace. */
3201 cl->next = ns->cl_list;
3209 /* Free the charlen list from cl to end (end is not freed).
3210 Free the whole list if end is NULL. */
3213 gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3217 for (; cl != end; cl = cl2)
3222 gfc_free_expr (cl->length);
3228 /* Free entry list structs. */
3231 free_entry_list (gfc_entry_list *el)
3233 gfc_entry_list *next;
3240 free_entry_list (next);
3244 /* Free a namespace structure and everything below it. Interface
3245 lists associated with intrinsic operators are not freed. These are
3246 taken care of when a specific name is freed. */
3249 gfc_free_namespace (gfc_namespace *ns)
3251 gfc_namespace *p, *q;
3260 gcc_assert (ns->refs == 0);
3262 gfc_free_statements (ns->code);
3264 free_sym_tree (ns->sym_root);
3265 free_uop_tree (ns->uop_root);
3266 free_common_tree (ns->common_root);
3267 free_tb_tree (ns->tb_sym_root);
3268 free_tb_tree (ns->tb_uop_root);
3269 gfc_free_finalizer_list (ns->finalizers);
3270 gfc_free_charlen (ns->cl_list, NULL);
3271 free_st_labels (ns->st_labels);
3273 free_entry_list (ns->entries);
3274 gfc_free_equiv (ns->equiv);
3275 gfc_free_equiv_lists (ns->equiv_lists);
3276 gfc_free_use_stmts (ns->use_stmts);
3278 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3279 gfc_free_interface (ns->op[i]);
3281 gfc_free_data (ns->data);
3285 /* Recursively free any contained namespaces. */
3290 gfc_free_namespace (q);
3296 gfc_symbol_init_2 (void)
3299 gfc_current_ns = gfc_get_namespace (NULL, 0);
3304 gfc_symbol_done_2 (void)
3307 gfc_free_namespace (gfc_current_ns);
3308 gfc_current_ns = NULL;
3309 gfc_free_dt_list ();
3313 /* Count how many nodes a symtree has. */
3316 count_st_nodes (const gfc_symtree *st)
3322 nodes = count_st_nodes (st->left);
3324 nodes += count_st_nodes (st->right);
3330 /* Convert symtree tree into symtree vector. */
3333 fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
3338 node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
3339 st_vec[node_cntr++] = st;
3340 node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
3346 /* Traverse namespace. As the functions might modify the symtree, we store the
3347 symtree as a vector and operate on this vector. Note: We assume that
3348 sym_func or st_func never deletes nodes from the symtree - only adding is
3349 allowed. Additionally, newly added nodes are not traversed. */
3352 do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
3353 void (*sym_func) (gfc_symbol *))
3355 gfc_symtree **st_vec;
3356 unsigned nodes, i, node_cntr;
3358 gcc_assert ((st_func && !sym_func) || (!st_func && sym_func));
3359 nodes = count_st_nodes (st);
3360 st_vec = XALLOCAVEC (gfc_symtree *, nodes);
3362 fill_st_vector (st, st_vec, node_cntr);
3367 for (i = 0; i < nodes; i++)
3368 st_vec[i]->n.sym->mark = 0;
3369 for (i = 0; i < nodes; i++)
3370 if (!st_vec[i]->n.sym->mark)
3372 (*sym_func) (st_vec[i]->n.sym);
3373 st_vec[i]->n.sym->mark = 1;
3377 for (i = 0; i < nodes; i++)
3378 (*st_func) (st_vec[i]);
3382 /* Recursively traverse the symtree nodes. */
3385 gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
3387 do_traverse_symtree (st, st_func, NULL);
3391 /* Call a given function for all symbols in the namespace. We take
3392 care that each gfc_symbol node is called exactly once. */
3395 gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
3397 do_traverse_symtree (ns->sym_root, NULL, sym_func);
3401 /* Return TRUE when name is the name of an intrinsic type. */
3404 gfc_is_intrinsic_typename (const char *name)
3406 if (strcmp (name, "integer") == 0
3407 || strcmp (name, "real") == 0
3408 || strcmp (name, "character") == 0
3409 || strcmp (name, "logical") == 0
3410 || strcmp (name, "complex") == 0
3411 || strcmp (name, "doubleprecision") == 0
3412 || strcmp (name, "doublecomplex") == 0)
3419 /* Return TRUE if the symbol is an automatic variable. */
3422 gfc_is_var_automatic (gfc_symbol *sym)
3424 /* Pointer and allocatable variables are never automatic. */
3425 if (sym->attr.pointer || sym->attr.allocatable)
3427 /* Check for arrays with non-constant size. */
3428 if (sym->attr.dimension && sym->as
3429 && !gfc_is_compile_time_shape (sym->as))
3431 /* Check for non-constant length character variables. */
3432 if (sym->ts.type == BT_CHARACTER
3434 && !gfc_is_constant_expr (sym->ts.u.cl->length))
3439 /* Given a symbol, mark it as SAVEd if it is allowed. */
3442 save_symbol (gfc_symbol *sym)
3445 if (sym->attr.use_assoc)
3448 if (sym->attr.in_common
3451 || sym->attr.flavor != FL_VARIABLE)
3453 /* Automatic objects are not saved. */
3454 if (gfc_is_var_automatic (sym))
3456 gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
3460 /* Mark those symbols which can be SAVEd as such. */
3463 gfc_save_all (gfc_namespace *ns)
3465 gfc_traverse_ns (ns, save_symbol);
3469 /* Make sure that no changes to symbols are pending. */
3472 gfc_enforce_clean_symbol_state(void)
3474 gcc_assert (changed_syms == NULL);
3478 /************** Global symbol handling ************/
3481 /* Search a tree for the global symbol. */
3484 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3493 c = strcmp (name, symbol->name);
3497 symbol = (c < 0) ? symbol->left : symbol->right;
3504 /* Compare two global symbols. Used for managing the BB tree. */
3507 gsym_compare (void *_s1, void *_s2)
3509 gfc_gsymbol *s1, *s2;
3511 s1 = (gfc_gsymbol *) _s1;
3512 s2 = (gfc_gsymbol *) _s2;
3513 return strcmp (s1->name, s2->name);
3517 /* Get a global symbol, creating it if it doesn't exist. */
3520 gfc_get_gsymbol (const char *name)
3524 s = gfc_find_gsymbol (gfc_gsym_root, name);
3528 s = XCNEW (gfc_gsymbol);
3529 s->type = GSYM_UNKNOWN;
3530 s->name = gfc_get_string (name);
3532 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3539 get_iso_c_binding_dt (int sym_id)
3541 gfc_dt_list *dt_list;
3543 dt_list = gfc_derived_types;
3545 /* Loop through the derived types in the name list, searching for
3546 the desired symbol from iso_c_binding. Search the parent namespaces
3547 if necessary and requested to (parent_flag). */
3548 while (dt_list != NULL)
3550 if (dt_list->derived->from_intmod != INTMOD_NONE
3551 && dt_list->derived->intmod_sym_id == sym_id)
3552 return dt_list->derived;
3554 dt_list = dt_list->next;
3561 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3562 with C. This is necessary for any derived type that is BIND(C) and for
3563 derived types that are parameters to functions that are BIND(C). All
3564 fields of the derived type are required to be interoperable, and are tested
3565 for such. If an error occurs, the errors are reported here, allowing for
3566 multiple errors to be handled for a single derived type. */
3569 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3571 gfc_component *curr_comp = NULL;
3572 gfc_try is_c_interop = FAILURE;
3573 gfc_try retval = SUCCESS;
3575 if (derived_sym == NULL)
3576 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3577 "unexpectedly NULL");
3579 /* If we've already looked at this derived symbol, do not look at it again
3580 so we don't repeat warnings/errors. */
3581 if (derived_sym->ts.is_c_interop)
3584 /* The derived type must have the BIND attribute to be interoperable
3585 J3/04-007, Section 15.2.3. */
3586 if (derived_sym->attr.is_bind_c != 1)
3588 derived_sym->ts.is_c_interop = 0;
3589 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3590 "attribute to be C interoperable", derived_sym->name,
3591 &(derived_sym->declared_at));
3595 curr_comp = derived_sym->components;
3597 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
3598 empty struct. Section 15.2 in Fortran 2003 states: "The following
3599 subclauses define the conditions under which a Fortran entity is
3600 interoperable. If a Fortran entity is interoperable, an equivalent
3601 entity may be defined by means of C and the Fortran entity is said
3602 to be interoperable with the C entity. There does not have to be such
3603 an interoperating C entity."
3605 if (curr_comp == NULL)
3607 gfc_warning ("Derived type '%s' with BIND(C) attribute at %L is empty, "
3608 "and may be inaccessible by the C companion processor",
3609 derived_sym->name, &(derived_sym->declared_at));
3610 derived_sym->ts.is_c_interop = 1;
3611 derived_sym->attr.is_bind_c = 1;
3616 /* Initialize the derived type as being C interoperable.
3617 If we find an error in the components, this will be set false. */
3618 derived_sym->ts.is_c_interop = 1;
3620 /* Loop through the list of components to verify that the kind of
3621 each is a C interoperable type. */
3624 /* The components cannot be pointers (fortran sense).
3625 J3/04-007, Section 15.2.3, C1505. */
3626 if (curr_comp->attr.pointer != 0)
3628 gfc_error ("Component '%s' at %L cannot have the "
3629 "POINTER attribute because it is a member "
3630 "of the BIND(C) derived type '%s' at %L",
3631 curr_comp->name, &(curr_comp->loc),
3632 derived_sym->name, &(derived_sym->declared_at));
3636 if (curr_comp->attr.proc_pointer != 0)
3638 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3639 " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3640 &curr_comp->loc, derived_sym->name,
3641 &derived_sym->declared_at);
3645 /* The components cannot be allocatable.
3646 J3/04-007, Section 15.2.3, C1505. */
3647 if (curr_comp->attr.allocatable != 0)
3649 gfc_error ("Component '%s' at %L cannot have the "
3650 "ALLOCATABLE attribute because it is a member "
3651 "of the BIND(C) derived type '%s' at %L",
3652 curr_comp->name, &(curr_comp->loc),
3653 derived_sym->name, &(derived_sym->declared_at));
3657 /* BIND(C) derived types must have interoperable components. */
3658 if (curr_comp->ts.type == BT_DERIVED
3659 && curr_comp->ts.u.derived->ts.is_iso_c != 1
3660 && curr_comp->ts.u.derived != derived_sym)
3662 /* This should be allowed; the draft says a derived-type can not
3663 have type parameters if it is has the BIND attribute. Type
3664 parameters seem to be for making parameterized derived types.
3665 There's no need to verify the type if it is c_ptr/c_funptr. */
3666 retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3670 /* Grab the typespec for the given component and test the kind. */
3671 is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
3673 if (is_c_interop != SUCCESS)
3675 /* Report warning and continue since not fatal. The
3676 draft does specify a constraint that requires all fields
3677 to interoperate, but if the user says real(4), etc., it
3678 may interoperate with *something* in C, but the compiler
3679 most likely won't know exactly what. Further, it may not
3680 interoperate with the same data type(s) in C if the user
3681 recompiles with different flags (e.g., -m32 and -m64 on
3682 x86_64 and using integer(4) to claim interop with a
3684 if (derived_sym->attr.is_bind_c == 1)
3685 /* If the derived type is bind(c), all fields must be
3687 gfc_warning ("Component '%s' in derived type '%s' at %L "
3688 "may not be C interoperable, even though "
3689 "derived type '%s' is BIND(C)",
3690 curr_comp->name, derived_sym->name,
3691 &(curr_comp->loc), derived_sym->name);
3693 /* If derived type is param to bind(c) routine, or to one
3694 of the iso_c_binding procs, it must be interoperable, so
3695 all fields must interop too. */
3696 gfc_warning ("Component '%s' in derived type '%s' at %L "
3697 "may not be C interoperable",
3698 curr_comp->name, derived_sym->name,
3703 curr_comp = curr_comp->next;
3704 } while (curr_comp != NULL);
3707 /* Make sure we don't have conflicts with the attributes. */
3708 if (derived_sym->attr.access == ACCESS_PRIVATE)
3710 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3711 "PRIVATE and BIND(C) attributes", derived_sym->name,
3712 &(derived_sym->declared_at));
3716 if (derived_sym->attr.sequence != 0)
3718 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3719 "attribute because it is BIND(C)", derived_sym->name,
3720 &(derived_sym->declared_at));
3724 /* Mark the derived type as not being C interoperable if we found an
3725 error. If there were only warnings, proceed with the assumption
3726 it's interoperable. */
3727 if (retval == FAILURE)
3728 derived_sym->ts.is_c_interop = 0;
3734 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3737 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3738 const char *module_name)
3740 gfc_symtree *tmp_symtree;
3741 gfc_symbol *tmp_sym;
3744 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3746 if (tmp_symtree != NULL)
3747 tmp_sym = tmp_symtree->n.sym;
3751 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3752 "create symbol for %s", ptr_name);
3755 /* Set up the symbol's important fields. Save attr required so we can
3756 initialize the ptr to NULL. */
3757 tmp_sym->attr.save = SAVE_EXPLICIT;
3758 tmp_sym->ts.is_c_interop = 1;
3759 tmp_sym->attr.is_c_interop = 1;
3760 tmp_sym->ts.is_iso_c = 1;
3761 tmp_sym->ts.type = BT_DERIVED;
3763 /* The c_ptr and c_funptr derived types will provide the
3764 definition for c_null_ptr and c_null_funptr, respectively. */
3765 if (ptr_id == ISOCBINDING_NULL_PTR)
3766 tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3768 tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3769 if (tmp_sym->ts.u.derived == NULL)
3771 /* This can occur if the user forgot to declare c_ptr or
3772 c_funptr and they're trying to use one of the procedures
3773 that has arg(s) of the missing type. In this case, a
3774 regular version of the thing should have been put in the
3776 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3777 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3778 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3779 ? "_gfortran_iso_c_binding_c_ptr"
3780 : "_gfortran_iso_c_binding_c_funptr"));
3782 tmp_sym->ts.u.derived =
3783 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3784 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3787 /* Module name is some mangled version of iso_c_binding. */
3788 tmp_sym->module = gfc_get_string (module_name);
3790 /* Say it's from the iso_c_binding module. */
3791 tmp_sym->attr.is_iso_c = 1;
3793 tmp_sym->attr.use_assoc = 1;
3794 tmp_sym->attr.is_bind_c = 1;
3795 /* Set the binding_label. */
3796 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3798 /* Set the c_address field of c_null_ptr and c_null_funptr to
3799 the value of NULL. */
3800 tmp_sym->value = gfc_get_expr ();
3801 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3802 tmp_sym->value->ts.type = BT_DERIVED;
3803 tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
3804 gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
3805 c = gfc_constructor_first (tmp_sym->value->value.constructor);
3806 c->expr = gfc_get_expr ();
3807 c->expr->expr_type = EXPR_NULL;
3808 c->expr->ts.is_iso_c = 1;
3809 /* Must declare c_null_ptr and c_null_funptr as having the
3810 PARAMETER attribute so they can be used in init expressions. */
3811 tmp_sym->attr.flavor = FL_PARAMETER;
3817 /* Add a formal argument, gfc_formal_arglist, to the
3818 end of the given list of arguments. Set the reference to the
3819 provided symbol, param_sym, in the argument. */
3822 add_formal_arg (gfc_formal_arglist **head,
3823 gfc_formal_arglist **tail,
3824 gfc_formal_arglist *formal_arg,
3825 gfc_symbol *param_sym)
3827 /* Put in list, either as first arg or at the tail (curr arg). */
3829 *head = *tail = formal_arg;
3832 (*tail)->next = formal_arg;
3833 (*tail) = formal_arg;
3836 (*tail)->sym = param_sym;
3837 (*tail)->next = NULL;
3843 /* Generates a symbol representing the CPTR argument to an
3844 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3845 CPTR and add it to the provided argument list. */
3848 gen_cptr_param (gfc_formal_arglist **head,
3849 gfc_formal_arglist **tail,
3850 const char *module_name,
3851 gfc_namespace *ns, const char *c_ptr_name,
3854 gfc_symbol *param_sym = NULL;
3855 gfc_symbol *c_ptr_sym = NULL;
3856 gfc_symtree *param_symtree = NULL;
3857 gfc_formal_arglist *formal_arg = NULL;
3858 const char *c_ptr_in;
3859 const char *c_ptr_type = NULL;
3861 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3862 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3864 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3866 if(c_ptr_name == NULL)
3867 c_ptr_in = "gfc_cptr__";
3869 c_ptr_in = c_ptr_name;
3870 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree, false);
3871 if (param_symtree != NULL)
3872 param_sym = param_symtree->n.sym;
3874 gfc_internal_error ("gen_cptr_param(): Unable to "
3875 "create symbol for %s", c_ptr_in);
3877 /* Set up the appropriate fields for the new c_ptr param sym. */
3879 param_sym->attr.flavor = FL_DERIVED;
3880 param_sym->ts.type = BT_DERIVED;
3881 param_sym->attr.intent = INTENT_IN;
3882 param_sym->attr.dummy = 1;
3884 /* This will pass the ptr to the iso_c routines as a (void *). */
3885 param_sym->attr.value = 1;
3886 param_sym->attr.use_assoc = 1;
3888 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3890 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3891 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3893 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3894 if (c_ptr_sym == NULL)
3896 /* This can happen if the user did not define c_ptr but they are
3897 trying to use one of the iso_c_binding functions that need it. */
3898 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3899 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3900 (const char *)c_ptr_type);
3902 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3903 (const char *)c_ptr_type);
3905 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3908 param_sym->ts.u.derived = c_ptr_sym;
3909 param_sym->module = gfc_get_string (module_name);
3911 /* Make new formal arg. */
3912 formal_arg = gfc_get_formal_arglist ();
3913 /* Add arg to list of formal args (the CPTR arg). */
3914 add_formal_arg (head, tail, formal_arg, param_sym);
3916 /* Validate changes. */
3917 gfc_commit_symbol (param_sym);
3921 /* Generates a symbol representing the FPTR argument to an
3922 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3923 FPTR and add it to the provided argument list. */
3926 gen_fptr_param (gfc_formal_arglist **head,
3927 gfc_formal_arglist **tail,
3928 const char *module_name,
3929 gfc_namespace *ns, const char *f_ptr_name, int proc)
3931 gfc_symbol *param_sym = NULL;
3932 gfc_symtree *param_symtree = NULL;
3933 gfc_formal_arglist *formal_arg = NULL;
3934 const char *f_ptr_out = "gfc_fptr__";
3936 if (f_ptr_name != NULL)
3937 f_ptr_out = f_ptr_name;
3939 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree, false);
3940 if (param_symtree != NULL)
3941 param_sym = param_symtree->n.sym;
3943 gfc_internal_error ("generateFPtrParam(): Unable to "
3944 "create symbol for %s", f_ptr_out);
3946 /* Set up the necessary fields for the fptr output param sym. */
3949 param_sym->attr.proc_pointer = 1;
3951 param_sym->attr.pointer = 1;
3952 param_sym->attr.dummy = 1;
3953 param_sym->attr.use_assoc = 1;
3955 /* ISO C Binding type to allow any pointer type as actual param. */
3956 param_sym->ts.type = BT_VOID;
3957 param_sym->module = gfc_get_string (module_name);
3960 formal_arg = gfc_get_formal_arglist ();
3961 /* Add arg to list of formal args. */
3962 add_formal_arg (head, tail, formal_arg, param_sym);
3964 /* Validate changes. */
3965 gfc_commit_symbol (param_sym);
3969 /* Generates a symbol representing the optional SHAPE argument for the
3970 iso_c_binding c_f_pointer() procedure. Also, create a
3971 gfc_formal_arglist for the SHAPE and add it to the provided
3975 gen_shape_param (gfc_formal_arglist **head,
3976 gfc_formal_arglist **tail,
3977 const char *module_name,
3978 gfc_namespace *ns, const char *shape_param_name)
3980 gfc_symbol *param_sym = NULL;
3981 gfc_symtree *param_symtree = NULL;
3982 gfc_formal_arglist *formal_arg = NULL;
3983 const char *shape_param = "gfc_shape_array__";
3985 if (shape_param_name != NULL)
3986 shape_param = shape_param_name;
3988 gfc_get_sym_tree (shape_param, ns, ¶m_symtree, false);
3989 if (param_symtree != NULL)
3990 param_sym = param_symtree->n.sym;
3992 gfc_internal_error ("generateShapeParam(): Unable to "
3993 "create symbol for %s", shape_param);
3995 /* Set up the necessary fields for the shape input param sym. */
3997 param_sym->attr.dummy = 1;
3998 param_sym->attr.use_assoc = 1;
4000 /* Integer array, rank 1, describing the shape of the object. Make it's
4001 type BT_VOID initially so we can accept any type/kind combination of
4002 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
4003 of BT_INTEGER type. */
4004 param_sym->ts.type = BT_VOID;
4006 /* Initialize the kind to default integer. However, it will be overridden
4007 during resolution to match the kind of the SHAPE parameter given as
4008 the actual argument (to allow for any valid integer kind). */
4009 param_sym->ts.kind = gfc_default_integer_kind;
4010 param_sym->as = gfc_get_array_spec ();
4012 param_sym->as->rank = 1;
4013 param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
4016 /* The extent is unknown until we get it. The length give us
4017 the rank the incoming pointer. */
4018 param_sym->as->type = AS_ASSUMED_SHAPE;
4020 /* The arg is also optional; it is required iff the second arg
4021 (fptr) is to an array, otherwise, it's ignored. */
4022 param_sym->attr.optional = 1;
4023 param_sym->attr.intent = INTENT_IN;
4024 param_sym->attr.dimension = 1;
4025 param_sym->module = gfc_get_string (module_name);
4028 formal_arg = gfc_get_formal_arglist ();
4029 /* Add arg to list of formal args. */
4030 add_formal_arg (head, tail, formal_arg, param_sym);
4032 /* Validate changes. */
4033 gfc_commit_symbol (param_sym);
4037 /* Add a procedure interface to the given symbol (i.e., store a
4038 reference to the list of formal arguments). */
4041 add_proc_interface (gfc_symbol *sym, ifsrc source,
4042 gfc_formal_arglist *formal)
4045 sym->formal = formal;
4046 sym->attr.if_source = source;
4050 /* Copy the formal args from an existing symbol, src, into a new
4051 symbol, dest. New formal args are created, and the description of
4052 each arg is set according to the existing ones. This function is
4053 used when creating procedure declaration variables from a procedure
4054 declaration statement (see match_proc_decl()) to create the formal
4055 args based on the args of a given named interface. */
4058 gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
4060 gfc_formal_arglist *head = NULL;
4061 gfc_formal_arglist *tail = NULL;
4062 gfc_formal_arglist *formal_arg = NULL;
4063 gfc_formal_arglist *curr_arg = NULL;
4064 gfc_formal_arglist *formal_prev = NULL;
4065 /* Save current namespace so we can change it for formal args. */
4066 gfc_namespace *parent_ns = gfc_current_ns;
4068 /* Create a new namespace, which will be the formal ns (namespace
4069 of the formal args). */
4070 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4071 gfc_current_ns->proc_name = dest;
4073 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4075 formal_arg = gfc_get_formal_arglist ();
4076 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
4078 /* May need to copy more info for the symbol. */
4079 formal_arg->sym->attr = curr_arg->sym->attr;
4080 formal_arg->sym->ts = curr_arg->sym->ts;
4081 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
4082 gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
4084 /* If this isn't the first arg, set up the next ptr. For the
4085 last arg built, the formal_arg->next will never get set to
4086 anything other than NULL. */
4087 if (formal_prev != NULL)
4088 formal_prev->next = formal_arg;
4090 formal_arg->next = NULL;
4092 formal_prev = formal_arg;
4094 /* Add arg to list of formal args. */
4095 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4097 /* Validate changes. */
4098 gfc_commit_symbol (formal_arg->sym);
4101 /* Add the interface to the symbol. */
4102 add_proc_interface (dest, IFSRC_DECL, head);
4104 /* Store the formal namespace information. */
4105 if (dest->formal != NULL)
4106 /* The current ns should be that for the dest proc. */
4107 dest->formal_ns = gfc_current_ns;
4108 /* Restore the current namespace to what it was on entry. */
4109 gfc_current_ns = parent_ns;
4114 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
4116 gfc_formal_arglist *head = NULL;
4117 gfc_formal_arglist *tail = NULL;
4118 gfc_formal_arglist *formal_arg = NULL;
4119 gfc_intrinsic_arg *curr_arg = NULL;
4120 gfc_formal_arglist *formal_prev = NULL;
4121 /* Save current namespace so we can change it for formal args. */
4122 gfc_namespace *parent_ns = gfc_current_ns;
4124 /* Create a new namespace, which will be the formal ns (namespace
4125 of the formal args). */
4126 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4127 gfc_current_ns->proc_name = dest;
4129 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4131 formal_arg = gfc_get_formal_arglist ();
4132 gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4134 /* May need to copy more info for the symbol. */
4135 formal_arg->sym->ts = curr_arg->ts;
4136 formal_arg->sym->attr.optional = curr_arg->optional;
4137 formal_arg->sym->attr.value = curr_arg->value;
4138 formal_arg->sym->attr.intent = curr_arg->intent;
4139 formal_arg->sym->attr.flavor = FL_VARIABLE;
4140 formal_arg->sym->attr.dummy = 1;
4142 if (formal_arg->sym->ts.type == BT_CHARACTER)
4143 formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4145 /* If this isn't the first arg, set up the next ptr. For the
4146 last arg built, the formal_arg->next will never get set to
4147 anything other than NULL. */
4148 if (formal_prev != NULL)
4149 formal_prev->next = formal_arg;
4151 formal_arg->next = NULL;
4153 formal_prev = formal_arg;
4155 /* Add arg to list of formal args. */
4156 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4158 /* Validate changes. */
4159 gfc_commit_symbol (formal_arg->sym);
4162 /* Add the interface to the symbol. */
4163 add_proc_interface (dest, IFSRC_DECL, head);
4165 /* Store the formal namespace information. */
4166 if (dest->formal != NULL)
4167 /* The current ns should be that for the dest proc. */
4168 dest->formal_ns = gfc_current_ns;
4169 /* Restore the current namespace to what it was on entry. */
4170 gfc_current_ns = parent_ns;
4175 gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
4177 gfc_formal_arglist *head = NULL;
4178 gfc_formal_arglist *tail = NULL;
4179 gfc_formal_arglist *formal_arg = NULL;
4180 gfc_formal_arglist *curr_arg = NULL;
4181 gfc_formal_arglist *formal_prev = NULL;
4182 /* Save current namespace so we can change it for formal args. */
4183 gfc_namespace *parent_ns = gfc_current_ns;
4185 /* Create a new namespace, which will be the formal ns (namespace
4186 of the formal args). */
4187 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4188 /* TODO: gfc_current_ns->proc_name = dest;*/
4190 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4192 formal_arg = gfc_get_formal_arglist ();
4193 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
4195 /* May need to copy more info for the symbol. */
4196 formal_arg->sym->attr = curr_arg->sym->attr;
4197 formal_arg->sym->ts = curr_arg->sym->ts;
4198 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
4199 gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
4201 /* If this isn't the first arg, set up the next ptr. For the
4202 last arg built, the formal_arg->next will never get set to
4203 anything other than NULL. */
4204 if (formal_prev != NULL)
4205 formal_prev->next = formal_arg;
4207 formal_arg->next = NULL;
4209 formal_prev = formal_arg;
4211 /* Add arg to list of formal args. */
4212 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4214 /* Validate changes. */
4215 gfc_commit_symbol (formal_arg->sym);
4218 /* Add the interface to the symbol. */
4219 gfc_free_formal_arglist (dest->formal);
4220 dest->formal = head;
4221 dest->attr.if_source = IFSRC_DECL;
4223 /* Store the formal namespace information. */
4224 if (dest->formal != NULL)
4225 /* The current ns should be that for the dest proc. */
4226 dest->formal_ns = gfc_current_ns;
4227 /* Restore the current namespace to what it was on entry. */
4228 gfc_current_ns = parent_ns;
4232 /* Builds the parameter list for the iso_c_binding procedure
4233 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
4234 generic version of either the c_f_pointer or c_f_procpointer
4235 functions. The new_proc_sym represents a "resolved" version of the
4236 symbol. The functions are resolved to match the types of their
4237 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4238 something similar to c_f_pointer_i4 if the type of data object fptr
4239 pointed to was a default integer. The actual name of the resolved
4240 procedure symbol is further mangled with the module name, etc., but
4241 the idea holds true. */
4244 build_formal_args (gfc_symbol *new_proc_sym,
4245 gfc_symbol *old_sym, int add_optional_arg)
4247 gfc_formal_arglist *head = NULL, *tail = NULL;
4248 gfc_namespace *parent_ns = NULL;
4250 parent_ns = gfc_current_ns;
4251 /* Create a new namespace, which will be the formal ns (namespace
4252 of the formal args). */
4253 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
4254 gfc_current_ns->proc_name = new_proc_sym;
4256 /* Generate the params. */
4257 if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
4259 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4260 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4261 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4262 gfc_current_ns, "fptr", 1);
4264 else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
4266 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4267 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4268 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4269 gfc_current_ns, "fptr", 0);
4270 /* If we're dealing with c_f_pointer, it has an optional third arg. */
4271 gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
4272 gfc_current_ns, "shape");
4275 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
4277 /* c_associated has one required arg and one optional; both
4279 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4280 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
4281 if (add_optional_arg)
4283 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4284 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
4285 /* The last param is optional so mark it as such. */
4286 tail->sym->attr.optional = 1;
4290 /* Add the interface (store formal args to new_proc_sym). */
4291 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
4293 /* Set up the formal_ns pointer to the one created for the
4294 new procedure so it'll get cleaned up during gfc_free_symbol(). */
4295 new_proc_sym->formal_ns = gfc_current_ns;
4297 gfc_current_ns = parent_ns;
4301 std_for_isocbinding_symbol (int id)
4305 #define NAMED_INTCST(a,b,c,d) \
4308 #include "iso-c-binding.def"
4311 #define NAMED_FUNCTION(a,b,c,d) \
4314 #include "iso-c-binding.def"
4315 #undef NAMED_FUNCTION
4318 return GFC_STD_F2003;
4322 /* Generate the given set of C interoperable kind objects, or all
4323 interoperable kinds. This function will only be given kind objects
4324 for valid iso_c_binding defined types because this is verified when
4325 the 'use' statement is parsed. If the user gives an 'only' clause,
4326 the specific kinds are looked up; if they don't exist, an error is
4327 reported. If the user does not give an 'only' clause, all
4328 iso_c_binding symbols are generated. If a list of specific kinds
4329 is given, it must have a NULL in the first empty spot to mark the
4334 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4335 const char *local_name)
4337 const char *const name = (local_name && local_name[0]) ? local_name
4338 : c_interop_kinds_table[s].name;
4339 gfc_symtree *tmp_symtree = NULL;
4340 gfc_symbol *tmp_sym = NULL;
4341 gfc_dt_list **dt_list_ptr = NULL;
4342 gfc_component *tmp_comp = NULL;
4343 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
4346 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4348 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4350 /* Already exists in this scope so don't re-add it.
4351 TODO: we should probably check that it's really the same symbol. */
4352 if (tmp_symtree != NULL)
4355 /* Create the sym tree in the current ns. */
4356 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4358 tmp_sym = tmp_symtree->n.sym;
4360 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4363 /* Say what module this symbol belongs to. */
4364 tmp_sym->module = gfc_get_string (mod_name);
4365 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4366 tmp_sym->intmod_sym_id = s;
4371 #define NAMED_INTCST(a,b,c,d) case a :
4372 #define NAMED_REALCST(a,b,c,d) case a :
4373 #define NAMED_CMPXCST(a,b,c,d) case a :
4374 #define NAMED_LOGCST(a,b,c) case a :
4375 #define NAMED_CHARKNDCST(a,b,c) case a :
4376 #include "iso-c-binding.def"
4378 tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4379 c_interop_kinds_table[s].value);
4381 /* Initialize an integer constant expression node. */
4382 tmp_sym->attr.flavor = FL_PARAMETER;
4383 tmp_sym->ts.type = BT_INTEGER;
4384 tmp_sym->ts.kind = gfc_default_integer_kind;
4386 /* Mark this type as a C interoperable one. */
4387 tmp_sym->ts.is_c_interop = 1;
4388 tmp_sym->ts.is_iso_c = 1;
4389 tmp_sym->value->ts.is_c_interop = 1;
4390 tmp_sym->value->ts.is_iso_c = 1;
4391 tmp_sym->attr.is_c_interop = 1;
4393 /* Tell what f90 type this c interop kind is valid. */
4394 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4396 /* Say it's from the iso_c_binding module. */
4397 tmp_sym->attr.is_iso_c = 1;
4399 /* Make it use associated. */
4400 tmp_sym->attr.use_assoc = 1;
4404 #define NAMED_CHARCST(a,b,c) case a :
4405 #include "iso-c-binding.def"
4407 /* Initialize an integer constant expression node for the
4408 length of the character. */
4409 tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
4410 &gfc_current_locus, NULL, 1);
4411 tmp_sym->value->ts.is_c_interop = 1;
4412 tmp_sym->value->ts.is_iso_c = 1;
4413 tmp_sym->value->value.character.length = 1;
4414 tmp_sym->value->value.character.string[0]
4415 = (gfc_char_t) c_interop_kinds_table[s].value;
4416 tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4417 tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
4420 /* May not need this in both attr and ts, but do need in
4421 attr for writing module file. */
4422 tmp_sym->attr.is_c_interop = 1;
4424 tmp_sym->attr.flavor = FL_PARAMETER;
4425 tmp_sym->ts.type = BT_CHARACTER;
4427 /* Need to set it to the C_CHAR kind. */
4428 tmp_sym->ts.kind = gfc_default_character_kind;
4430 /* Mark this type as a C interoperable one. */
4431 tmp_sym->ts.is_c_interop = 1;
4432 tmp_sym->ts.is_iso_c = 1;
4434 /* Tell what f90 type this c interop kind is valid. */
4435 tmp_sym->ts.f90_type = BT_CHARACTER;
4437 /* Say it's from the iso_c_binding module. */
4438 tmp_sym->attr.is_iso_c = 1;
4440 /* Make it use associated. */
4441 tmp_sym->attr.use_assoc = 1;
4444 case ISOCBINDING_PTR:
4445 case ISOCBINDING_FUNPTR:
4447 /* Initialize an integer constant expression node. */
4448 tmp_sym->attr.flavor = FL_DERIVED;
4449 tmp_sym->ts.is_c_interop = 1;
4450 tmp_sym->attr.is_c_interop = 1;
4451 tmp_sym->attr.is_iso_c = 1;
4452 tmp_sym->ts.is_iso_c = 1;
4453 tmp_sym->ts.type = BT_DERIVED;
4455 /* A derived type must have the bind attribute to be
4456 interoperable (J3/04-007, Section 15.2.3), even though
4457 the binding label is not used. */
4458 tmp_sym->attr.is_bind_c = 1;
4460 tmp_sym->attr.referenced = 1;
4462 tmp_sym->ts.u.derived = tmp_sym;
4464 /* Add the symbol created for the derived type to the current ns. */
4465 dt_list_ptr = &(gfc_derived_types);
4466 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4467 dt_list_ptr = &((*dt_list_ptr)->next);
4469 /* There is already at least one derived type in the list, so append
4470 the one we're currently building for c_ptr or c_funptr. */
4471 if (*dt_list_ptr != NULL)
4472 dt_list_ptr = &((*dt_list_ptr)->next);
4473 (*dt_list_ptr) = gfc_get_dt_list ();
4474 (*dt_list_ptr)->derived = tmp_sym;
4475 (*dt_list_ptr)->next = NULL;
4477 /* Set up the component of the derived type, which will be
4478 an integer with kind equal to c_ptr_size. Mangle the name of
4479 the field for the c_address to prevent the curious user from
4480 trying to access it from Fortran. */
4481 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
4482 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
4483 if (tmp_comp == NULL)
4484 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4485 "create component for c_address");
4487 tmp_comp->ts.type = BT_INTEGER;
4489 /* Set this because the module will need to read/write this field. */
4490 tmp_comp->ts.f90_type = BT_INTEGER;
4492 /* The kinds for c_ptr and c_funptr are the same. */
4493 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4494 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4496 tmp_comp->attr.pointer = 0;
4497 tmp_comp->attr.dimension = 0;
4499 /* Mark the component as C interoperable. */
4500 tmp_comp->ts.is_c_interop = 1;
4502 /* Make it use associated (iso_c_binding module). */
4503 tmp_sym->attr.use_assoc = 1;
4506 case ISOCBINDING_NULL_PTR:
4507 case ISOCBINDING_NULL_FUNPTR:
4508 gen_special_c_interop_ptr (s, name, mod_name);
4511 case ISOCBINDING_F_POINTER:
4512 case ISOCBINDING_ASSOCIATED:
4513 case ISOCBINDING_LOC:
4514 case ISOCBINDING_FUNLOC:
4515 case ISOCBINDING_F_PROCPOINTER:
4517 tmp_sym->attr.proc = PROC_MODULE;
4519 /* Use the procedure's name as it is in the iso_c_binding module for
4520 setting the binding label in case the user renamed the symbol. */
4521 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
4522 c_interop_kinds_table[s].name);
4523 tmp_sym->attr.is_iso_c = 1;
4524 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4525 tmp_sym->attr.subroutine = 1;
4528 /* TODO! This needs to be finished more for the expr of the
4529 function or something!
4530 This may not need to be here, because trying to do c_loc
4532 if (s == ISOCBINDING_ASSOCIATED)
4534 tmp_sym->attr.function = 1;
4535 tmp_sym->ts.type = BT_LOGICAL;
4536 tmp_sym->ts.kind = gfc_default_logical_kind;
4537 tmp_sym->result = tmp_sym;
4541 /* Here, we're taking the simple approach. We're defining
4542 c_loc as an external identifier so the compiler will put
4543 what we expect on the stack for the address we want the
4545 tmp_sym->ts.type = BT_DERIVED;
4546 if (s == ISOCBINDING_LOC)
4547 tmp_sym->ts.u.derived =
4548 get_iso_c_binding_dt (ISOCBINDING_PTR);
4550 tmp_sym->ts.u.derived =
4551 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4553 if (tmp_sym->ts.u.derived == NULL)
4555 /* Create the necessary derived type so we can continue
4556 processing the file. */
4557 generate_isocbinding_symbol
4558 (mod_name, s == ISOCBINDING_FUNLOC
4559 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4560 (const char *)(s == ISOCBINDING_FUNLOC
4561 ? "_gfortran_iso_c_binding_c_funptr"
4562 : "_gfortran_iso_c_binding_c_ptr"));
4563 tmp_sym->ts.u.derived =
4564 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4565 ? ISOCBINDING_FUNPTR
4569 /* The function result is itself (no result clause). */
4570 tmp_sym->result = tmp_sym;
4571 tmp_sym->attr.external = 1;
4572 tmp_sym->attr.use_assoc = 0;
4573 tmp_sym->attr.pure = 1;
4574 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4575 tmp_sym->attr.proc = PROC_UNKNOWN;
4579 tmp_sym->attr.flavor = FL_PROCEDURE;
4580 tmp_sym->attr.contained = 0;
4582 /* Try using this builder routine, with the new and old symbols
4583 both being the generic iso_c proc sym being created. This
4584 will create the formal args (and the new namespace for them).
4585 Don't build an arg list for c_loc because we're going to treat
4586 c_loc as an external procedure. */
4587 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4588 /* The 1 says to add any optional args, if applicable. */
4589 build_formal_args (tmp_sym, tmp_sym, 1);
4591 /* Set this after setting up the symbol, to prevent error messages. */
4592 tmp_sym->attr.use_assoc = 1;
4594 /* This symbol will not be referenced directly. It will be
4595 resolved to the implementation for the given f90 kind. */
4596 tmp_sym->attr.referenced = 0;
4603 gfc_commit_symbol (tmp_sym);
4607 /* Creates a new symbol based off of an old iso_c symbol, with a new
4608 binding label. This function can be used to create a new,
4609 resolved, version of a procedure symbol for c_f_pointer or
4610 c_f_procpointer that is based on the generic symbols. A new
4611 parameter list is created for the new symbol using
4612 build_formal_args(). The add_optional_flag specifies whether the
4613 to add the optional SHAPE argument. The new symbol is
4617 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4618 char *new_binding_label, int add_optional_arg)
4620 gfc_symtree *new_symtree = NULL;
4622 /* See if we have a symbol by that name already available, looking
4623 through any parent namespaces. */
4624 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4625 if (new_symtree != NULL)
4626 /* Return the existing symbol. */
4627 return new_symtree->n.sym;
4629 /* Create the symtree/symbol, with attempted host association. */
4630 gfc_get_ha_sym_tree (new_name, &new_symtree);
4631 if (new_symtree == NULL)
4632 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4633 "symtree for '%s'", new_name);
4635 /* Now fill in the fields of the resolved symbol with the old sym. */
4636 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4637 new_symtree->n.sym->attr = old_sym->attr;
4638 new_symtree->n.sym->ts = old_sym->ts;
4639 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4640 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4641 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4642 if (old_sym->attr.function)
4643 new_symtree->n.sym->result = new_symtree->n.sym;
4644 /* Build the formal arg list. */
4645 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4647 gfc_commit_symbol (new_symtree->n.sym);
4649 return new_symtree->n.sym;
4653 /* Check that a symbol is already typed. If strict is not set, an untyped
4654 symbol is acceptable for non-standard-conforming mode. */
4657 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4658 bool strict, locus where)
4662 if (gfc_matching_prefix)
4665 /* Check for the type and try to give it an implicit one. */
4666 if (sym->ts.type == BT_UNKNOWN
4667 && gfc_set_default_type (sym, 0, ns) == FAILURE)
4671 gfc_error ("Symbol '%s' is used before it is typed at %L",
4676 if (gfc_notify_std (GFC_STD_GNU,
4677 "Extension: Symbol '%s' is used before"
4678 " it is typed at %L", sym->name, &where) == FAILURE)
4682 /* Everything is ok. */
4687 /* Construct a typebound-procedure structure. Those are stored in a tentative
4688 list and marked `error' until symbols are committed. */
4691 gfc_get_typebound_proc (gfc_typebound_proc *tb0)
4693 gfc_typebound_proc *result;
4694 tentative_tbp *list_node;
4696 result = XCNEW (gfc_typebound_proc);
4701 list_node = XCNEW (tentative_tbp);
4702 list_node->next = tentative_tbp_list;
4703 list_node->proc = result;
4704 tentative_tbp_list = list_node;
4710 /* Get the super-type of a given derived type. */
4713 gfc_get_derived_super_type (gfc_symbol* derived)
4715 if (!derived->attr.extension)
4718 gcc_assert (derived->components);
4719 gcc_assert (derived->components->ts.type == BT_DERIVED);
4720 gcc_assert (derived->components->ts.u.derived);
4722 return derived->components->ts.u.derived;
4726 /* Get the ultimate super-type of a given derived type. */
4729 gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
4731 if (!derived->attr.extension)
4734 derived = gfc_get_derived_super_type (derived);
4736 if (derived->attr.extension)
4737 return gfc_get_ultimate_derived_super_type (derived);
4743 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4746 gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
4748 while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
4749 t2 = gfc_get_derived_super_type (t2);
4750 return gfc_compare_derived_types (t1, t2);
4754 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4755 If ts1 is nonpolymorphic, ts2 must be the same type.
4756 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4759 gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
4761 bool is_class1 = (ts1->type == BT_CLASS);
4762 bool is_class2 = (ts2->type == BT_CLASS);
4763 bool is_derived1 = (ts1->type == BT_DERIVED);
4764 bool is_derived2 = (ts2->type == BT_DERIVED);
4766 if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
4767 return (ts1->type == ts2->type);
4769 if (is_derived1 && is_derived2)
4770 return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
4772 if (is_class1 && is_derived2)
4773 return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4775 else if (is_class1 && is_class2)
4776 return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4777 ts2->u.derived->components->ts.u.derived);
4783 /* Find the parent-namespace of the current function. If we're inside
4784 BLOCK constructs, it may not be the current one. */
4787 gfc_find_proc_namespace (gfc_namespace* ns)
4789 while (ns->construct_entities)
4799 /* Check if an associate-variable should be translated as an `implicit' pointer
4800 internally (if it is associated to a variable and not an array with
4804 gfc_is_associate_pointer (gfc_symbol* sym)
4809 if (!sym->assoc->variable)
4812 if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)