1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
31 /* Strings for all symbol attributes. We use these for dumping the
32 parse tree, in error messages, and also when reading and writing
35 const mstring flavors[] =
37 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
38 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
39 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
40 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
41 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
45 const mstring procedures[] =
47 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
48 minit ("MODULE-PROC", PROC_MODULE),
49 minit ("INTERNAL-PROC", PROC_INTERNAL),
50 minit ("DUMMY-PROC", PROC_DUMMY),
51 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
52 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
53 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
57 const mstring intents[] =
59 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
60 minit ("IN", INTENT_IN),
61 minit ("OUT", INTENT_OUT),
62 minit ("INOUT", INTENT_INOUT),
66 const mstring access_types[] =
68 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
69 minit ("PUBLIC", ACCESS_PUBLIC),
70 minit ("PRIVATE", ACCESS_PRIVATE),
74 const mstring ifsrc_types[] =
76 minit ("UNKNOWN", IFSRC_UNKNOWN),
77 minit ("DECL", IFSRC_DECL),
78 minit ("BODY", IFSRC_IFBODY),
79 minit ("USAGE", IFSRC_USAGE)
82 const mstring save_status[] =
84 minit ("UNKNOWN", SAVE_NONE),
85 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
86 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
89 /* This is to make sure the backend generates setup code in the correct
92 static int next_dummy_order = 1;
95 gfc_namespace *gfc_current_ns;
97 gfc_gsymbol *gfc_gsym_root = NULL;
99 static gfc_symbol *changed_syms = NULL;
101 gfc_dt_list *gfc_derived_types;
104 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
106 /* The following static variable indicates whether a particular element has
107 been explicitly set or not. */
109 static int new_flag[GFC_LETTERS];
112 /* Handle a correctly parsed IMPLICIT NONE. */
115 gfc_set_implicit_none (void)
119 if (gfc_current_ns->seen_implicit_none)
121 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
125 gfc_current_ns->seen_implicit_none = 1;
127 for (i = 0; i < GFC_LETTERS; i++)
129 gfc_clear_ts (&gfc_current_ns->default_type[i]);
130 gfc_current_ns->set_flag[i] = 1;
135 /* Reset the implicit range flags. */
138 gfc_clear_new_implicit (void)
142 for (i = 0; i < GFC_LETTERS; i++)
147 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
150 gfc_add_new_implicit_range (int c1, int c2)
157 for (i = c1; i <= c2; i++)
161 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
173 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
174 the new implicit types back into the existing types will work. */
177 gfc_merge_new_implicit (gfc_typespec *ts)
181 if (gfc_current_ns->seen_implicit_none)
183 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
187 for (i = 0; i < GFC_LETTERS; i++)
192 if (gfc_current_ns->set_flag[i])
194 gfc_error ("Letter %c already has an IMPLICIT type at %C",
198 gfc_current_ns->default_type[i] = *ts;
199 gfc_current_ns->set_flag[i] = 1;
206 /* Given a symbol, return a pointer to the typespec for its default type. */
209 gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns)
213 letter = sym->name[0];
215 if (gfc_option.flag_allow_leading_underscore && letter == '_')
216 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
217 "gfortran developers, and should not be used for "
218 "implicitly typed variables");
220 if (letter < 'a' || letter > 'z')
221 gfc_internal_error ("gfc_get_default_type(): Bad symbol");
226 return &ns->default_type[letter - 'a'];
230 /* Given a pointer to a symbol, set its type according to the first
231 letter of its name. Fails if the letter in question has no default
235 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
239 if (sym->ts.type != BT_UNKNOWN)
240 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
242 ts = gfc_get_default_type (sym, ns);
244 if (ts->type == BT_UNKNOWN)
246 if (error_flag && !sym->attr.untyped)
248 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
249 sym->name, &sym->declared_at);
250 sym->attr.untyped = 1; /* Ensure we only give an error once. */
257 sym->attr.implicit_type = 1;
259 if (sym->attr.is_bind_c == 1)
261 /* BIND(C) variables should not be implicitly declared. */
262 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
263 "not be C interoperable", sym->name, &sym->declared_at);
264 sym->ts.f90_type = sym->ts.type;
267 if (sym->attr.dummy != 0)
269 if (sym->ns->proc_name != NULL
270 && (sym->ns->proc_name->attr.subroutine != 0
271 || sym->ns->proc_name->attr.function != 0)
272 && sym->ns->proc_name->attr.is_bind_c != 0)
274 /* Dummy args to a BIND(C) routine may not be interoperable if
275 they are implicitly typed. */
276 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
277 "be C interoperable but it is a dummy argument to "
278 "the BIND(C) procedure '%s' at %L", sym->name,
279 &(sym->declared_at), sym->ns->proc_name->name,
280 &(sym->ns->proc_name->declared_at));
281 sym->ts.f90_type = sym->ts.type;
289 /* This function is called from parse.c(parse_progunit) to check the
290 type of the function is not implicitly typed in the host namespace
291 and to implicitly type the function result, if necessary. */
294 gfc_check_function_type (gfc_namespace *ns)
296 gfc_symbol *proc = ns->proc_name;
298 if (!proc->attr.contained || proc->result->attr.implicit_type)
301 if (proc->result->ts.type == BT_UNKNOWN)
303 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
306 if (proc->result != proc)
308 proc->ts = proc->result->ts;
309 proc->as = gfc_copy_array_spec (proc->result->as);
310 proc->attr.dimension = proc->result->attr.dimension;
311 proc->attr.pointer = proc->result->attr.pointer;
312 proc->attr.allocatable = proc->result->attr.allocatable;
317 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
318 proc->result->name, &proc->result->declared_at);
319 proc->result->attr.untyped = 1;
325 /******************** Symbol attribute stuff *********************/
327 /* This is a generic conflict-checker. We do this to avoid having a
328 single conflict in two places. */
330 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
331 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
332 #define conf_std(a, b, std) if (attr->a && attr->b)\
341 check_conflict (symbol_attribute *attr, const char *name, locus *where)
343 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
344 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
345 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
346 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
347 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
348 *privat = "PRIVATE", *recursive = "RECURSIVE",
349 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
350 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
351 *function = "FUNCTION", *subroutine = "SUBROUTINE",
352 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
353 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
354 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
355 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
356 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE";
357 static const char *threadprivate = "THREADPRIVATE";
363 where = &gfc_current_locus;
365 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
369 standard = GFC_STD_F2003;
373 /* Check for attributes not allowed in a BLOCK DATA. */
374 if (gfc_current_state () == COMP_BLOCK_DATA)
378 if (attr->in_namelist)
380 if (attr->allocatable)
386 if (attr->access == ACCESS_PRIVATE)
388 if (attr->access == ACCESS_PUBLIC)
390 if (attr->intent != INTENT_UNKNOWN)
396 ("%s attribute not allowed in BLOCK DATA program unit at %L",
402 if (attr->save == SAVE_EXPLICIT)
405 conf (in_common, save);
408 switch (attr->flavor)
416 a1 = gfc_code2string (flavors, attr->flavor);
421 /* Conflicts between SAVE and PROCEDURE will be checked at
422 resolution stage, see "resolve_fl_procedure". */
431 conf (dummy, intrinsic);
432 conf (dummy, threadprivate);
433 conf (pointer, target);
434 conf (pointer, intrinsic);
435 conf (pointer, elemental);
436 conf (allocatable, elemental);
438 conf (target, external);
439 conf (target, intrinsic);
441 if (!attr->if_source)
442 conf (external, dimension); /* See Fortran 95's R504. */
444 conf (external, intrinsic);
445 conf (entry, intrinsic);
447 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
449 conf (external, subroutine);
450 conf (external, function);
453 conf (allocatable, pointer);
454 conf_std (allocatable, dummy, GFC_STD_F2003);
455 conf_std (allocatable, function, GFC_STD_F2003);
456 conf_std (allocatable, result, GFC_STD_F2003);
457 conf (elemental, recursive);
459 conf (in_common, dummy);
460 conf (in_common, allocatable);
461 conf (in_common, result);
463 conf (dummy, result);
465 conf (in_equivalence, use_assoc);
466 conf (in_equivalence, dummy);
467 conf (in_equivalence, target);
468 conf (in_equivalence, pointer);
469 conf (in_equivalence, function);
470 conf (in_equivalence, result);
471 conf (in_equivalence, entry);
472 conf (in_equivalence, allocatable);
473 conf (in_equivalence, threadprivate);
475 conf (in_namelist, pointer);
476 conf (in_namelist, allocatable);
478 conf (entry, result);
480 conf (function, subroutine);
482 if (!function && !subroutine)
483 conf (is_bind_c, dummy);
485 conf (is_bind_c, cray_pointer);
486 conf (is_bind_c, cray_pointee);
487 conf (is_bind_c, allocatable);
488 conf (is_bind_c, elemental);
490 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
491 Parameter conflict caught below. Also, value cannot be specified
492 for a dummy procedure. */
494 /* Cray pointer/pointee conflicts. */
495 conf (cray_pointer, cray_pointee);
496 conf (cray_pointer, dimension);
497 conf (cray_pointer, pointer);
498 conf (cray_pointer, target);
499 conf (cray_pointer, allocatable);
500 conf (cray_pointer, external);
501 conf (cray_pointer, intrinsic);
502 conf (cray_pointer, in_namelist);
503 conf (cray_pointer, function);
504 conf (cray_pointer, subroutine);
505 conf (cray_pointer, entry);
507 conf (cray_pointee, allocatable);
508 conf (cray_pointee, intent);
509 conf (cray_pointee, optional);
510 conf (cray_pointee, dummy);
511 conf (cray_pointee, target);
512 conf (cray_pointee, intrinsic);
513 conf (cray_pointee, pointer);
514 conf (cray_pointee, entry);
515 conf (cray_pointee, in_common);
516 conf (cray_pointee, in_equivalence);
517 conf (cray_pointee, threadprivate);
520 conf (data, function);
522 conf (data, allocatable);
523 conf (data, use_assoc);
525 conf (value, pointer)
526 conf (value, allocatable)
527 conf (value, subroutine)
528 conf (value, function)
529 conf (value, volatile_)
530 conf (value, dimension)
531 conf (value, external)
534 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
537 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
541 conf (is_protected, intrinsic)
542 conf (is_protected, external)
543 conf (is_protected, in_common)
545 conf (volatile_, intrinsic)
546 conf (volatile_, external)
548 if (attr->volatile_ && attr->intent == INTENT_IN)
555 conf (procedure, allocatable)
556 conf (procedure, dimension)
557 conf (procedure, intrinsic)
558 conf (procedure, is_protected)
559 conf (procedure, target)
560 conf (procedure, value)
561 conf (procedure, volatile_)
562 conf (procedure, entry)
564 a1 = gfc_code2string (flavors, attr->flavor);
566 if (attr->in_namelist
567 && attr->flavor != FL_VARIABLE
568 && attr->flavor != FL_PROCEDURE
569 && attr->flavor != FL_UNKNOWN)
575 switch (attr->flavor)
585 conf2 (is_protected);
595 conf2 (threadprivate);
597 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
599 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
600 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
607 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
618 /* Conflicts with INTENT will be checked at resolution stage,
619 see "resolve_fl_procedure". */
621 if (attr->subroutine)
629 conf2 (threadprivate);
634 case PROC_ST_FUNCTION:
646 conf2 (threadprivate);
666 conf2 (threadprivate);
668 if (attr->intent != INTENT_UNKNOWN)
684 conf2 (is_protected);
690 conf2 (threadprivate);
703 gfc_error ("%s attribute conflicts with %s attribute at %L",
706 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
707 a1, a2, name, where);
714 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
715 "with %s attribute at %L", a1, a2,
720 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
721 "with %s attribute in '%s' at %L",
722 a1, a2, name, where);
731 /* Mark a symbol as referenced. */
734 gfc_set_sym_referenced (gfc_symbol *sym)
737 if (sym->attr.referenced)
740 sym->attr.referenced = 1;
742 /* Remember which order dummy variables are accessed in. */
744 sym->dummy_order = next_dummy_order++;
748 /* Common subroutine called by attribute changing subroutines in order
749 to prevent them from changing a symbol that has been
750 use-associated. Returns zero if it is OK to change the symbol,
754 check_used (symbol_attribute *attr, const char *name, locus *where)
757 if (attr->use_assoc == 0)
761 where = &gfc_current_locus;
764 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
767 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
774 /* Generate an error because of a duplicate attribute. */
777 duplicate_attr (const char *attr, locus *where)
781 where = &gfc_current_locus;
783 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
787 /* Called from decl.c (attr_decl1) to check attributes, when declared
791 gfc_add_attribute (symbol_attribute *attr, locus *where)
794 if (check_used (attr, NULL, where))
797 return check_conflict (attr, NULL, where);
801 gfc_add_allocatable (symbol_attribute *attr, locus *where)
804 if (check_used (attr, NULL, where))
807 if (attr->allocatable)
809 duplicate_attr ("ALLOCATABLE", where);
813 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
814 && gfc_find_state (COMP_INTERFACE) == FAILURE)
816 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
821 attr->allocatable = 1;
822 return check_conflict (attr, NULL, where);
827 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
830 if (check_used (attr, name, where))
835 duplicate_attr ("DIMENSION", where);
839 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
840 && gfc_find_state (COMP_INTERFACE) == FAILURE)
842 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
843 "at %L", name, where);
848 return check_conflict (attr, name, where);
853 gfc_add_external (symbol_attribute *attr, locus *where)
856 if (check_used (attr, NULL, where))
861 duplicate_attr ("EXTERNAL", where);
865 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
868 attr->proc_pointer = 1;
873 return check_conflict (attr, NULL, where);
878 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
881 if (check_used (attr, NULL, where))
886 duplicate_attr ("INTRINSIC", where);
892 return check_conflict (attr, NULL, where);
897 gfc_add_optional (symbol_attribute *attr, locus *where)
900 if (check_used (attr, NULL, where))
905 duplicate_attr ("OPTIONAL", where);
910 return check_conflict (attr, NULL, where);
915 gfc_add_pointer (symbol_attribute *attr, locus *where)
918 if (check_used (attr, NULL, where))
921 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
922 && gfc_find_state (COMP_INTERFACE) == FAILURE))
924 duplicate_attr ("POINTER", where);
928 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
929 || (attr->if_source == IFSRC_IFBODY
930 && gfc_find_state (COMP_INTERFACE) == FAILURE))
931 attr->proc_pointer = 1;
935 return check_conflict (attr, NULL, where);
940 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
943 if (check_used (attr, NULL, where))
946 attr->cray_pointer = 1;
947 return check_conflict (attr, NULL, where);
952 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
955 if (check_used (attr, NULL, where))
958 if (attr->cray_pointee)
960 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
961 " statements", where);
965 attr->cray_pointee = 1;
966 return check_conflict (attr, NULL, where);
971 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
973 if (check_used (attr, name, where))
976 if (attr->is_protected)
978 if (gfc_notify_std (GFC_STD_LEGACY,
979 "Duplicate PROTECTED attribute specified at %L",
985 attr->is_protected = 1;
986 return check_conflict (attr, name, where);
991 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
994 if (check_used (attr, name, where))
998 return check_conflict (attr, name, where);
1003 gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
1006 if (check_used (attr, name, where))
1009 if (gfc_pure (NULL))
1012 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1017 if (attr->save == SAVE_EXPLICIT)
1019 if (gfc_notify_std (GFC_STD_LEGACY,
1020 "Duplicate SAVE attribute specified at %L",
1026 attr->save = SAVE_EXPLICIT;
1027 return check_conflict (attr, name, where);
1032 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1035 if (check_used (attr, name, where))
1040 if (gfc_notify_std (GFC_STD_LEGACY,
1041 "Duplicate VALUE attribute specified at %L",
1048 return check_conflict (attr, name, where);
1053 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1055 /* No check_used needed as 11.2.1 of the F2003 standard allows
1056 that the local identifier made accessible by a use statement can be
1057 given a VOLATILE attribute. */
1059 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1060 if (gfc_notify_std (GFC_STD_LEGACY,
1061 "Duplicate VOLATILE attribute specified at %L", where)
1065 attr->volatile_ = 1;
1066 attr->volatile_ns = gfc_current_ns;
1067 return check_conflict (attr, name, where);
1072 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1075 if (check_used (attr, name, where))
1078 if (attr->threadprivate)
1080 duplicate_attr ("THREADPRIVATE", where);
1084 attr->threadprivate = 1;
1085 return check_conflict (attr, name, where);
1090 gfc_add_target (symbol_attribute *attr, locus *where)
1093 if (check_used (attr, NULL, where))
1098 duplicate_attr ("TARGET", where);
1103 return check_conflict (attr, NULL, where);
1108 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1111 if (check_used (attr, name, where))
1114 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1116 return check_conflict (attr, name, where);
1121 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1124 if (check_used (attr, name, where))
1127 /* Duplicate attribute already checked for. */
1128 attr->in_common = 1;
1129 if (check_conflict (attr, name, where) == FAILURE)
1132 if (attr->flavor == FL_VARIABLE)
1135 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1140 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1143 /* Duplicate attribute already checked for. */
1144 attr->in_equivalence = 1;
1145 if (check_conflict (attr, name, where) == FAILURE)
1148 if (attr->flavor == FL_VARIABLE)
1151 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1156 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1159 if (check_used (attr, name, where))
1163 return check_conflict (attr, name, where);
1168 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1171 attr->in_namelist = 1;
1172 return check_conflict (attr, name, where);
1177 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1180 if (check_used (attr, name, where))
1184 return check_conflict (attr, name, where);
1189 gfc_add_elemental (symbol_attribute *attr, locus *where)
1192 if (check_used (attr, NULL, where))
1195 if (attr->elemental)
1197 duplicate_attr ("ELEMENTAL", where);
1201 attr->elemental = 1;
1202 return check_conflict (attr, NULL, where);
1207 gfc_add_pure (symbol_attribute *attr, locus *where)
1210 if (check_used (attr, NULL, where))
1215 duplicate_attr ("PURE", where);
1220 return check_conflict (attr, NULL, where);
1225 gfc_add_recursive (symbol_attribute *attr, locus *where)
1228 if (check_used (attr, NULL, where))
1231 if (attr->recursive)
1233 duplicate_attr ("RECURSIVE", where);
1237 attr->recursive = 1;
1238 return check_conflict (attr, NULL, where);
1243 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1246 if (check_used (attr, name, where))
1251 duplicate_attr ("ENTRY", where);
1256 return check_conflict (attr, name, where);
1261 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1264 if (attr->flavor != FL_PROCEDURE
1265 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1269 return check_conflict (attr, name, where);
1274 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1277 if (attr->flavor != FL_PROCEDURE
1278 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1281 attr->subroutine = 1;
1282 return check_conflict (attr, name, where);
1287 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1290 if (attr->flavor != FL_PROCEDURE
1291 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1295 return check_conflict (attr, name, where);
1300 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1303 if (check_used (attr, NULL, where))
1306 if (attr->flavor != FL_PROCEDURE
1307 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1310 if (attr->procedure)
1312 duplicate_attr ("PROCEDURE", where);
1316 attr->procedure = 1;
1318 return check_conflict (attr, NULL, where);
1322 /* Flavors are special because some flavors are not what Fortran
1323 considers attributes and can be reaffirmed multiple times. */
1326 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1330 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1331 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1332 || f == FL_NAMELIST) && check_used (attr, name, where))
1335 if (attr->flavor == f && f == FL_VARIABLE)
1338 if (attr->flavor != FL_UNKNOWN)
1341 where = &gfc_current_locus;
1344 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1345 gfc_code2string (flavors, attr->flavor), name,
1346 gfc_code2string (flavors, f), where);
1348 gfc_error ("%s attribute conflicts with %s attribute at %L",
1349 gfc_code2string (flavors, attr->flavor),
1350 gfc_code2string (flavors, f), where);
1357 return check_conflict (attr, name, where);
1362 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1363 const char *name, locus *where)
1366 if (check_used (attr, name, where))
1369 if (attr->flavor != FL_PROCEDURE
1370 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1374 where = &gfc_current_locus;
1376 if (attr->proc != PROC_UNKNOWN)
1378 gfc_error ("%s procedure at %L is already declared as %s procedure",
1379 gfc_code2string (procedures, t), where,
1380 gfc_code2string (procedures, attr->proc));
1387 /* Statement functions are always scalar and functions. */
1388 if (t == PROC_ST_FUNCTION
1389 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1390 || attr->dimension))
1393 return check_conflict (attr, name, where);
1398 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1401 if (check_used (attr, NULL, where))
1404 if (attr->intent == INTENT_UNKNOWN)
1406 attr->intent = intent;
1407 return check_conflict (attr, NULL, where);
1411 where = &gfc_current_locus;
1413 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1414 gfc_intent_string (attr->intent),
1415 gfc_intent_string (intent), where);
1421 /* No checks for use-association in public and private statements. */
1424 gfc_add_access (symbol_attribute *attr, gfc_access access,
1425 const char *name, locus *where)
1428 if (attr->access == ACCESS_UNKNOWN)
1430 attr->access = access;
1431 return check_conflict (attr, name, where);
1435 where = &gfc_current_locus;
1436 gfc_error ("ACCESS specification at %L was already specified", where);
1442 /* Set the is_bind_c field for the given symbol_attribute. */
1445 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1446 int is_proc_lang_bind_spec)
1449 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1450 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1451 "variables or common blocks", where);
1452 else if (attr->is_bind_c)
1453 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1455 attr->is_bind_c = 1;
1458 where = &gfc_current_locus;
1460 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1464 return check_conflict (attr, name, where);
1468 /* Set the extension field for the given symbol_attribute. */
1471 gfc_add_extension (symbol_attribute *attr, locus *where)
1474 where = &gfc_current_locus;
1476 if (attr->extension)
1477 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1479 attr->extension = 1;
1481 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
1490 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1491 gfc_formal_arglist * formal, locus *where)
1494 if (check_used (&sym->attr, sym->name, where))
1498 where = &gfc_current_locus;
1500 if (sym->attr.if_source != IFSRC_UNKNOWN
1501 && sym->attr.if_source != IFSRC_DECL)
1503 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1508 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1510 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1511 "body", sym->name, where);
1515 sym->formal = formal;
1516 sym->attr.if_source = source;
1522 /* Add a type to a symbol. */
1525 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1530 where = &gfc_current_locus;
1532 if (sym->ts.type != BT_UNKNOWN)
1534 const char *msg = "Symbol '%s' at %L already has basic type of %s";
1535 if (!(sym->ts.type == ts->type
1536 && (sym->attr.flavor == FL_PROCEDURE || sym->attr.result))
1537 || gfc_notification_std (GFC_STD_GNU) == ERROR
1540 gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1543 if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where,
1544 gfc_basic_typename (sym->ts.type)) == FAILURE)
1546 if (gfc_option.warn_surprising)
1547 gfc_warning (msg, sym->name, where, gfc_basic_typename (sym->ts.type));
1550 flavor = sym->attr.flavor;
1552 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1553 || flavor == FL_LABEL
1554 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1555 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1557 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1566 /* Clears all attributes. */
1569 gfc_clear_attr (symbol_attribute *attr)
1571 memset (attr, 0, sizeof (symbol_attribute));
1575 /* Check for missing attributes in the new symbol. Currently does
1576 nothing, but it's not clear that it is unnecessary yet. */
1579 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1580 locus *where ATTRIBUTE_UNUSED)
1587 /* Copy an attribute to a symbol attribute, bit by bit. Some
1588 attributes have a lot of side-effects but cannot be present given
1589 where we are called from, so we ignore some bits. */
1592 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1594 int is_proc_lang_bind_spec;
1596 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1599 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1601 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1603 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1605 if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1607 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1609 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1611 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1613 if (src->threadprivate
1614 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1616 if (src->target && gfc_add_target (dest, where) == FAILURE)
1618 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1620 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1625 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1628 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1631 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1633 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1635 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1638 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1640 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1642 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1644 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1647 if (src->flavor != FL_UNKNOWN
1648 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1651 if (src->intent != INTENT_UNKNOWN
1652 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1655 if (src->access != ACCESS_UNKNOWN
1656 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1659 if (gfc_missing_attr (dest, where) == FAILURE)
1662 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1664 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1667 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1669 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1673 if (src->is_c_interop)
1674 dest->is_c_interop = 1;
1678 if (src->external && gfc_add_external (dest, where) == FAILURE)
1680 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1682 if (src->proc_pointer)
1683 dest->proc_pointer = 1;
1692 /************** Component name management ************/
1694 /* Component names of a derived type form their own little namespaces
1695 that are separate from all other spaces. The space is composed of
1696 a singly linked list of gfc_component structures whose head is
1697 located in the parent symbol. */
1700 /* Add a component name to a symbol. The call fails if the name is
1701 already present. On success, the component pointer is modified to
1702 point to the additional component structure. */
1705 gfc_add_component (gfc_symbol *sym, const char *name,
1706 gfc_component **component)
1708 gfc_component *p, *tail;
1712 for (p = sym->components; p; p = p->next)
1714 if (strcmp (p->name, name) == 0)
1716 gfc_error ("Component '%s' at %C already declared at %L",
1724 if (sym->attr.extension
1725 && gfc_find_component (sym->components->ts.derived, name, true, true))
1727 gfc_error ("Component '%s' at %C already in the parent type "
1728 "at %L", name, &sym->components->ts.derived->declared_at);
1732 /* Allocate a new component. */
1733 p = gfc_get_component ();
1736 sym->components = p;
1740 p->name = gfc_get_string (name);
1741 p->loc = gfc_current_locus;
1748 /* Recursive function to switch derived types of all symbol in a
1752 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1760 if (sym->ts.type == BT_DERIVED && sym->ts.derived == from)
1761 sym->ts.derived = to;
1763 switch_types (st->left, from, to);
1764 switch_types (st->right, from, to);
1768 /* This subroutine is called when a derived type is used in order to
1769 make the final determination about which version to use. The
1770 standard requires that a type be defined before it is 'used', but
1771 such types can appear in IMPLICIT statements before the actual
1772 definition. 'Using' in this context means declaring a variable to
1773 be that type or using the type constructor.
1775 If a type is used and the components haven't been defined, then we
1776 have to have a derived type in a parent unit. We find the node in
1777 the other namespace and point the symtree node in this namespace to
1778 that node. Further reference to this name point to the correct
1779 node. If we can't find the node in a parent namespace, then we have
1782 This subroutine takes a pointer to a symbol node and returns a
1783 pointer to the translated node or NULL for an error. Usually there
1784 is no translation and we return the node we were passed. */
1787 gfc_use_derived (gfc_symbol *sym)
1794 if (sym->components != NULL || sym->attr.zero_comp)
1795 return sym; /* Already defined. */
1797 if (sym->ns->parent == NULL)
1800 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1802 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1806 if (s == NULL || s->attr.flavor != FL_DERIVED)
1809 /* Get rid of symbol sym, translating all references to s. */
1810 for (i = 0; i < GFC_LETTERS; i++)
1812 t = &sym->ns->default_type[i];
1813 if (t->derived == sym)
1817 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1822 /* Unlink from list of modified symbols. */
1823 gfc_commit_symbol (sym);
1825 switch_types (sym->ns->sym_root, sym, s);
1827 /* TODO: Also have to replace sym -> s in other lists like
1828 namelists, common lists and interface lists. */
1829 gfc_free_symbol (sym);
1834 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1840 /* Given a derived type node and a component name, try to locate the
1841 component structure. Returns the NULL pointer if the component is
1842 not found or the components are private. If noaccess is set, no access
1846 gfc_find_component (gfc_symbol *sym, const char *name,
1847 bool noaccess, bool silent)
1854 sym = gfc_use_derived (sym);
1859 for (p = sym->components; p; p = p->next)
1860 if (strcmp (p->name, name) == 0)
1864 && sym->attr.extension
1865 && sym->components->ts.type == BT_DERIVED)
1867 p = gfc_find_component (sym->components->ts.derived, name,
1869 /* Do not overwrite the error. */
1874 if (p == NULL && !silent)
1875 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1878 else if (sym->attr.use_assoc && !noaccess)
1880 if (p->attr.access == ACCESS_PRIVATE)
1883 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
1888 /* If there were components given and all components are private, error
1889 out at this place. */
1890 if (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
1893 gfc_error ("All components of '%s' are PRIVATE in structure"
1894 " constructor at %C", sym->name);
1903 /* Given a symbol, free all of the component structures and everything
1907 free_components (gfc_component *p)
1915 gfc_free_array_spec (p->as);
1916 gfc_free_expr (p->initializer);
1923 /******************** Statement label management ********************/
1925 /* Comparison function for statement labels, used for managing the
1929 compare_st_labels (void *a1, void *b1)
1931 int a = ((gfc_st_label *) a1)->value;
1932 int b = ((gfc_st_label *) b1)->value;
1938 /* Free a single gfc_st_label structure, making sure the tree is not
1939 messed up. This function is called only when some parse error
1943 gfc_free_st_label (gfc_st_label *label)
1949 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
1951 if (label->format != NULL)
1952 gfc_free_expr (label->format);
1958 /* Free a whole tree of gfc_st_label structures. */
1961 free_st_labels (gfc_st_label *label)
1967 free_st_labels (label->left);
1968 free_st_labels (label->right);
1970 if (label->format != NULL)
1971 gfc_free_expr (label->format);
1976 /* Given a label number, search for and return a pointer to the label
1977 structure, creating it if it does not exist. */
1980 gfc_get_st_label (int labelno)
1984 /* First see if the label is already in this namespace. */
1985 lp = gfc_current_ns->st_labels;
1988 if (lp->value == labelno)
1991 if (lp->value < labelno)
1997 lp = XCNEW (gfc_st_label);
1999 lp->value = labelno;
2000 lp->defined = ST_LABEL_UNKNOWN;
2001 lp->referenced = ST_LABEL_UNKNOWN;
2003 gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels);
2009 /* Called when a statement with a statement label is about to be
2010 accepted. We add the label to the list of the current namespace,
2011 making sure it hasn't been defined previously and referenced
2015 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2019 labelno = lp->value;
2021 if (lp->defined != ST_LABEL_UNKNOWN)
2022 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2023 &lp->where, label_locus);
2026 lp->where = *label_locus;
2030 case ST_LABEL_FORMAT:
2031 if (lp->referenced == ST_LABEL_TARGET)
2032 gfc_error ("Label %d at %C already referenced as branch target",
2035 lp->defined = ST_LABEL_FORMAT;
2039 case ST_LABEL_TARGET:
2040 if (lp->referenced == ST_LABEL_FORMAT)
2041 gfc_error ("Label %d at %C already referenced as a format label",
2044 lp->defined = ST_LABEL_TARGET;
2049 lp->defined = ST_LABEL_BAD_TARGET;
2050 lp->referenced = ST_LABEL_BAD_TARGET;
2056 /* Reference a label. Given a label and its type, see if that
2057 reference is consistent with what is known about that label,
2058 updating the unknown state. Returns FAILURE if something goes
2062 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2064 gfc_sl_type label_type;
2071 labelno = lp->value;
2073 if (lp->defined != ST_LABEL_UNKNOWN)
2074 label_type = lp->defined;
2077 label_type = lp->referenced;
2078 lp->where = gfc_current_locus;
2081 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2083 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2088 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2089 && type == ST_LABEL_FORMAT)
2091 gfc_error ("Label %d at %C previously used as branch target", labelno);
2096 lp->referenced = type;
2104 /*******A helper function for creating new expressions*************/
2108 gfc_lval_expr_from_sym (gfc_symbol *sym)
2111 lval = gfc_get_expr ();
2112 lval->expr_type = EXPR_VARIABLE;
2113 lval->where = sym->declared_at;
2115 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2117 /* It will always be a full array. */
2118 lval->rank = sym->as ? sym->as->rank : 0;
2121 lval->ref = gfc_get_ref ();
2122 lval->ref->type = REF_ARRAY;
2123 lval->ref->u.ar.type = AR_FULL;
2124 lval->ref->u.ar.dimen = lval->rank;
2125 lval->ref->u.ar.where = sym->declared_at;
2126 lval->ref->u.ar.as = sym->as;
2133 /************** Symbol table management subroutines ****************/
2135 /* Basic details: Fortran 95 requires a potentially unlimited number
2136 of distinct namespaces when compiling a program unit. This case
2137 occurs during a compilation of internal subprograms because all of
2138 the internal subprograms must be read before we can start
2139 generating code for the host.
2141 Given the tricky nature of the Fortran grammar, we must be able to
2142 undo changes made to a symbol table if the current interpretation
2143 of a statement is found to be incorrect. Whenever a symbol is
2144 looked up, we make a copy of it and link to it. All of these
2145 symbols are kept in a singly linked list so that we can commit or
2146 undo the changes at a later time.
2148 A symtree may point to a symbol node outside of its namespace. In
2149 this case, that symbol has been used as a host associated variable
2150 at some previous time. */
2152 /* Allocate a new namespace structure. Copies the implicit types from
2153 PARENT if PARENT_TYPES is set. */
2156 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2160 gfc_intrinsic_op in;
2163 ns = XCNEW (gfc_namespace);
2164 ns->sym_root = NULL;
2165 ns->uop_root = NULL;
2166 ns->finalizers = NULL;
2167 ns->default_access = ACCESS_UNKNOWN;
2168 ns->parent = parent;
2170 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2171 ns->operator_access[in] = ACCESS_UNKNOWN;
2173 /* Initialize default implicit types. */
2174 for (i = 'a'; i <= 'z'; i++)
2176 ns->set_flag[i - 'a'] = 0;
2177 ts = &ns->default_type[i - 'a'];
2179 if (parent_types && ns->parent != NULL)
2181 /* Copy parent settings. */
2182 *ts = ns->parent->default_type[i - 'a'];
2186 if (gfc_option.flag_implicit_none != 0)
2192 if ('i' <= i && i <= 'n')
2194 ts->type = BT_INTEGER;
2195 ts->kind = gfc_default_integer_kind;
2200 ts->kind = gfc_default_real_kind;
2210 /* Comparison function for symtree nodes. */
2213 compare_symtree (void *_st1, void *_st2)
2215 gfc_symtree *st1, *st2;
2217 st1 = (gfc_symtree *) _st1;
2218 st2 = (gfc_symtree *) _st2;
2220 return strcmp (st1->name, st2->name);
2224 /* Allocate a new symtree node and associate it with the new symbol. */
2227 gfc_new_symtree (gfc_symtree **root, const char *name)
2231 st = XCNEW (gfc_symtree);
2232 st->name = gfc_get_string (name);
2233 st->typebound = NULL;
2235 gfc_insert_bbt (root, st, compare_symtree);
2240 /* Delete a symbol from the tree. Does not free the symbol itself! */
2243 gfc_delete_symtree (gfc_symtree **root, const char *name)
2245 gfc_symtree st, *st0;
2247 st0 = gfc_find_symtree (*root, name);
2249 st.name = gfc_get_string (name);
2250 gfc_delete_bbt (root, &st, compare_symtree);
2256 /* Given a root symtree node and a name, try to find the symbol within
2257 the namespace. Returns NULL if the symbol is not found. */
2260 gfc_find_symtree (gfc_symtree *st, const char *name)
2266 c = strcmp (name, st->name);
2270 st = (c < 0) ? st->left : st->right;
2277 /* Return a symtree node with a name that is guaranteed to be unique
2278 within the namespace and corresponds to an illegal fortran name. */
2281 gfc_get_unique_symtree (gfc_namespace *ns)
2283 char name[GFC_MAX_SYMBOL_LEN + 1];
2284 static int serial = 0;
2286 sprintf (name, "@%d", serial++);
2287 return gfc_new_symtree (&ns->sym_root, name);
2291 /* Given a name find a user operator node, creating it if it doesn't
2292 exist. These are much simpler than symbols because they can't be
2293 ambiguous with one another. */
2296 gfc_get_uop (const char *name)
2301 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2305 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2307 uop = st->n.uop = XCNEW (gfc_user_op);
2308 uop->name = gfc_get_string (name);
2309 uop->access = ACCESS_UNKNOWN;
2310 uop->ns = gfc_current_ns;
2316 /* Given a name find the user operator node. Returns NULL if it does
2320 gfc_find_uop (const char *name, gfc_namespace *ns)
2325 ns = gfc_current_ns;
2327 st = gfc_find_symtree (ns->uop_root, name);
2328 return (st == NULL) ? NULL : st->n.uop;
2332 /* Remove a gfc_symbol structure and everything it points to. */
2335 gfc_free_symbol (gfc_symbol *sym)
2341 gfc_free_array_spec (sym->as);
2343 free_components (sym->components);
2345 gfc_free_expr (sym->value);
2347 gfc_free_namelist (sym->namelist);
2349 gfc_free_namespace (sym->formal_ns);
2351 if (!sym->attr.generic_copy)
2352 gfc_free_interface (sym->generic);
2354 gfc_free_formal_arglist (sym->formal);
2356 gfc_free_namespace (sym->f2k_derived);
2362 /* Allocate and initialize a new symbol node. */
2365 gfc_new_symbol (const char *name, gfc_namespace *ns)
2369 p = XCNEW (gfc_symbol);
2371 gfc_clear_ts (&p->ts);
2372 gfc_clear_attr (&p->attr);
2375 p->declared_at = gfc_current_locus;
2377 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2378 gfc_internal_error ("new_symbol(): Symbol name too long");
2380 p->name = gfc_get_string (name);
2382 /* Make sure flags for symbol being C bound are clear initially. */
2383 p->attr.is_bind_c = 0;
2384 p->attr.is_iso_c = 0;
2385 /* Make sure the binding label field has a Nul char to start. */
2386 p->binding_label[0] = '\0';
2388 /* Clear the ptrs we may need. */
2389 p->common_block = NULL;
2390 p->f2k_derived = NULL;
2396 /* Generate an error if a symbol is ambiguous. */
2399 ambiguous_symbol (const char *name, gfc_symtree *st)
2402 if (st->n.sym->module)
2403 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2404 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2406 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2407 "from current program unit", name, st->n.sym->name);
2411 /* Search for a symtree starting in the current namespace, resorting to
2412 any parent namespaces if requested by a nonzero parent_flag.
2413 Returns nonzero if the name is ambiguous. */
2416 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2417 gfc_symtree **result)
2422 ns = gfc_current_ns;
2426 st = gfc_find_symtree (ns->sym_root, name);
2430 /* Ambiguous generic interfaces are permitted, as long
2431 as the specific interfaces are different. */
2432 if (st->ambiguous && !st->n.sym->attr.generic)
2434 ambiguous_symbol (name, st);
2453 /* Same, but returns the symbol instead. */
2456 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2457 gfc_symbol **result)
2462 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2467 *result = st->n.sym;
2473 /* Save symbol with the information necessary to back it out. */
2476 save_symbol_data (gfc_symbol *sym)
2479 if (sym->gfc_new || sym->old_symbol != NULL)
2482 sym->old_symbol = XCNEW (gfc_symbol);
2483 *(sym->old_symbol) = *sym;
2485 sym->tlink = changed_syms;
2490 /* Given a name, find a symbol, or create it if it does not exist yet
2491 in the current namespace. If the symbol is found we make sure that
2494 The integer return code indicates
2496 1 The symbol name was ambiguous
2497 2 The name meant to be established was already host associated.
2499 So if the return value is nonzero, then an error was issued. */
2502 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result)
2507 /* This doesn't usually happen during resolution. */
2509 ns = gfc_current_ns;
2511 /* Try to find the symbol in ns. */
2512 st = gfc_find_symtree (ns->sym_root, name);
2516 /* If not there, create a new symbol. */
2517 p = gfc_new_symbol (name, ns);
2519 /* Add to the list of tentative symbols. */
2520 p->old_symbol = NULL;
2521 p->tlink = changed_syms;
2526 st = gfc_new_symtree (&ns->sym_root, name);
2533 /* Make sure the existing symbol is OK. Ambiguous
2534 generic interfaces are permitted, as long as the
2535 specific interfaces are different. */
2536 if (st->ambiguous && !st->n.sym->attr.generic)
2538 ambiguous_symbol (name, st);
2544 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2546 && ns->proc_name->attr.if_source == IFSRC_IFBODY
2547 && (ns->has_import_set || p->attr.imported)))
2549 /* Symbol is from another namespace. */
2550 gfc_error ("Symbol '%s' at %C has already been host associated",
2557 /* Copy in case this symbol is changed. */
2558 save_symbol_data (p);
2567 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2572 i = gfc_get_sym_tree (name, ns, &st);
2577 *result = st->n.sym;
2584 /* Subroutine that searches for a symbol, creating it if it doesn't
2585 exist, but tries to host-associate the symbol if possible. */
2588 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2593 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2596 save_symbol_data (st->n.sym);
2601 if (gfc_current_ns->parent != NULL)
2603 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2614 return gfc_get_sym_tree (name, gfc_current_ns, result);
2619 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2624 i = gfc_get_ha_sym_tree (name, &st);
2627 *result = st->n.sym;
2634 /* Return true if both symbols could refer to the same data object. Does
2635 not take account of aliasing due to equivalence statements. */
2638 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2640 /* Aliasing isn't possible if the symbols have different base types. */
2641 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2644 /* Pointers can point to other pointers, target objects and allocatable
2645 objects. Two allocatable objects cannot share the same storage. */
2646 if (lsym->attr.pointer
2647 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2649 if (lsym->attr.target && rsym->attr.pointer)
2651 if (lsym->attr.allocatable && rsym->attr.pointer)
2658 /* Undoes all the changes made to symbols in the current statement.
2659 This subroutine is made simpler due to the fact that attributes are
2660 never removed once added. */
2663 gfc_undo_symbols (void)
2665 gfc_symbol *p, *q, *old;
2667 for (p = changed_syms; p; p = q)
2673 /* Symbol was new. */
2674 if (p->attr.in_common && p->common_block->head)
2676 /* If the symbol was added to any common block, it
2677 needs to be removed to stop the resolver looking
2678 for a (possibly) dead symbol. */
2680 if (p->common_block->head == p)
2681 p->common_block->head = p->common_next;
2684 gfc_symbol *cparent, *csym;
2686 cparent = p->common_block->head;
2687 csym = cparent->common_next;
2692 csym = csym->common_next;
2695 gcc_assert(cparent->common_next == p);
2697 cparent->common_next = csym->common_next;
2701 gfc_delete_symtree (&p->ns->sym_root, p->name);
2705 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2707 gfc_free_symbol (p);
2711 /* Restore previous state of symbol. Just copy simple stuff. */
2713 old = p->old_symbol;
2715 p->ts.type = old->ts.type;
2716 p->ts.kind = old->ts.kind;
2718 p->attr = old->attr;
2720 if (p->value != old->value)
2722 gfc_free_expr (old->value);
2726 if (p->as != old->as)
2729 gfc_free_array_spec (p->as);
2733 p->generic = old->generic;
2734 p->component_access = old->component_access;
2736 if (p->namelist != NULL && old->namelist == NULL)
2738 gfc_free_namelist (p->namelist);
2743 if (p->namelist_tail != old->namelist_tail)
2745 gfc_free_namelist (old->namelist_tail);
2746 old->namelist_tail->next = NULL;
2750 p->namelist_tail = old->namelist_tail;
2752 if (p->formal != old->formal)
2754 gfc_free_formal_arglist (p->formal);
2755 p->formal = old->formal;
2758 gfc_free (p->old_symbol);
2759 p->old_symbol = NULL;
2763 changed_syms = NULL;
2767 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2768 components of old_symbol that might need deallocation are the "allocatables"
2769 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2770 namelist_tail. In case these differ between old_symbol and sym, it's just
2771 because sym->namelist has gotten a few more items. */
2774 free_old_symbol (gfc_symbol *sym)
2777 if (sym->old_symbol == NULL)
2780 if (sym->old_symbol->as != sym->as)
2781 gfc_free_array_spec (sym->old_symbol->as);
2783 if (sym->old_symbol->value != sym->value)
2784 gfc_free_expr (sym->old_symbol->value);
2786 if (sym->old_symbol->formal != sym->formal)
2787 gfc_free_formal_arglist (sym->old_symbol->formal);
2789 gfc_free (sym->old_symbol);
2790 sym->old_symbol = NULL;
2794 /* Makes the changes made in the current statement permanent-- gets
2795 rid of undo information. */
2798 gfc_commit_symbols (void)
2802 for (p = changed_syms; p; p = q)
2808 free_old_symbol (p);
2810 changed_syms = NULL;
2814 /* Makes the changes made in one symbol permanent -- gets rid of undo
2818 gfc_commit_symbol (gfc_symbol *sym)
2822 if (changed_syms == sym)
2823 changed_syms = sym->tlink;
2826 for (p = changed_syms; p; p = p->tlink)
2827 if (p->tlink == sym)
2829 p->tlink = sym->tlink;
2838 free_old_symbol (sym);
2842 /* Recursive function that deletes an entire tree and all the common
2843 head structures it points to. */
2846 free_common_tree (gfc_symtree * common_tree)
2848 if (common_tree == NULL)
2851 free_common_tree (common_tree->left);
2852 free_common_tree (common_tree->right);
2854 gfc_free (common_tree);
2858 /* Recursive function that deletes an entire tree and all the user
2859 operator nodes that it contains. */
2862 free_uop_tree (gfc_symtree *uop_tree)
2865 if (uop_tree == NULL)
2868 free_uop_tree (uop_tree->left);
2869 free_uop_tree (uop_tree->right);
2871 gfc_free_interface (uop_tree->n.uop->op);
2873 gfc_free (uop_tree->n.uop);
2874 gfc_free (uop_tree);
2878 /* Recursive function that deletes an entire tree and all the symbols
2879 that it contains. */
2882 free_sym_tree (gfc_symtree *sym_tree)
2887 if (sym_tree == NULL)
2890 free_sym_tree (sym_tree->left);
2891 free_sym_tree (sym_tree->right);
2893 sym = sym_tree->n.sym;
2897 gfc_internal_error ("free_sym_tree(): Negative refs");
2899 if (sym->formal_ns != NULL && sym->refs == 1)
2901 /* As formal_ns contains a reference to sym, delete formal_ns just
2902 before the deletion of sym. */
2903 ns = sym->formal_ns;
2904 sym->formal_ns = NULL;
2905 gfc_free_namespace (ns);
2907 else if (sym->refs == 0)
2909 /* Go ahead and delete the symbol. */
2910 gfc_free_symbol (sym);
2913 gfc_free (sym_tree);
2917 /* Free the derived type list. */
2920 gfc_free_dt_list (void)
2922 gfc_dt_list *dt, *n;
2924 for (dt = gfc_derived_types; dt; dt = n)
2930 gfc_derived_types = NULL;
2934 /* Free the gfc_equiv_info's. */
2937 gfc_free_equiv_infos (gfc_equiv_info *s)
2941 gfc_free_equiv_infos (s->next);
2946 /* Free the gfc_equiv_lists. */
2949 gfc_free_equiv_lists (gfc_equiv_list *l)
2953 gfc_free_equiv_lists (l->next);
2954 gfc_free_equiv_infos (l->equiv);
2959 /* Free a finalizer procedure list. */
2962 gfc_free_finalizer (gfc_finalizer* el)
2968 --el->proc_sym->refs;
2969 if (!el->proc_sym->refs)
2970 gfc_free_symbol (el->proc_sym);
2978 gfc_free_finalizer_list (gfc_finalizer* list)
2982 gfc_finalizer* current = list;
2984 gfc_free_finalizer (current);
2989 /* Free a namespace structure and everything below it. Interface
2990 lists associated with intrinsic operators are not freed. These are
2991 taken care of when a specific name is freed. */
2994 gfc_free_namespace (gfc_namespace *ns)
2996 gfc_charlen *cl, *cl2;
2997 gfc_namespace *p, *q;
3006 gcc_assert (ns->refs == 0);
3008 gfc_free_statements (ns->code);
3010 free_sym_tree (ns->sym_root);
3011 free_uop_tree (ns->uop_root);
3012 free_common_tree (ns->common_root);
3013 gfc_free_finalizer_list (ns->finalizers);
3015 for (cl = ns->cl_list; cl; cl = cl2)
3018 gfc_free_expr (cl->length);
3022 free_st_labels (ns->st_labels);
3024 gfc_free_equiv (ns->equiv);
3025 gfc_free_equiv_lists (ns->equiv_lists);
3026 gfc_free_use_stmts (ns->use_stmts);
3028 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3029 gfc_free_interface (ns->op[i]);
3031 gfc_free_data (ns->data);
3035 /* Recursively free any contained namespaces. */
3040 gfc_free_namespace (q);
3046 gfc_symbol_init_2 (void)
3049 gfc_current_ns = gfc_get_namespace (NULL, 0);
3054 gfc_symbol_done_2 (void)
3057 gfc_free_namespace (gfc_current_ns);
3058 gfc_current_ns = NULL;
3059 gfc_free_dt_list ();
3063 /* Clear mark bits from symbol nodes associated with a symtree node. */
3066 clear_sym_mark (gfc_symtree *st)
3069 st->n.sym->mark = 0;
3073 /* Recursively traverse the symtree nodes. */
3076 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
3081 gfc_traverse_symtree (st->left, func);
3083 gfc_traverse_symtree (st->right, func);
3087 /* Recursive namespace traversal function. */
3090 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
3096 traverse_ns (st->left, func);
3098 if (st->n.sym->mark == 0)
3099 (*func) (st->n.sym);
3100 st->n.sym->mark = 1;
3102 traverse_ns (st->right, func);
3106 /* Call a given function for all symbols in the namespace. We take
3107 care that each gfc_symbol node is called exactly once. */
3110 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3113 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3115 traverse_ns (ns->sym_root, func);
3119 /* Return TRUE when name is the name of an intrinsic type. */
3122 gfc_is_intrinsic_typename (const char *name)
3124 if (strcmp (name, "integer") == 0
3125 || strcmp (name, "real") == 0
3126 || strcmp (name, "character") == 0
3127 || strcmp (name, "logical") == 0
3128 || strcmp (name, "complex") == 0
3129 || strcmp (name, "doubleprecision") == 0
3130 || strcmp (name, "doublecomplex") == 0)
3137 /* Return TRUE if the symbol is an automatic variable. */
3140 gfc_is_var_automatic (gfc_symbol *sym)
3142 /* Pointer and allocatable variables are never automatic. */
3143 if (sym->attr.pointer || sym->attr.allocatable)
3145 /* Check for arrays with non-constant size. */
3146 if (sym->attr.dimension && sym->as
3147 && !gfc_is_compile_time_shape (sym->as))
3149 /* Check for non-constant length character variables. */
3150 if (sym->ts.type == BT_CHARACTER
3152 && !gfc_is_constant_expr (sym->ts.cl->length))
3157 /* Given a symbol, mark it as SAVEd if it is allowed. */
3160 save_symbol (gfc_symbol *sym)
3163 if (sym->attr.use_assoc)
3166 if (sym->attr.in_common
3168 || sym->attr.flavor != FL_VARIABLE)
3170 /* Automatic objects are not saved. */
3171 if (gfc_is_var_automatic (sym))
3173 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3177 /* Mark those symbols which can be SAVEd as such. */
3180 gfc_save_all (gfc_namespace *ns)
3183 gfc_traverse_ns (ns, save_symbol);
3188 /* Make sure that no changes to symbols are pending. */
3191 gfc_symbol_state(void) {
3193 if (changed_syms != NULL)
3194 gfc_internal_error("Symbol changes still pending!");
3199 /************** Global symbol handling ************/
3202 /* Search a tree for the global symbol. */
3205 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3214 c = strcmp (name, symbol->name);
3218 symbol = (c < 0) ? symbol->left : symbol->right;
3225 /* Compare two global symbols. Used for managing the BB tree. */
3228 gsym_compare (void *_s1, void *_s2)
3230 gfc_gsymbol *s1, *s2;
3232 s1 = (gfc_gsymbol *) _s1;
3233 s2 = (gfc_gsymbol *) _s2;
3234 return strcmp (s1->name, s2->name);
3238 /* Get a global symbol, creating it if it doesn't exist. */
3241 gfc_get_gsymbol (const char *name)
3245 s = gfc_find_gsymbol (gfc_gsym_root, name);
3249 s = XCNEW (gfc_gsymbol);
3250 s->type = GSYM_UNKNOWN;
3251 s->name = gfc_get_string (name);
3253 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3260 get_iso_c_binding_dt (int sym_id)
3262 gfc_dt_list *dt_list;
3264 dt_list = gfc_derived_types;
3266 /* Loop through the derived types in the name list, searching for
3267 the desired symbol from iso_c_binding. Search the parent namespaces
3268 if necessary and requested to (parent_flag). */
3269 while (dt_list != NULL)
3271 if (dt_list->derived->from_intmod != INTMOD_NONE
3272 && dt_list->derived->intmod_sym_id == sym_id)
3273 return dt_list->derived;
3275 dt_list = dt_list->next;
3282 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3283 with C. This is necessary for any derived type that is BIND(C) and for
3284 derived types that are parameters to functions that are BIND(C). All
3285 fields of the derived type are required to be interoperable, and are tested
3286 for such. If an error occurs, the errors are reported here, allowing for
3287 multiple errors to be handled for a single derived type. */
3290 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3292 gfc_component *curr_comp = NULL;
3293 gfc_try is_c_interop = FAILURE;
3294 gfc_try retval = SUCCESS;
3296 if (derived_sym == NULL)
3297 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3298 "unexpectedly NULL");
3300 /* If we've already looked at this derived symbol, do not look at it again
3301 so we don't repeat warnings/errors. */
3302 if (derived_sym->ts.is_c_interop)
3305 /* The derived type must have the BIND attribute to be interoperable
3306 J3/04-007, Section 15.2.3. */
3307 if (derived_sym->attr.is_bind_c != 1)
3309 derived_sym->ts.is_c_interop = 0;
3310 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3311 "attribute to be C interoperable", derived_sym->name,
3312 &(derived_sym->declared_at));
3316 curr_comp = derived_sym->components;
3318 /* TODO: is this really an error? */
3319 if (curr_comp == NULL)
3321 gfc_error ("Derived type '%s' at %L is empty",
3322 derived_sym->name, &(derived_sym->declared_at));
3326 /* Initialize the derived type as being C interoperable.
3327 If we find an error in the components, this will be set false. */
3328 derived_sym->ts.is_c_interop = 1;
3330 /* Loop through the list of components to verify that the kind of
3331 each is a C interoperable type. */
3334 /* The components cannot be pointers (fortran sense).
3335 J3/04-007, Section 15.2.3, C1505. */
3336 if (curr_comp->attr.pointer != 0)
3338 gfc_error ("Component '%s' at %L cannot have the "
3339 "POINTER attribute because it is a member "
3340 "of the BIND(C) derived type '%s' at %L",
3341 curr_comp->name, &(curr_comp->loc),
3342 derived_sym->name, &(derived_sym->declared_at));
3346 /* The components cannot be allocatable.
3347 J3/04-007, Section 15.2.3, C1505. */
3348 if (curr_comp->attr.allocatable != 0)
3350 gfc_error ("Component '%s' at %L cannot have the "
3351 "ALLOCATABLE attribute because it is a member "
3352 "of the BIND(C) derived type '%s' at %L",
3353 curr_comp->name, &(curr_comp->loc),
3354 derived_sym->name, &(derived_sym->declared_at));
3358 /* BIND(C) derived types must have interoperable components. */
3359 if (curr_comp->ts.type == BT_DERIVED
3360 && curr_comp->ts.derived->ts.is_iso_c != 1
3361 && curr_comp->ts.derived != derived_sym)
3363 /* This should be allowed; the draft says a derived-type can not
3364 have type parameters if it is has the BIND attribute. Type
3365 parameters seem to be for making parameterized derived types.
3366 There's no need to verify the type if it is c_ptr/c_funptr. */
3367 retval = verify_bind_c_derived_type (curr_comp->ts.derived);
3371 /* Grab the typespec for the given component and test the kind. */
3372 is_c_interop = verify_c_interop (&(curr_comp->ts), curr_comp->name,
3375 if (is_c_interop != SUCCESS)
3377 /* Report warning and continue since not fatal. The
3378 draft does specify a constraint that requires all fields
3379 to interoperate, but if the user says real(4), etc., it
3380 may interoperate with *something* in C, but the compiler
3381 most likely won't know exactly what. Further, it may not
3382 interoperate with the same data type(s) in C if the user
3383 recompiles with different flags (e.g., -m32 and -m64 on
3384 x86_64 and using integer(4) to claim interop with a
3386 if (derived_sym->attr.is_bind_c == 1)
3387 /* If the derived type is bind(c), all fields must be
3389 gfc_warning ("Component '%s' in derived type '%s' at %L "
3390 "may not be C interoperable, even though "
3391 "derived type '%s' is BIND(C)",
3392 curr_comp->name, derived_sym->name,
3393 &(curr_comp->loc), derived_sym->name);
3395 /* If derived type is param to bind(c) routine, or to one
3396 of the iso_c_binding procs, it must be interoperable, so
3397 all fields must interop too. */
3398 gfc_warning ("Component '%s' in derived type '%s' at %L "
3399 "may not be C interoperable",
3400 curr_comp->name, derived_sym->name,
3405 curr_comp = curr_comp->next;
3406 } while (curr_comp != NULL);
3409 /* Make sure we don't have conflicts with the attributes. */
3410 if (derived_sym->attr.access == ACCESS_PRIVATE)
3412 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3413 "PRIVATE and BIND(C) attributes", derived_sym->name,
3414 &(derived_sym->declared_at));
3418 if (derived_sym->attr.sequence != 0)
3420 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3421 "attribute because it is BIND(C)", derived_sym->name,
3422 &(derived_sym->declared_at));
3426 /* Mark the derived type as not being C interoperable if we found an
3427 error. If there were only warnings, proceed with the assumption
3428 it's interoperable. */
3429 if (retval == FAILURE)
3430 derived_sym->ts.is_c_interop = 0;
3436 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3439 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3440 const char *module_name)
3442 gfc_symtree *tmp_symtree;
3443 gfc_symbol *tmp_sym;
3445 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3447 if (tmp_symtree != NULL)
3448 tmp_sym = tmp_symtree->n.sym;
3452 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3453 "create symbol for %s", ptr_name);
3456 /* Set up the symbol's important fields. Save attr required so we can
3457 initialize the ptr to NULL. */
3458 tmp_sym->attr.save = SAVE_EXPLICIT;
3459 tmp_sym->ts.is_c_interop = 1;
3460 tmp_sym->attr.is_c_interop = 1;
3461 tmp_sym->ts.is_iso_c = 1;
3462 tmp_sym->ts.type = BT_DERIVED;
3464 /* The c_ptr and c_funptr derived types will provide the
3465 definition for c_null_ptr and c_null_funptr, respectively. */
3466 if (ptr_id == ISOCBINDING_NULL_PTR)
3467 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3469 tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3470 if (tmp_sym->ts.derived == NULL)
3472 /* This can occur if the user forgot to declare c_ptr or
3473 c_funptr and they're trying to use one of the procedures
3474 that has arg(s) of the missing type. In this case, a
3475 regular version of the thing should have been put in the
3477 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3478 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3479 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3480 ? "_gfortran_iso_c_binding_c_ptr"
3481 : "_gfortran_iso_c_binding_c_funptr"));
3483 tmp_sym->ts.derived =
3484 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3485 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3488 /* Module name is some mangled version of iso_c_binding. */
3489 tmp_sym->module = gfc_get_string (module_name);
3491 /* Say it's from the iso_c_binding module. */
3492 tmp_sym->attr.is_iso_c = 1;
3494 tmp_sym->attr.use_assoc = 1;
3495 tmp_sym->attr.is_bind_c = 1;
3496 /* Set the binding_label. */
3497 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3499 /* Set the c_address field of c_null_ptr and c_null_funptr to
3500 the value of NULL. */
3501 tmp_sym->value = gfc_get_expr ();
3502 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3503 tmp_sym->value->ts.type = BT_DERIVED;
3504 tmp_sym->value->ts.derived = tmp_sym->ts.derived;
3505 /* Create a constructor with no expr, that way we can recognize if the user
3506 tries to call the structure constructor for one of the iso_c_binding
3507 derived types during resolution (resolve_structure_cons). */
3508 tmp_sym->value->value.constructor = gfc_get_constructor ();
3509 /* Must declare c_null_ptr and c_null_funptr as having the
3510 PARAMETER attribute so they can be used in init expressions. */
3511 tmp_sym->attr.flavor = FL_PARAMETER;
3517 /* Add a formal argument, gfc_formal_arglist, to the
3518 end of the given list of arguments. Set the reference to the
3519 provided symbol, param_sym, in the argument. */
3522 add_formal_arg (gfc_formal_arglist **head,
3523 gfc_formal_arglist **tail,
3524 gfc_formal_arglist *formal_arg,
3525 gfc_symbol *param_sym)
3527 /* Put in list, either as first arg or at the tail (curr arg). */
3529 *head = *tail = formal_arg;
3532 (*tail)->next = formal_arg;
3533 (*tail) = formal_arg;
3536 (*tail)->sym = param_sym;
3537 (*tail)->next = NULL;
3543 /* Generates a symbol representing the CPTR argument to an
3544 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3545 CPTR and add it to the provided argument list. */
3548 gen_cptr_param (gfc_formal_arglist **head,
3549 gfc_formal_arglist **tail,
3550 const char *module_name,
3551 gfc_namespace *ns, const char *c_ptr_name,
3554 gfc_symbol *param_sym = NULL;
3555 gfc_symbol *c_ptr_sym = NULL;
3556 gfc_symtree *param_symtree = NULL;
3557 gfc_formal_arglist *formal_arg = NULL;
3558 const char *c_ptr_in;
3559 const char *c_ptr_type = NULL;
3561 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3562 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3564 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3566 if(c_ptr_name == NULL)
3567 c_ptr_in = "gfc_cptr__";
3569 c_ptr_in = c_ptr_name;
3570 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree);
3571 if (param_symtree != NULL)
3572 param_sym = param_symtree->n.sym;
3574 gfc_internal_error ("gen_cptr_param(): Unable to "
3575 "create symbol for %s", c_ptr_in);
3577 /* Set up the appropriate fields for the new c_ptr param sym. */
3579 param_sym->attr.flavor = FL_DERIVED;
3580 param_sym->ts.type = BT_DERIVED;
3581 param_sym->attr.intent = INTENT_IN;
3582 param_sym->attr.dummy = 1;
3584 /* This will pass the ptr to the iso_c routines as a (void *). */
3585 param_sym->attr.value = 1;
3586 param_sym->attr.use_assoc = 1;
3588 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3590 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3591 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3593 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3594 if (c_ptr_sym == NULL)
3596 /* This can happen if the user did not define c_ptr but they are
3597 trying to use one of the iso_c_binding functions that need it. */
3598 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3599 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3600 (const char *)c_ptr_type);
3602 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3603 (const char *)c_ptr_type);
3605 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3608 param_sym->ts.derived = c_ptr_sym;
3609 param_sym->module = gfc_get_string (module_name);
3611 /* Make new formal arg. */
3612 formal_arg = gfc_get_formal_arglist ();
3613 /* Add arg to list of formal args (the CPTR arg). */
3614 add_formal_arg (head, tail, formal_arg, param_sym);
3618 /* Generates a symbol representing the FPTR argument to an
3619 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3620 FPTR and add it to the provided argument list. */
3623 gen_fptr_param (gfc_formal_arglist **head,
3624 gfc_formal_arglist **tail,
3625 const char *module_name,
3626 gfc_namespace *ns, const char *f_ptr_name, int proc)
3628 gfc_symbol *param_sym = NULL;
3629 gfc_symtree *param_symtree = NULL;
3630 gfc_formal_arglist *formal_arg = NULL;
3631 const char *f_ptr_out = "gfc_fptr__";
3633 if (f_ptr_name != NULL)
3634 f_ptr_out = f_ptr_name;
3636 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree);
3637 if (param_symtree != NULL)
3638 param_sym = param_symtree->n.sym;
3640 gfc_internal_error ("generateFPtrParam(): Unable to "
3641 "create symbol for %s", f_ptr_out);
3643 /* Set up the necessary fields for the fptr output param sym. */
3646 param_sym->attr.proc_pointer = 1;
3648 param_sym->attr.pointer = 1;
3649 param_sym->attr.dummy = 1;
3650 param_sym->attr.use_assoc = 1;
3652 /* ISO C Binding type to allow any pointer type as actual param. */
3653 param_sym->ts.type = BT_VOID;
3654 param_sym->module = gfc_get_string (module_name);
3657 formal_arg = gfc_get_formal_arglist ();
3658 /* Add arg to list of formal args. */
3659 add_formal_arg (head, tail, formal_arg, param_sym);
3663 /* Generates a symbol representing the optional SHAPE argument for the
3664 iso_c_binding c_f_pointer() procedure. Also, create a
3665 gfc_formal_arglist for the SHAPE and add it to the provided
3669 gen_shape_param (gfc_formal_arglist **head,
3670 gfc_formal_arglist **tail,
3671 const char *module_name,
3672 gfc_namespace *ns, const char *shape_param_name)
3674 gfc_symbol *param_sym = NULL;
3675 gfc_symtree *param_symtree = NULL;
3676 gfc_formal_arglist *formal_arg = NULL;
3677 const char *shape_param = "gfc_shape_array__";
3680 if (shape_param_name != NULL)
3681 shape_param = shape_param_name;
3683 gfc_get_sym_tree (shape_param, ns, ¶m_symtree);
3684 if (param_symtree != NULL)
3685 param_sym = param_symtree->n.sym;
3687 gfc_internal_error ("generateShapeParam(): Unable to "
3688 "create symbol for %s", shape_param);
3690 /* Set up the necessary fields for the shape input param sym. */
3692 param_sym->attr.dummy = 1;
3693 param_sym->attr.use_assoc = 1;
3695 /* Integer array, rank 1, describing the shape of the object. Make it's
3696 type BT_VOID initially so we can accept any type/kind combination of
3697 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3698 of BT_INTEGER type. */
3699 param_sym->ts.type = BT_VOID;
3701 /* Initialize the kind to default integer. However, it will be overridden
3702 during resolution to match the kind of the SHAPE parameter given as
3703 the actual argument (to allow for any valid integer kind). */
3704 param_sym->ts.kind = gfc_default_integer_kind;
3705 param_sym->as = gfc_get_array_spec ();
3707 /* Clear out the dimension info for the array. */
3708 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3710 param_sym->as->lower[i] = NULL;
3711 param_sym->as->upper[i] = NULL;
3713 param_sym->as->rank = 1;
3714 param_sym->as->lower[0] = gfc_int_expr (1);
3716 /* The extent is unknown until we get it. The length give us
3717 the rank the incoming pointer. */
3718 param_sym->as->type = AS_ASSUMED_SHAPE;
3720 /* The arg is also optional; it is required iff the second arg
3721 (fptr) is to an array, otherwise, it's ignored. */
3722 param_sym->attr.optional = 1;
3723 param_sym->attr.intent = INTENT_IN;
3724 param_sym->attr.dimension = 1;
3725 param_sym->module = gfc_get_string (module_name);
3728 formal_arg = gfc_get_formal_arglist ();
3729 /* Add arg to list of formal args. */
3730 add_formal_arg (head, tail, formal_arg, param_sym);
3733 /* Add a procedure interface to the given symbol (i.e., store a
3734 reference to the list of formal arguments). */
3737 add_proc_interface (gfc_symbol *sym, ifsrc source,
3738 gfc_formal_arglist *formal)
3741 sym->formal = formal;
3742 sym->attr.if_source = source;
3745 /* Copy the formal args from an existing symbol, src, into a new
3746 symbol, dest. New formal args are created, and the description of
3747 each arg is set according to the existing ones. This function is
3748 used when creating procedure declaration variables from a procedure
3749 declaration statement (see match_proc_decl()) to create the formal
3750 args based on the args of a given named interface. */
3753 copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
3755 gfc_formal_arglist *head = NULL;
3756 gfc_formal_arglist *tail = NULL;
3757 gfc_formal_arglist *formal_arg = NULL;
3758 gfc_formal_arglist *curr_arg = NULL;
3759 gfc_formal_arglist *formal_prev = NULL;
3760 /* Save current namespace so we can change it for formal args. */
3761 gfc_namespace *parent_ns = gfc_current_ns;
3763 /* Create a new namespace, which will be the formal ns (namespace
3764 of the formal args). */
3765 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3766 gfc_current_ns->proc_name = dest;
3768 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3770 formal_arg = gfc_get_formal_arglist ();
3771 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
3773 /* May need to copy more info for the symbol. */
3774 formal_arg->sym->attr = curr_arg->sym->attr;
3775 formal_arg->sym->ts = curr_arg->sym->ts;
3776 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
3778 /* If this isn't the first arg, set up the next ptr. For the
3779 last arg built, the formal_arg->next will never get set to
3780 anything other than NULL. */
3781 if (formal_prev != NULL)
3782 formal_prev->next = formal_arg;
3784 formal_arg->next = NULL;
3786 formal_prev = formal_arg;
3788 /* Add arg to list of formal args. */
3789 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
3792 /* Add the interface to the symbol. */
3793 add_proc_interface (dest, IFSRC_DECL, head);
3795 /* Store the formal namespace information. */
3796 if (dest->formal != NULL)
3797 /* The current ns should be that for the dest proc. */
3798 dest->formal_ns = gfc_current_ns;
3799 /* Restore the current namespace to what it was on entry. */
3800 gfc_current_ns = parent_ns;
3803 /* Builds the parameter list for the iso_c_binding procedure
3804 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
3805 generic version of either the c_f_pointer or c_f_procpointer
3806 functions. The new_proc_sym represents a "resolved" version of the
3807 symbol. The functions are resolved to match the types of their
3808 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
3809 something similar to c_f_pointer_i4 if the type of data object fptr
3810 pointed to was a default integer. The actual name of the resolved
3811 procedure symbol is further mangled with the module name, etc., but
3812 the idea holds true. */
3815 build_formal_args (gfc_symbol *new_proc_sym,
3816 gfc_symbol *old_sym, int add_optional_arg)
3818 gfc_formal_arglist *head = NULL, *tail = NULL;
3819 gfc_namespace *parent_ns = NULL;
3821 parent_ns = gfc_current_ns;
3822 /* Create a new namespace, which will be the formal ns (namespace
3823 of the formal args). */
3824 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
3825 gfc_current_ns->proc_name = new_proc_sym;
3827 /* Generate the params. */
3828 if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
3830 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3831 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3832 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3833 gfc_current_ns, "fptr", 1);
3835 else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
3837 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3838 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
3839 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
3840 gfc_current_ns, "fptr", 0);
3841 /* If we're dealing with c_f_pointer, it has an optional third arg. */
3842 gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
3843 gfc_current_ns, "shape");
3846 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
3848 /* c_associated has one required arg and one optional; both
3850 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3851 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
3852 if (add_optional_arg)
3854 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
3855 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
3856 /* The last param is optional so mark it as such. */
3857 tail->sym->attr.optional = 1;
3861 /* Add the interface (store formal args to new_proc_sym). */
3862 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
3864 /* Set up the formal_ns pointer to the one created for the
3865 new procedure so it'll get cleaned up during gfc_free_symbol(). */
3866 new_proc_sym->formal_ns = gfc_current_ns;
3868 gfc_current_ns = parent_ns;
3872 std_for_isocbinding_symbol (int id)
3876 #define NAMED_INTCST(a,b,c,d) \
3879 #include "iso-c-binding.def"
3882 return GFC_STD_F2003;
3886 /* Generate the given set of C interoperable kind objects, or all
3887 interoperable kinds. This function will only be given kind objects
3888 for valid iso_c_binding defined types because this is verified when
3889 the 'use' statement is parsed. If the user gives an 'only' clause,
3890 the specific kinds are looked up; if they don't exist, an error is
3891 reported. If the user does not give an 'only' clause, all
3892 iso_c_binding symbols are generated. If a list of specific kinds
3893 is given, it must have a NULL in the first empty spot to mark the
3898 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
3899 const char *local_name)
3901 const char *const name = (local_name && local_name[0]) ? local_name
3902 : c_interop_kinds_table[s].name;
3903 gfc_symtree *tmp_symtree = NULL;
3904 gfc_symbol *tmp_sym = NULL;
3905 gfc_dt_list **dt_list_ptr = NULL;
3906 gfc_component *tmp_comp = NULL;
3907 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
3910 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == FAILURE)
3912 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
3914 /* Already exists in this scope so don't re-add it.
3915 TODO: we should probably check that it's really the same symbol. */
3916 if (tmp_symtree != NULL)
3919 /* Create the sym tree in the current ns. */
3920 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree);
3922 tmp_sym = tmp_symtree->n.sym;
3924 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
3927 /* Say what module this symbol belongs to. */
3928 tmp_sym->module = gfc_get_string (mod_name);
3929 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
3930 tmp_sym->intmod_sym_id = s;
3935 #define NAMED_INTCST(a,b,c,d) case a :
3936 #define NAMED_REALCST(a,b,c) case a :
3937 #define NAMED_CMPXCST(a,b,c) case a :
3938 #define NAMED_LOGCST(a,b,c) case a :
3939 #define NAMED_CHARKNDCST(a,b,c) case a :
3940 #include "iso-c-binding.def"
3942 tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
3944 /* Initialize an integer constant expression node. */
3945 tmp_sym->attr.flavor = FL_PARAMETER;
3946 tmp_sym->ts.type = BT_INTEGER;
3947 tmp_sym->ts.kind = gfc_default_integer_kind;
3949 /* Mark this type as a C interoperable one. */
3950 tmp_sym->ts.is_c_interop = 1;
3951 tmp_sym->ts.is_iso_c = 1;
3952 tmp_sym->value->ts.is_c_interop = 1;
3953 tmp_sym->value->ts.is_iso_c = 1;
3954 tmp_sym->attr.is_c_interop = 1;
3956 /* Tell what f90 type this c interop kind is valid. */
3957 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
3959 /* Say it's from the iso_c_binding module. */
3960 tmp_sym->attr.is_iso_c = 1;
3962 /* Make it use associated. */
3963 tmp_sym->attr.use_assoc = 1;
3967 #define NAMED_CHARCST(a,b,c) case a :
3968 #include "iso-c-binding.def"
3970 /* Initialize an integer constant expression node for the
3971 length of the character. */
3972 tmp_sym->value = gfc_get_expr ();
3973 tmp_sym->value->expr_type = EXPR_CONSTANT;
3974 tmp_sym->value->ts.type = BT_CHARACTER;
3975 tmp_sym->value->ts.kind = gfc_default_character_kind;
3976 tmp_sym->value->where = gfc_current_locus;
3977 tmp_sym->value->ts.is_c_interop = 1;
3978 tmp_sym->value->ts.is_iso_c = 1;
3979 tmp_sym->value->value.character.length = 1;
3980 tmp_sym->value->value.character.string = gfc_get_wide_string (2);
3981 tmp_sym->value->value.character.string[0]
3982 = (gfc_char_t) c_interop_kinds_table[s].value;
3983 tmp_sym->value->value.character.string[1] = '\0';
3984 tmp_sym->ts.cl = gfc_get_charlen ();
3985 tmp_sym->ts.cl->length = gfc_int_expr (1);
3987 /* May not need this in both attr and ts, but do need in
3988 attr for writing module file. */
3989 tmp_sym->attr.is_c_interop = 1;
3991 tmp_sym->attr.flavor = FL_PARAMETER;
3992 tmp_sym->ts.type = BT_CHARACTER;
3994 /* Need to set it to the C_CHAR kind. */
3995 tmp_sym->ts.kind = gfc_default_character_kind;
3997 /* Mark this type as a C interoperable one. */
3998 tmp_sym->ts.is_c_interop = 1;
3999 tmp_sym->ts.is_iso_c = 1;
4001 /* Tell what f90 type this c interop kind is valid. */
4002 tmp_sym->ts.f90_type = BT_CHARACTER;
4004 /* Say it's from the iso_c_binding module. */
4005 tmp_sym->attr.is_iso_c = 1;
4007 /* Make it use associated. */
4008 tmp_sym->attr.use_assoc = 1;
4011 case ISOCBINDING_PTR:
4012 case ISOCBINDING_FUNPTR:
4014 /* Initialize an integer constant expression node. */
4015 tmp_sym->attr.flavor = FL_DERIVED;
4016 tmp_sym->ts.is_c_interop = 1;
4017 tmp_sym->attr.is_c_interop = 1;
4018 tmp_sym->attr.is_iso_c = 1;
4019 tmp_sym->ts.is_iso_c = 1;
4020 tmp_sym->ts.type = BT_DERIVED;
4022 /* A derived type must have the bind attribute to be
4023 interoperable (J3/04-007, Section 15.2.3), even though
4024 the binding label is not used. */
4025 tmp_sym->attr.is_bind_c = 1;
4027 tmp_sym->attr.referenced = 1;
4029 tmp_sym->ts.derived = tmp_sym;
4031 /* Add the symbol created for the derived type to the current ns. */
4032 dt_list_ptr = &(gfc_derived_types);
4033 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4034 dt_list_ptr = &((*dt_list_ptr)->next);
4036 /* There is already at least one derived type in the list, so append
4037 the one we're currently building for c_ptr or c_funptr. */
4038 if (*dt_list_ptr != NULL)
4039 dt_list_ptr = &((*dt_list_ptr)->next);
4040 (*dt_list_ptr) = gfc_get_dt_list ();
4041 (*dt_list_ptr)->derived = tmp_sym;
4042 (*dt_list_ptr)->next = NULL;
4044 /* Set up the component of the derived type, which will be
4045 an integer with kind equal to c_ptr_size. Mangle the name of
4046 the field for the c_address to prevent the curious user from
4047 trying to access it from Fortran. */
4048 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
4049 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
4050 if (tmp_comp == NULL)
4051 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4052 "create component for c_address");
4054 tmp_comp->ts.type = BT_INTEGER;
4056 /* Set this because the module will need to read/write this field. */
4057 tmp_comp->ts.f90_type = BT_INTEGER;
4059 /* The kinds for c_ptr and c_funptr are the same. */
4060 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4061 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4063 tmp_comp->attr.pointer = 0;
4064 tmp_comp->attr.dimension = 0;
4066 /* Mark the component as C interoperable. */
4067 tmp_comp->ts.is_c_interop = 1;
4069 /* Make it use associated (iso_c_binding module). */
4070 tmp_sym->attr.use_assoc = 1;
4073 case ISOCBINDING_NULL_PTR:
4074 case ISOCBINDING_NULL_FUNPTR:
4075 gen_special_c_interop_ptr (s, name, mod_name);
4078 case ISOCBINDING_F_POINTER:
4079 case ISOCBINDING_ASSOCIATED:
4080 case ISOCBINDING_LOC:
4081 case ISOCBINDING_FUNLOC:
4082 case ISOCBINDING_F_PROCPOINTER:
4084 tmp_sym->attr.proc = PROC_MODULE;
4086 /* Use the procedure's name as it is in the iso_c_binding module for
4087 setting the binding label in case the user renamed the symbol. */
4088 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
4089 c_interop_kinds_table[s].name);
4090 tmp_sym->attr.is_iso_c = 1;
4091 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4092 tmp_sym->attr.subroutine = 1;
4095 /* TODO! This needs to be finished more for the expr of the
4096 function or something!
4097 This may not need to be here, because trying to do c_loc
4099 if (s == ISOCBINDING_ASSOCIATED)
4101 tmp_sym->attr.function = 1;
4102 tmp_sym->ts.type = BT_LOGICAL;
4103 tmp_sym->ts.kind = gfc_default_logical_kind;
4104 tmp_sym->result = tmp_sym;
4108 /* Here, we're taking the simple approach. We're defining
4109 c_loc as an external identifier so the compiler will put
4110 what we expect on the stack for the address we want the
4112 tmp_sym->ts.type = BT_DERIVED;
4113 if (s == ISOCBINDING_LOC)
4114 tmp_sym->ts.derived =
4115 get_iso_c_binding_dt (ISOCBINDING_PTR);
4117 tmp_sym->ts.derived =
4118 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4120 if (tmp_sym->ts.derived == NULL)
4122 /* Create the necessary derived type so we can continue
4123 processing the file. */
4124 generate_isocbinding_symbol
4125 (mod_name, s == ISOCBINDING_FUNLOC
4126 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4127 (const char *)(s == ISOCBINDING_FUNLOC
4128 ? "_gfortran_iso_c_binding_c_funptr"
4129 : "_gfortran_iso_c_binding_c_ptr"));
4130 tmp_sym->ts.derived =
4131 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4132 ? ISOCBINDING_FUNPTR
4136 /* The function result is itself (no result clause). */
4137 tmp_sym->result = tmp_sym;
4138 tmp_sym->attr.external = 1;
4139 tmp_sym->attr.use_assoc = 0;
4140 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4141 tmp_sym->attr.proc = PROC_UNKNOWN;
4145 tmp_sym->attr.flavor = FL_PROCEDURE;
4146 tmp_sym->attr.contained = 0;
4148 /* Try using this builder routine, with the new and old symbols
4149 both being the generic iso_c proc sym being created. This
4150 will create the formal args (and the new namespace for them).
4151 Don't build an arg list for c_loc because we're going to treat
4152 c_loc as an external procedure. */
4153 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4154 /* The 1 says to add any optional args, if applicable. */
4155 build_formal_args (tmp_sym, tmp_sym, 1);
4157 /* Set this after setting up the symbol, to prevent error messages. */
4158 tmp_sym->attr.use_assoc = 1;
4160 /* This symbol will not be referenced directly. It will be
4161 resolved to the implementation for the given f90 kind. */
4162 tmp_sym->attr.referenced = 0;
4172 /* Creates a new symbol based off of an old iso_c symbol, with a new
4173 binding label. This function can be used to create a new,
4174 resolved, version of a procedure symbol for c_f_pointer or
4175 c_f_procpointer that is based on the generic symbols. A new
4176 parameter list is created for the new symbol using
4177 build_formal_args(). The add_optional_flag specifies whether the
4178 to add the optional SHAPE argument. The new symbol is
4182 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4183 char *new_binding_label, int add_optional_arg)
4185 gfc_symtree *new_symtree = NULL;
4187 /* See if we have a symbol by that name already available, looking
4188 through any parent namespaces. */
4189 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4190 if (new_symtree != NULL)
4191 /* Return the existing symbol. */
4192 return new_symtree->n.sym;
4194 /* Create the symtree/symbol, with attempted host association. */
4195 gfc_get_ha_sym_tree (new_name, &new_symtree);
4196 if (new_symtree == NULL)
4197 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4198 "symtree for '%s'", new_name);
4200 /* Now fill in the fields of the resolved symbol with the old sym. */
4201 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4202 new_symtree->n.sym->attr = old_sym->attr;
4203 new_symtree->n.sym->ts = old_sym->ts;
4204 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4205 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4206 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4207 /* Build the formal arg list. */
4208 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4210 gfc_commit_symbol (new_symtree->n.sym);
4212 return new_symtree->n.sym;
4216 /* Check that a symbol is already typed. If strict is not set, an untyped
4217 symbol is acceptable for non-standard-conforming mode. */
4220 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4221 bool strict, locus where)
4225 if (gfc_matching_prefix)
4228 /* Check for the type and try to give it an implicit one. */
4229 if (sym->ts.type == BT_UNKNOWN
4230 && gfc_set_default_type (sym, 0, ns) == FAILURE)
4234 gfc_error ("Symbol '%s' is used before it is typed at %L",
4239 if (gfc_notify_std (GFC_STD_GNU,
4240 "Extension: Symbol '%s' is used before"
4241 " it is typed at %L", sym->name, &where) == FAILURE)
4245 /* Everything is ok. */
4250 /* Get the super-type of a given derived type. */
4253 gfc_get_derived_super_type (gfc_symbol* derived)
4255 if (!derived->attr.extension)
4258 gcc_assert (derived->components);
4259 gcc_assert (derived->components->ts.type == BT_DERIVED);
4260 gcc_assert (derived->components->ts.derived);
4262 return derived->components->ts.derived;
4266 /* Find a type-bound procedure by name for a derived-type (looking recursively
4267 through the super-types). */
4270 gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
4271 const char* name, bool noaccess)
4275 /* Set default to failure. */
4279 /* Try to find it in the current type's namespace. */
4280 gcc_assert (derived->f2k_derived);
4281 res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
4284 if (!res->typebound)
4291 if (!noaccess && derived->attr.use_assoc
4292 && res->typebound->access == ACCESS_PRIVATE)
4294 gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
4302 /* Otherwise, recurse on parent type if derived is an extension. */
4303 if (derived->attr.extension)
4305 gfc_symbol* super_type;
4306 super_type = gfc_get_derived_super_type (derived);
4307 gcc_assert (super_type);
4308 return gfc_find_typebound_proc (super_type, t, name, noaccess);
4311 /* Nothing found. */