1 /* Maintain binary trees of symbols.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 Free Software Foundation, Inc.
5 Contributed by Andy Vaught
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
30 #include "constructor.h"
33 /* Strings for all symbol attributes. We use these for dumping the
34 parse tree, in error messages, and also when reading and writing
37 const mstring flavors[] =
39 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
40 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
41 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
42 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
43 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
47 const mstring procedures[] =
49 minit ("UNKNOWN-PROC", PROC_UNKNOWN),
50 minit ("MODULE-PROC", PROC_MODULE),
51 minit ("INTERNAL-PROC", PROC_INTERNAL),
52 minit ("DUMMY-PROC", PROC_DUMMY),
53 minit ("INTRINSIC-PROC", PROC_INTRINSIC),
54 minit ("EXTERNAL-PROC", PROC_EXTERNAL),
55 minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
59 const mstring intents[] =
61 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
62 minit ("IN", INTENT_IN),
63 minit ("OUT", INTENT_OUT),
64 minit ("INOUT", INTENT_INOUT),
68 const mstring access_types[] =
70 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
71 minit ("PUBLIC", ACCESS_PUBLIC),
72 minit ("PRIVATE", ACCESS_PRIVATE),
76 const mstring ifsrc_types[] =
78 minit ("UNKNOWN", IFSRC_UNKNOWN),
79 minit ("DECL", IFSRC_DECL),
80 minit ("BODY", IFSRC_IFBODY)
83 const mstring save_status[] =
85 minit ("UNKNOWN", SAVE_NONE),
86 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
87 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
90 /* This is to make sure the backend generates setup code in the correct
93 static int next_dummy_order = 1;
96 gfc_namespace *gfc_current_ns;
97 gfc_namespace *gfc_global_ns_list;
99 gfc_gsymbol *gfc_gsym_root = NULL;
101 static gfc_symbol *changed_syms = NULL;
103 gfc_dt_list *gfc_derived_types;
106 /* List of tentative typebound-procedures. */
108 typedef struct tentative_tbp
110 gfc_typebound_proc *proc;
111 struct tentative_tbp *next;
115 static tentative_tbp *tentative_tbp_list = NULL;
118 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
120 /* The following static variable indicates whether a particular element has
121 been explicitly set or not. */
123 static int new_flag[GFC_LETTERS];
126 /* Handle a correctly parsed IMPLICIT NONE. */
129 gfc_set_implicit_none (void)
133 if (gfc_current_ns->seen_implicit_none)
135 gfc_error ("Duplicate IMPLICIT NONE statement at %C");
139 gfc_current_ns->seen_implicit_none = 1;
141 for (i = 0; i < GFC_LETTERS; i++)
143 gfc_clear_ts (&gfc_current_ns->default_type[i]);
144 gfc_current_ns->set_flag[i] = 1;
149 /* Reset the implicit range flags. */
152 gfc_clear_new_implicit (void)
156 for (i = 0; i < GFC_LETTERS; i++)
161 /* Prepare for a new implicit range. Sets flags in new_flag[]. */
164 gfc_add_new_implicit_range (int c1, int c2)
171 for (i = c1; i <= c2; i++)
175 gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
187 /* Add a matched implicit range for gfc_set_implicit(). Check if merging
188 the new implicit types back into the existing types will work. */
191 gfc_merge_new_implicit (gfc_typespec *ts)
195 if (gfc_current_ns->seen_implicit_none)
197 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
201 for (i = 0; i < GFC_LETTERS; i++)
205 if (gfc_current_ns->set_flag[i])
207 gfc_error ("Letter %c already has an IMPLICIT type at %C",
212 gfc_current_ns->default_type[i] = *ts;
213 gfc_current_ns->implicit_loc[i] = gfc_current_locus;
214 gfc_current_ns->set_flag[i] = 1;
221 /* Given a symbol, return a pointer to the typespec for its default type. */
224 gfc_get_default_type (const char *name, gfc_namespace *ns)
230 if (gfc_option.flag_allow_leading_underscore && letter == '_')
231 gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
232 "gfortran developers, and should not be used for "
233 "implicitly typed variables");
235 if (letter < 'a' || letter > 'z')
236 gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
241 return &ns->default_type[letter - 'a'];
245 /* Given a pointer to a symbol, set its type according to the first
246 letter of its name. Fails if the letter in question has no default
250 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
254 if (sym->ts.type != BT_UNKNOWN)
255 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
257 ts = gfc_get_default_type (sym->name, ns);
259 if (ts->type == BT_UNKNOWN)
261 if (error_flag && !sym->attr.untyped)
263 gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
264 sym->name, &sym->declared_at);
265 sym->attr.untyped = 1; /* Ensure we only give an error once. */
272 sym->attr.implicit_type = 1;
274 if (ts->type == BT_CHARACTER && ts->u.cl)
275 sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
277 if (sym->attr.is_bind_c == 1)
279 /* BIND(C) variables should not be implicitly declared. */
280 gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
281 "not be C interoperable", sym->name, &sym->declared_at);
282 sym->ts.f90_type = sym->ts.type;
285 if (sym->attr.dummy != 0)
287 if (sym->ns->proc_name != NULL
288 && (sym->ns->proc_name->attr.subroutine != 0
289 || sym->ns->proc_name->attr.function != 0)
290 && sym->ns->proc_name->attr.is_bind_c != 0)
292 /* Dummy args to a BIND(C) routine may not be interoperable if
293 they are implicitly typed. */
294 gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
295 "be C interoperable but it is a dummy argument to "
296 "the BIND(C) procedure '%s' at %L", sym->name,
297 &(sym->declared_at), sym->ns->proc_name->name,
298 &(sym->ns->proc_name->declared_at));
299 sym->ts.f90_type = sym->ts.type;
307 /* This function is called from parse.c(parse_progunit) to check the
308 type of the function is not implicitly typed in the host namespace
309 and to implicitly type the function result, if necessary. */
312 gfc_check_function_type (gfc_namespace *ns)
314 gfc_symbol *proc = ns->proc_name;
316 if (!proc->attr.contained || proc->result->attr.implicit_type)
319 if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
321 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
324 if (proc->result != proc)
326 proc->ts = proc->result->ts;
327 proc->as = gfc_copy_array_spec (proc->result->as);
328 proc->attr.dimension = proc->result->attr.dimension;
329 proc->attr.pointer = proc->result->attr.pointer;
330 proc->attr.allocatable = proc->result->attr.allocatable;
333 else if (!proc->result->attr.proc_pointer)
335 gfc_error ("Function result '%s' at %L has no IMPLICIT type",
336 proc->result->name, &proc->result->declared_at);
337 proc->result->attr.untyped = 1;
343 /******************** Symbol attribute stuff *********************/
345 /* This is a generic conflict-checker. We do this to avoid having a
346 single conflict in two places. */
348 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
349 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
350 #define conf_std(a, b, std) if (attr->a && attr->b)\
359 check_conflict (symbol_attribute *attr, const char *name, locus *where)
361 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
362 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
363 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
364 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
365 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
366 *privat = "PRIVATE", *recursive = "RECURSIVE",
367 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
368 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
369 *function = "FUNCTION", *subroutine = "SUBROUTINE",
370 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
371 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
372 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
373 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
374 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
375 *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION";
376 static const char *threadprivate = "THREADPRIVATE";
382 where = &gfc_current_locus;
384 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
388 standard = GFC_STD_F2003;
392 /* Check for attributes not allowed in a BLOCK DATA. */
393 if (gfc_current_state () == COMP_BLOCK_DATA)
397 if (attr->in_namelist)
399 if (attr->allocatable)
405 if (attr->access == ACCESS_PRIVATE)
407 if (attr->access == ACCESS_PUBLIC)
409 if (attr->intent != INTENT_UNKNOWN)
415 ("%s attribute not allowed in BLOCK DATA program unit at %L",
421 if (attr->save == SAVE_EXPLICIT)
424 conf (in_common, save);
427 switch (attr->flavor)
435 a1 = gfc_code2string (flavors, attr->flavor);
440 /* Conflicts between SAVE and PROCEDURE will be checked at
441 resolution stage, see "resolve_fl_procedure". */
450 conf (dummy, intrinsic);
451 conf (dummy, threadprivate);
452 conf (pointer, target);
453 conf (pointer, intrinsic);
454 conf (pointer, elemental);
455 conf (allocatable, elemental);
457 conf (target, external);
458 conf (target, intrinsic);
460 if (!attr->if_source)
461 conf (external, dimension); /* See Fortran 95's R504. */
463 conf (external, intrinsic);
464 conf (entry, intrinsic);
466 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
467 conf (external, subroutine);
469 if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
470 "Fortran 2003: Procedure pointer at %C") == FAILURE)
473 conf (allocatable, pointer);
474 conf_std (allocatable, dummy, GFC_STD_F2003);
475 conf_std (allocatable, function, GFC_STD_F2003);
476 conf_std (allocatable, result, GFC_STD_F2003);
477 conf (elemental, recursive);
479 conf (in_common, dummy);
480 conf (in_common, allocatable);
481 conf (in_common, codimension);
482 conf (in_common, result);
484 conf (dummy, result);
486 conf (in_equivalence, use_assoc);
487 conf (in_equivalence, codimension);
488 conf (in_equivalence, dummy);
489 conf (in_equivalence, target);
490 conf (in_equivalence, pointer);
491 conf (in_equivalence, function);
492 conf (in_equivalence, result);
493 conf (in_equivalence, entry);
494 conf (in_equivalence, allocatable);
495 conf (in_equivalence, threadprivate);
497 conf (in_namelist, pointer);
498 conf (in_namelist, allocatable);
500 conf (entry, result);
502 conf (function, subroutine);
504 if (!function && !subroutine)
505 conf (is_bind_c, dummy);
507 conf (is_bind_c, cray_pointer);
508 conf (is_bind_c, cray_pointee);
509 conf (is_bind_c, codimension);
510 conf (is_bind_c, allocatable);
511 conf (is_bind_c, elemental);
513 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
514 Parameter conflict caught below. Also, value cannot be specified
515 for a dummy procedure. */
517 /* Cray pointer/pointee conflicts. */
518 conf (cray_pointer, cray_pointee);
519 conf (cray_pointer, dimension);
520 conf (cray_pointer, codimension);
521 conf (cray_pointer, pointer);
522 conf (cray_pointer, target);
523 conf (cray_pointer, allocatable);
524 conf (cray_pointer, external);
525 conf (cray_pointer, intrinsic);
526 conf (cray_pointer, in_namelist);
527 conf (cray_pointer, function);
528 conf (cray_pointer, subroutine);
529 conf (cray_pointer, entry);
531 conf (cray_pointee, allocatable);
532 conf (cray_pointer, codimension);
533 conf (cray_pointee, intent);
534 conf (cray_pointee, optional);
535 conf (cray_pointee, dummy);
536 conf (cray_pointee, target);
537 conf (cray_pointee, intrinsic);
538 conf (cray_pointee, pointer);
539 conf (cray_pointee, entry);
540 conf (cray_pointee, in_common);
541 conf (cray_pointee, in_equivalence);
542 conf (cray_pointee, threadprivate);
545 conf (data, function);
547 conf (data, allocatable);
548 conf (data, use_assoc);
550 conf (value, pointer)
551 conf (value, allocatable)
552 conf (value, subroutine)
553 conf (value, function)
554 conf (value, volatile_)
555 conf (value, dimension)
556 conf (value, codimension)
557 conf (value, external)
559 conf (codimension, result)
562 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
565 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
569 conf (is_protected, intrinsic)
570 conf (is_protected, in_common)
572 conf (asynchronous, intrinsic)
573 conf (asynchronous, external)
575 conf (volatile_, intrinsic)
576 conf (volatile_, external)
578 if (attr->volatile_ && attr->intent == INTENT_IN)
585 conf (procedure, allocatable)
586 conf (procedure, dimension)
587 conf (procedure, codimension)
588 conf (procedure, intrinsic)
589 conf (procedure, target)
590 conf (procedure, value)
591 conf (procedure, volatile_)
592 conf (procedure, asynchronous)
593 conf (procedure, entry)
595 a1 = gfc_code2string (flavors, attr->flavor);
597 if (attr->in_namelist
598 && attr->flavor != FL_VARIABLE
599 && attr->flavor != FL_PROCEDURE
600 && attr->flavor != FL_UNKNOWN)
606 switch (attr->flavor)
616 conf2 (asynchronous);
618 conf2 (is_protected);
628 conf2 (threadprivate);
630 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
632 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
633 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
640 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
654 /* Conflicts with INTENT, SAVE and RESULT will be checked
655 at resolution stage, see "resolve_fl_procedure". */
657 if (attr->subroutine)
663 conf2 (asynchronous);
668 conf2 (threadprivate);
671 if (!attr->proc_pointer)
676 case PROC_ST_FUNCTION:
686 conf2 (threadprivate);
706 conf2 (threadprivate);
709 if (attr->intent != INTENT_UNKNOWN)
725 conf2 (is_protected);
731 conf2 (asynchronous);
732 conf2 (threadprivate);
747 gfc_error ("%s attribute conflicts with %s attribute at %L",
750 gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
751 a1, a2, name, where);
758 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
759 "with %s attribute at %L", a1, a2,
764 return gfc_notify_std (standard, "Fortran 2003: %s attribute "
765 "with %s attribute in '%s' at %L",
766 a1, a2, name, where);
775 /* Mark a symbol as referenced. */
778 gfc_set_sym_referenced (gfc_symbol *sym)
781 if (sym->attr.referenced)
784 sym->attr.referenced = 1;
786 /* Remember which order dummy variables are accessed in. */
788 sym->dummy_order = next_dummy_order++;
792 /* Common subroutine called by attribute changing subroutines in order
793 to prevent them from changing a symbol that has been
794 use-associated. Returns zero if it is OK to change the symbol,
798 check_used (symbol_attribute *attr, const char *name, locus *where)
801 if (attr->use_assoc == 0)
805 where = &gfc_current_locus;
808 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
811 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
818 /* Generate an error because of a duplicate attribute. */
821 duplicate_attr (const char *attr, locus *where)
825 where = &gfc_current_locus;
827 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
832 gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
833 locus *where ATTRIBUTE_UNUSED)
835 attr->ext_attr |= 1 << ext_attr;
840 /* Called from decl.c (attr_decl1) to check attributes, when declared
844 gfc_add_attribute (symbol_attribute *attr, locus *where)
846 if (check_used (attr, NULL, where))
849 return check_conflict (attr, NULL, where);
854 gfc_add_allocatable (symbol_attribute *attr, locus *where)
857 if (check_used (attr, NULL, where))
860 if (attr->allocatable)
862 duplicate_attr ("ALLOCATABLE", where);
866 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
867 && gfc_find_state (COMP_INTERFACE) == FAILURE)
869 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
874 attr->allocatable = 1;
875 return check_conflict (attr, NULL, where);
880 gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
883 if (check_used (attr, name, where))
886 if (attr->codimension)
888 duplicate_attr ("CODIMENSION", where);
892 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
893 && gfc_find_state (COMP_INTERFACE) == FAILURE)
895 gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
896 "at %L", name, where);
900 attr->codimension = 1;
901 return check_conflict (attr, name, where);
906 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
909 if (check_used (attr, name, where))
914 duplicate_attr ("DIMENSION", where);
918 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
919 && gfc_find_state (COMP_INTERFACE) == FAILURE)
921 gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
922 "at %L", name, where);
927 return check_conflict (attr, name, where);
932 gfc_add_external (symbol_attribute *attr, locus *where)
935 if (check_used (attr, NULL, where))
940 duplicate_attr ("EXTERNAL", where);
944 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
947 attr->proc_pointer = 1;
952 return check_conflict (attr, NULL, where);
957 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
960 if (check_used (attr, NULL, where))
965 duplicate_attr ("INTRINSIC", where);
971 return check_conflict (attr, NULL, where);
976 gfc_add_optional (symbol_attribute *attr, locus *where)
979 if (check_used (attr, NULL, where))
984 duplicate_attr ("OPTIONAL", where);
989 return check_conflict (attr, NULL, where);
994 gfc_add_pointer (symbol_attribute *attr, locus *where)
997 if (check_used (attr, NULL, where))
1000 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
1001 && gfc_find_state (COMP_INTERFACE) == FAILURE))
1003 duplicate_attr ("POINTER", where);
1007 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
1008 || (attr->if_source == IFSRC_IFBODY
1009 && gfc_find_state (COMP_INTERFACE) == FAILURE))
1010 attr->proc_pointer = 1;
1014 return check_conflict (attr, NULL, where);
1019 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
1022 if (check_used (attr, NULL, where))
1025 attr->cray_pointer = 1;
1026 return check_conflict (attr, NULL, where);
1031 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
1034 if (check_used (attr, NULL, where))
1037 if (attr->cray_pointee)
1039 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1040 " statements", where);
1044 attr->cray_pointee = 1;
1045 return check_conflict (attr, NULL, where);
1050 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1052 if (check_used (attr, name, where))
1055 if (attr->is_protected)
1057 if (gfc_notify_std (GFC_STD_LEGACY,
1058 "Duplicate PROTECTED attribute specified at %L",
1064 attr->is_protected = 1;
1065 return check_conflict (attr, name, where);
1070 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1073 if (check_used (attr, name, where))
1077 return check_conflict (attr, name, where);
1082 gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
1085 if (check_used (attr, name, where))
1088 if (gfc_pure (NULL))
1091 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1096 if (attr->save == SAVE_EXPLICIT && !attr->vtab)
1098 if (gfc_notify_std (GFC_STD_LEGACY,
1099 "Duplicate SAVE attribute specified at %L",
1105 attr->save = SAVE_EXPLICIT;
1106 return check_conflict (attr, name, where);
1111 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1114 if (check_used (attr, name, where))
1119 if (gfc_notify_std (GFC_STD_LEGACY,
1120 "Duplicate VALUE attribute specified at %L",
1127 return check_conflict (attr, name, where);
1132 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1134 /* No check_used needed as 11.2.1 of the F2003 standard allows
1135 that the local identifier made accessible by a use statement can be
1136 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1138 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1139 if (gfc_notify_std (GFC_STD_LEGACY,
1140 "Duplicate VOLATILE attribute specified at %L", where)
1144 attr->volatile_ = 1;
1145 attr->volatile_ns = gfc_current_ns;
1146 return check_conflict (attr, name, where);
1151 gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1153 /* No check_used needed as 11.2.1 of the F2003 standard allows
1154 that the local identifier made accessible by a use statement can be
1155 given a ASYNCHRONOUS attribute. */
1157 if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
1158 if (gfc_notify_std (GFC_STD_LEGACY,
1159 "Duplicate ASYNCHRONOUS attribute specified at %L",
1163 attr->asynchronous = 1;
1164 attr->asynchronous_ns = gfc_current_ns;
1165 return check_conflict (attr, name, where);
1170 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1173 if (check_used (attr, name, where))
1176 if (attr->threadprivate)
1178 duplicate_attr ("THREADPRIVATE", where);
1182 attr->threadprivate = 1;
1183 return check_conflict (attr, name, where);
1188 gfc_add_target (symbol_attribute *attr, locus *where)
1191 if (check_used (attr, NULL, where))
1196 duplicate_attr ("TARGET", where);
1201 return check_conflict (attr, NULL, where);
1206 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1209 if (check_used (attr, name, where))
1212 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1214 return check_conflict (attr, name, where);
1219 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1222 if (check_used (attr, name, where))
1225 /* Duplicate attribute already checked for. */
1226 attr->in_common = 1;
1227 return check_conflict (attr, name, where);
1232 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1235 /* Duplicate attribute already checked for. */
1236 attr->in_equivalence = 1;
1237 if (check_conflict (attr, name, where) == FAILURE)
1240 if (attr->flavor == FL_VARIABLE)
1243 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1248 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1251 if (check_used (attr, name, where))
1255 return check_conflict (attr, name, where);
1260 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1263 attr->in_namelist = 1;
1264 return check_conflict (attr, name, where);
1269 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1272 if (check_used (attr, name, where))
1276 return check_conflict (attr, name, where);
1281 gfc_add_elemental (symbol_attribute *attr, locus *where)
1284 if (check_used (attr, NULL, where))
1287 if (attr->elemental)
1289 duplicate_attr ("ELEMENTAL", where);
1293 attr->elemental = 1;
1294 return check_conflict (attr, NULL, where);
1299 gfc_add_pure (symbol_attribute *attr, locus *where)
1302 if (check_used (attr, NULL, where))
1307 duplicate_attr ("PURE", where);
1312 return check_conflict (attr, NULL, where);
1317 gfc_add_recursive (symbol_attribute *attr, locus *where)
1320 if (check_used (attr, NULL, where))
1323 if (attr->recursive)
1325 duplicate_attr ("RECURSIVE", where);
1329 attr->recursive = 1;
1330 return check_conflict (attr, NULL, where);
1335 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1338 if (check_used (attr, name, where))
1343 duplicate_attr ("ENTRY", where);
1348 return check_conflict (attr, name, where);
1353 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1356 if (attr->flavor != FL_PROCEDURE
1357 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1361 return check_conflict (attr, name, where);
1366 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1369 if (attr->flavor != FL_PROCEDURE
1370 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1373 attr->subroutine = 1;
1374 return check_conflict (attr, name, where);
1379 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1382 if (attr->flavor != FL_PROCEDURE
1383 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1387 return check_conflict (attr, name, where);
1392 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1395 if (check_used (attr, NULL, where))
1398 if (attr->flavor != FL_PROCEDURE
1399 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1402 if (attr->procedure)
1404 duplicate_attr ("PROCEDURE", where);
1408 attr->procedure = 1;
1410 return check_conflict (attr, NULL, where);
1415 gfc_add_abstract (symbol_attribute* attr, locus* where)
1419 duplicate_attr ("ABSTRACT", where);
1428 /* Flavors are special because some flavors are not what Fortran
1429 considers attributes and can be reaffirmed multiple times. */
1432 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1436 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1437 || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1438 || f == FL_NAMELIST) && check_used (attr, name, where))
1441 if (attr->flavor == f && f == FL_VARIABLE)
1444 if (attr->flavor != FL_UNKNOWN)
1447 where = &gfc_current_locus;
1450 gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1451 gfc_code2string (flavors, attr->flavor), name,
1452 gfc_code2string (flavors, f), where);
1454 gfc_error ("%s attribute conflicts with %s attribute at %L",
1455 gfc_code2string (flavors, attr->flavor),
1456 gfc_code2string (flavors, f), where);
1463 return check_conflict (attr, name, where);
1468 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1469 const char *name, locus *where)
1472 if (check_used (attr, name, where))
1475 if (attr->flavor != FL_PROCEDURE
1476 && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1480 where = &gfc_current_locus;
1482 if (attr->proc != PROC_UNKNOWN)
1484 gfc_error ("%s procedure at %L is already declared as %s procedure",
1485 gfc_code2string (procedures, t), where,
1486 gfc_code2string (procedures, attr->proc));
1493 /* Statement functions are always scalar and functions. */
1494 if (t == PROC_ST_FUNCTION
1495 && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1496 || attr->dimension))
1499 return check_conflict (attr, name, where);
1504 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1507 if (check_used (attr, NULL, where))
1510 if (attr->intent == INTENT_UNKNOWN)
1512 attr->intent = intent;
1513 return check_conflict (attr, NULL, where);
1517 where = &gfc_current_locus;
1519 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1520 gfc_intent_string (attr->intent),
1521 gfc_intent_string (intent), where);
1527 /* No checks for use-association in public and private statements. */
1530 gfc_add_access (symbol_attribute *attr, gfc_access access,
1531 const char *name, locus *where)
1534 if (attr->access == ACCESS_UNKNOWN
1535 || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1537 attr->access = access;
1538 return check_conflict (attr, name, where);
1542 where = &gfc_current_locus;
1543 gfc_error ("ACCESS specification at %L was already specified", where);
1549 /* Set the is_bind_c field for the given symbol_attribute. */
1552 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1553 int is_proc_lang_bind_spec)
1556 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1557 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1558 "variables or common blocks", where);
1559 else if (attr->is_bind_c)
1560 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1562 attr->is_bind_c = 1;
1565 where = &gfc_current_locus;
1567 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1571 return check_conflict (attr, name, where);
1575 /* Set the extension field for the given symbol_attribute. */
1578 gfc_add_extension (symbol_attribute *attr, locus *where)
1581 where = &gfc_current_locus;
1583 if (attr->extension)
1584 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1586 attr->extension = 1;
1588 if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
1597 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1598 gfc_formal_arglist * formal, locus *where)
1601 if (check_used (&sym->attr, sym->name, where))
1605 where = &gfc_current_locus;
1607 if (sym->attr.if_source != IFSRC_UNKNOWN
1608 && sym->attr.if_source != IFSRC_DECL)
1610 gfc_error ("Symbol '%s' at %L already has an explicit interface",
1615 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1617 gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1618 "body", sym->name, where);
1622 sym->formal = formal;
1623 sym->attr.if_source = source;
1629 /* Add a type to a symbol. */
1632 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1638 where = &gfc_current_locus;
1641 type = sym->result->ts.type;
1643 type = sym->ts.type;
1645 if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
1646 type = sym->ns->proc_name->ts.type;
1648 if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
1650 gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1651 where, gfc_basic_typename (type));
1655 if (sym->attr.procedure && sym->ts.interface)
1657 gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1658 sym->name, where, gfc_basic_typename (ts->type));
1662 flavor = sym->attr.flavor;
1664 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1665 || flavor == FL_LABEL
1666 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1667 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1669 gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1678 /* Clears all attributes. */
1681 gfc_clear_attr (symbol_attribute *attr)
1683 memset (attr, 0, sizeof (symbol_attribute));
1687 /* Check for missing attributes in the new symbol. Currently does
1688 nothing, but it's not clear that it is unnecessary yet. */
1691 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1692 locus *where ATTRIBUTE_UNUSED)
1699 /* Copy an attribute to a symbol attribute, bit by bit. Some
1700 attributes have a lot of side-effects but cannot be present given
1701 where we are called from, so we ignore some bits. */
1704 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1706 int is_proc_lang_bind_spec;
1708 /* In line with the other attributes, we only add bits but do not remove
1709 them; cf. also PR 41034. */
1710 dest->ext_attr |= src->ext_attr;
1712 if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1715 if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1717 if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE)
1719 if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1721 if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1723 if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1725 if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1727 if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1729 if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1731 if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
1733 if (src->threadprivate
1734 && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1736 if (src->target && gfc_add_target (dest, where) == FAILURE)
1738 if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1740 if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1745 if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1748 if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1751 if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1753 if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1755 if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1758 if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1760 if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1762 if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1764 if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1767 if (src->flavor != FL_UNKNOWN
1768 && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1771 if (src->intent != INTENT_UNKNOWN
1772 && gfc_add_intent (dest, src->intent, where) == FAILURE)
1775 if (src->access != ACCESS_UNKNOWN
1776 && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1779 if (gfc_missing_attr (dest, where) == FAILURE)
1782 if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1784 if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1787 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1789 && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1793 if (src->is_c_interop)
1794 dest->is_c_interop = 1;
1798 if (src->external && gfc_add_external (dest, where) == FAILURE)
1800 if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1802 if (src->proc_pointer)
1803 dest->proc_pointer = 1;
1812 /************** Component name management ************/
1814 /* Component names of a derived type form their own little namespaces
1815 that are separate from all other spaces. The space is composed of
1816 a singly linked list of gfc_component structures whose head is
1817 located in the parent symbol. */
1820 /* Add a component name to a symbol. The call fails if the name is
1821 already present. On success, the component pointer is modified to
1822 point to the additional component structure. */
1825 gfc_add_component (gfc_symbol *sym, const char *name,
1826 gfc_component **component)
1828 gfc_component *p, *tail;
1832 for (p = sym->components; p; p = p->next)
1834 if (strcmp (p->name, name) == 0)
1836 gfc_error ("Component '%s' at %C already declared at %L",
1844 if (sym->attr.extension
1845 && gfc_find_component (sym->components->ts.u.derived, name, true, true))
1847 gfc_error ("Component '%s' at %C already in the parent type "
1848 "at %L", name, &sym->components->ts.u.derived->declared_at);
1852 /* Allocate a new component. */
1853 p = gfc_get_component ();
1856 sym->components = p;
1860 p->name = gfc_get_string (name);
1861 p->loc = gfc_current_locus;
1862 p->ts.type = BT_UNKNOWN;
1869 /* Recursive function to switch derived types of all symbol in a
1873 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1881 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
1882 sym->ts.u.derived = to;
1884 switch_types (st->left, from, to);
1885 switch_types (st->right, from, to);
1889 /* This subroutine is called when a derived type is used in order to
1890 make the final determination about which version to use. The
1891 standard requires that a type be defined before it is 'used', but
1892 such types can appear in IMPLICIT statements before the actual
1893 definition. 'Using' in this context means declaring a variable to
1894 be that type or using the type constructor.
1896 If a type is used and the components haven't been defined, then we
1897 have to have a derived type in a parent unit. We find the node in
1898 the other namespace and point the symtree node in this namespace to
1899 that node. Further reference to this name point to the correct
1900 node. If we can't find the node in a parent namespace, then we have
1903 This subroutine takes a pointer to a symbol node and returns a
1904 pointer to the translated node or NULL for an error. Usually there
1905 is no translation and we return the node we were passed. */
1908 gfc_use_derived (gfc_symbol *sym)
1915 if (sym->components != NULL || sym->attr.zero_comp)
1916 return sym; /* Already defined. */
1918 if (sym->ns->parent == NULL)
1921 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1923 gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1927 if (s == NULL || s->attr.flavor != FL_DERIVED)
1930 /* Get rid of symbol sym, translating all references to s. */
1931 for (i = 0; i < GFC_LETTERS; i++)
1933 t = &sym->ns->default_type[i];
1934 if (t->u.derived == sym)
1938 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1943 /* Unlink from list of modified symbols. */
1944 gfc_commit_symbol (sym);
1946 switch_types (sym->ns->sym_root, sym, s);
1948 /* TODO: Also have to replace sym -> s in other lists like
1949 namelists, common lists and interface lists. */
1950 gfc_free_symbol (sym);
1955 gfc_error ("Derived type '%s' at %C is being used before it is defined",
1961 /* Given a derived type node and a component name, try to locate the
1962 component structure. Returns the NULL pointer if the component is
1963 not found or the components are private. If noaccess is set, no access
1967 gfc_find_component (gfc_symbol *sym, const char *name,
1968 bool noaccess, bool silent)
1975 sym = gfc_use_derived (sym);
1980 for (p = sym->components; p; p = p->next)
1981 if (strcmp (p->name, name) == 0)
1985 && sym->attr.extension
1986 && sym->components->ts.type == BT_DERIVED)
1988 p = gfc_find_component (sym->components->ts.u.derived, name,
1990 /* Do not overwrite the error. */
1995 if (p == NULL && !silent)
1996 gfc_error ("'%s' at %C is not a member of the '%s' structure",
1999 else if (sym->attr.use_assoc && !noaccess)
2001 bool is_parent_comp = sym->attr.extension && (p == sym->components);
2002 if (p->attr.access == ACCESS_PRIVATE ||
2003 (p->attr.access != ACCESS_PUBLIC
2004 && sym->component_access == ACCESS_PRIVATE
2005 && !is_parent_comp))
2008 gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2018 /* Given a symbol, free all of the component structures and everything
2022 free_components (gfc_component *p)
2030 gfc_free_array_spec (p->as);
2031 gfc_free_expr (p->initializer);
2038 /******************** Statement label management ********************/
2040 /* Comparison function for statement labels, used for managing the
2044 compare_st_labels (void *a1, void *b1)
2046 int a = ((gfc_st_label *) a1)->value;
2047 int b = ((gfc_st_label *) b1)->value;
2053 /* Free a single gfc_st_label structure, making sure the tree is not
2054 messed up. This function is called only when some parse error
2058 gfc_free_st_label (gfc_st_label *label)
2064 gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
2066 if (label->format != NULL)
2067 gfc_free_expr (label->format);
2073 /* Free a whole tree of gfc_st_label structures. */
2076 free_st_labels (gfc_st_label *label)
2082 free_st_labels (label->left);
2083 free_st_labels (label->right);
2085 if (label->format != NULL)
2086 gfc_free_expr (label->format);
2091 /* Given a label number, search for and return a pointer to the label
2092 structure, creating it if it does not exist. */
2095 gfc_get_st_label (int labelno)
2100 /* Find the namespace of the scoping unit:
2101 If we're in a BLOCK construct, jump to the parent namespace. */
2102 ns = gfc_current_ns;
2103 while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2106 /* First see if the label is already in this namespace. */
2110 if (lp->value == labelno)
2113 if (lp->value < labelno)
2119 lp = XCNEW (gfc_st_label);
2121 lp->value = labelno;
2122 lp->defined = ST_LABEL_UNKNOWN;
2123 lp->referenced = ST_LABEL_UNKNOWN;
2125 gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2131 /* Called when a statement with a statement label is about to be
2132 accepted. We add the label to the list of the current namespace,
2133 making sure it hasn't been defined previously and referenced
2137 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2141 labelno = lp->value;
2143 if (lp->defined != ST_LABEL_UNKNOWN)
2144 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2145 &lp->where, label_locus);
2148 lp->where = *label_locus;
2152 case ST_LABEL_FORMAT:
2153 if (lp->referenced == ST_LABEL_TARGET)
2154 gfc_error ("Label %d at %C already referenced as branch target",
2157 lp->defined = ST_LABEL_FORMAT;
2161 case ST_LABEL_TARGET:
2162 if (lp->referenced == ST_LABEL_FORMAT)
2163 gfc_error ("Label %d at %C already referenced as a format label",
2166 lp->defined = ST_LABEL_TARGET;
2171 lp->defined = ST_LABEL_BAD_TARGET;
2172 lp->referenced = ST_LABEL_BAD_TARGET;
2178 /* Reference a label. Given a label and its type, see if that
2179 reference is consistent with what is known about that label,
2180 updating the unknown state. Returns FAILURE if something goes
2184 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2186 gfc_sl_type label_type;
2193 labelno = lp->value;
2195 if (lp->defined != ST_LABEL_UNKNOWN)
2196 label_type = lp->defined;
2199 label_type = lp->referenced;
2200 lp->where = gfc_current_locus;
2203 if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2205 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2210 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2211 && type == ST_LABEL_FORMAT)
2213 gfc_error ("Label %d at %C previously used as branch target", labelno);
2218 lp->referenced = type;
2226 /*******A helper function for creating new expressions*************/
2230 gfc_lval_expr_from_sym (gfc_symbol *sym)
2233 lval = gfc_get_expr ();
2234 lval->expr_type = EXPR_VARIABLE;
2235 lval->where = sym->declared_at;
2237 lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2239 /* It will always be a full array. */
2240 lval->rank = sym->as ? sym->as->rank : 0;
2243 lval->ref = gfc_get_ref ();
2244 lval->ref->type = REF_ARRAY;
2245 lval->ref->u.ar.type = AR_FULL;
2246 lval->ref->u.ar.dimen = lval->rank;
2247 lval->ref->u.ar.where = sym->declared_at;
2248 lval->ref->u.ar.as = sym->as;
2255 /************** Symbol table management subroutines ****************/
2257 /* Basic details: Fortran 95 requires a potentially unlimited number
2258 of distinct namespaces when compiling a program unit. This case
2259 occurs during a compilation of internal subprograms because all of
2260 the internal subprograms must be read before we can start
2261 generating code for the host.
2263 Given the tricky nature of the Fortran grammar, we must be able to
2264 undo changes made to a symbol table if the current interpretation
2265 of a statement is found to be incorrect. Whenever a symbol is
2266 looked up, we make a copy of it and link to it. All of these
2267 symbols are kept in a singly linked list so that we can commit or
2268 undo the changes at a later time.
2270 A symtree may point to a symbol node outside of its namespace. In
2271 this case, that symbol has been used as a host associated variable
2272 at some previous time. */
2274 /* Allocate a new namespace structure. Copies the implicit types from
2275 PARENT if PARENT_TYPES is set. */
2278 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2285 ns = XCNEW (gfc_namespace);
2286 ns->sym_root = NULL;
2287 ns->uop_root = NULL;
2288 ns->tb_sym_root = NULL;
2289 ns->finalizers = NULL;
2290 ns->default_access = ACCESS_UNKNOWN;
2291 ns->parent = parent;
2293 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2295 ns->operator_access[in] = ACCESS_UNKNOWN;
2296 ns->tb_op[in] = NULL;
2299 /* Initialize default implicit types. */
2300 for (i = 'a'; i <= 'z'; i++)
2302 ns->set_flag[i - 'a'] = 0;
2303 ts = &ns->default_type[i - 'a'];
2305 if (parent_types && ns->parent != NULL)
2307 /* Copy parent settings. */
2308 *ts = ns->parent->default_type[i - 'a'];
2312 if (gfc_option.flag_implicit_none != 0)
2318 if ('i' <= i && i <= 'n')
2320 ts->type = BT_INTEGER;
2321 ts->kind = gfc_default_integer_kind;
2326 ts->kind = gfc_default_real_kind;
2336 /* Comparison function for symtree nodes. */
2339 compare_symtree (void *_st1, void *_st2)
2341 gfc_symtree *st1, *st2;
2343 st1 = (gfc_symtree *) _st1;
2344 st2 = (gfc_symtree *) _st2;
2346 return strcmp (st1->name, st2->name);
2350 /* Allocate a new symtree node and associate it with the new symbol. */
2353 gfc_new_symtree (gfc_symtree **root, const char *name)
2357 st = XCNEW (gfc_symtree);
2358 st->name = gfc_get_string (name);
2360 gfc_insert_bbt (root, st, compare_symtree);
2365 /* Delete a symbol from the tree. Does not free the symbol itself! */
2368 gfc_delete_symtree (gfc_symtree **root, const char *name)
2370 gfc_symtree st, *st0;
2372 st0 = gfc_find_symtree (*root, name);
2374 st.name = gfc_get_string (name);
2375 gfc_delete_bbt (root, &st, compare_symtree);
2381 /* Given a root symtree node and a name, try to find the symbol within
2382 the namespace. Returns NULL if the symbol is not found. */
2385 gfc_find_symtree (gfc_symtree *st, const char *name)
2391 c = strcmp (name, st->name);
2395 st = (c < 0) ? st->left : st->right;
2402 /* Return a symtree node with a name that is guaranteed to be unique
2403 within the namespace and corresponds to an illegal fortran name. */
2406 gfc_get_unique_symtree (gfc_namespace *ns)
2408 char name[GFC_MAX_SYMBOL_LEN + 1];
2409 static int serial = 0;
2411 sprintf (name, "@%d", serial++);
2412 return gfc_new_symtree (&ns->sym_root, name);
2416 /* Given a name find a user operator node, creating it if it doesn't
2417 exist. These are much simpler than symbols because they can't be
2418 ambiguous with one another. */
2421 gfc_get_uop (const char *name)
2426 st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2430 st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2432 uop = st->n.uop = XCNEW (gfc_user_op);
2433 uop->name = gfc_get_string (name);
2434 uop->access = ACCESS_UNKNOWN;
2435 uop->ns = gfc_current_ns;
2441 /* Given a name find the user operator node. Returns NULL if it does
2445 gfc_find_uop (const char *name, gfc_namespace *ns)
2450 ns = gfc_current_ns;
2452 st = gfc_find_symtree (ns->uop_root, name);
2453 return (st == NULL) ? NULL : st->n.uop;
2457 /* Remove a gfc_symbol structure and everything it points to. */
2460 gfc_free_symbol (gfc_symbol *sym)
2466 gfc_free_array_spec (sym->as);
2468 free_components (sym->components);
2470 gfc_free_expr (sym->value);
2472 gfc_free_namelist (sym->namelist);
2474 gfc_free_namespace (sym->formal_ns);
2476 if (!sym->attr.generic_copy)
2477 gfc_free_interface (sym->generic);
2479 gfc_free_formal_arglist (sym->formal);
2481 gfc_free_namespace (sym->f2k_derived);
2487 /* Allocate and initialize a new symbol node. */
2490 gfc_new_symbol (const char *name, gfc_namespace *ns)
2494 p = XCNEW (gfc_symbol);
2496 gfc_clear_ts (&p->ts);
2497 gfc_clear_attr (&p->attr);
2500 p->declared_at = gfc_current_locus;
2502 if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2503 gfc_internal_error ("new_symbol(): Symbol name too long");
2505 p->name = gfc_get_string (name);
2507 /* Make sure flags for symbol being C bound are clear initially. */
2508 p->attr.is_bind_c = 0;
2509 p->attr.is_iso_c = 0;
2510 /* Make sure the binding label field has a Nul char to start. */
2511 p->binding_label[0] = '\0';
2513 /* Clear the ptrs we may need. */
2514 p->common_block = NULL;
2515 p->f2k_derived = NULL;
2521 /* Generate an error if a symbol is ambiguous. */
2524 ambiguous_symbol (const char *name, gfc_symtree *st)
2527 if (st->n.sym->module)
2528 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2529 "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2531 gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2532 "from current program unit", name, st->n.sym->name);
2536 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2537 selector on the stack. If yes, replace it by the corresponding temporary. */
2540 select_type_insert_tmp (gfc_symtree **st)
2542 gfc_select_type_stack *stack = select_type_stack;
2543 for (; stack; stack = stack->prev)
2544 if ((*st)->n.sym == stack->selector && stack->tmp)
2549 /* Search for a symtree starting in the current namespace, resorting to
2550 any parent namespaces if requested by a nonzero parent_flag.
2551 Returns nonzero if the name is ambiguous. */
2554 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2555 gfc_symtree **result)
2560 ns = gfc_current_ns;
2564 st = gfc_find_symtree (ns->sym_root, name);
2567 select_type_insert_tmp (&st);
2570 /* Ambiguous generic interfaces are permitted, as long
2571 as the specific interfaces are different. */
2572 if (st->ambiguous && !st->n.sym->attr.generic)
2574 ambiguous_symbol (name, st);
2593 /* Same, but returns the symbol instead. */
2596 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2597 gfc_symbol **result)
2602 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2607 *result = st->n.sym;
2613 /* Save symbol with the information necessary to back it out. */
2616 save_symbol_data (gfc_symbol *sym)
2619 if (sym->gfc_new || sym->old_symbol != NULL)
2622 sym->old_symbol = XCNEW (gfc_symbol);
2623 *(sym->old_symbol) = *sym;
2625 sym->tlink = changed_syms;
2630 /* Given a name, find a symbol, or create it if it does not exist yet
2631 in the current namespace. If the symbol is found we make sure that
2634 The integer return code indicates
2636 1 The symbol name was ambiguous
2637 2 The name meant to be established was already host associated.
2639 So if the return value is nonzero, then an error was issued. */
2642 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2643 bool allow_subroutine)
2648 /* This doesn't usually happen during resolution. */
2650 ns = gfc_current_ns;
2652 /* Try to find the symbol in ns. */
2653 st = gfc_find_symtree (ns->sym_root, name);
2657 /* If not there, create a new symbol. */
2658 p = gfc_new_symbol (name, ns);
2660 /* Add to the list of tentative symbols. */
2661 p->old_symbol = NULL;
2662 p->tlink = changed_syms;
2667 st = gfc_new_symtree (&ns->sym_root, name);
2674 /* Make sure the existing symbol is OK. Ambiguous
2675 generic interfaces are permitted, as long as the
2676 specific interfaces are different. */
2677 if (st->ambiguous && !st->n.sym->attr.generic)
2679 ambiguous_symbol (name, st);
2684 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2685 && !(allow_subroutine && p->attr.subroutine)
2686 && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2687 && (ns->has_import_set || p->attr.imported)))
2689 /* Symbol is from another namespace. */
2690 gfc_error ("Symbol '%s' at %C has already been host associated",
2697 /* Copy in case this symbol is changed. */
2698 save_symbol_data (p);
2707 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2712 i = gfc_get_sym_tree (name, ns, &st, false);
2717 *result = st->n.sym;
2724 /* Subroutine that searches for a symbol, creating it if it doesn't
2725 exist, but tries to host-associate the symbol if possible. */
2728 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2733 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2737 save_symbol_data (st->n.sym);
2742 if (gfc_current_ns->parent != NULL)
2744 i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2755 return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2760 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2765 i = gfc_get_ha_sym_tree (name, &st);
2768 *result = st->n.sym;
2775 /* Return true if both symbols could refer to the same data object. Does
2776 not take account of aliasing due to equivalence statements. */
2779 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2781 /* Aliasing isn't possible if the symbols have different base types. */
2782 if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2785 /* Pointers can point to other pointers, target objects and allocatable
2786 objects. Two allocatable objects cannot share the same storage. */
2787 if (lsym->attr.pointer
2788 && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2790 if (lsym->attr.target && rsym->attr.pointer)
2792 if (lsym->attr.allocatable && rsym->attr.pointer)
2799 /* Undoes all the changes made to symbols in the current statement.
2800 This subroutine is made simpler due to the fact that attributes are
2801 never removed once added. */
2804 gfc_undo_symbols (void)
2806 gfc_symbol *p, *q, *old;
2807 tentative_tbp *tbp, *tbq;
2809 for (p = changed_syms; p; p = q)
2815 /* Symbol was new. */
2816 if (p->attr.in_common && p->common_block && p->common_block->head)
2818 /* If the symbol was added to any common block, it
2819 needs to be removed to stop the resolver looking
2820 for a (possibly) dead symbol. */
2822 if (p->common_block->head == p)
2823 p->common_block->head = p->common_next;
2826 gfc_symbol *cparent, *csym;
2828 cparent = p->common_block->head;
2829 csym = cparent->common_next;
2834 csym = csym->common_next;
2837 gcc_assert(cparent->common_next == p);
2839 cparent->common_next = csym->common_next;
2843 gfc_delete_symtree (&p->ns->sym_root, p->name);
2847 gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2849 gfc_free_symbol (p);
2853 /* Restore previous state of symbol. Just copy simple stuff. */
2855 old = p->old_symbol;
2857 p->ts.type = old->ts.type;
2858 p->ts.kind = old->ts.kind;
2860 p->attr = old->attr;
2862 if (p->value != old->value)
2864 gfc_free_expr (old->value);
2868 if (p->as != old->as)
2871 gfc_free_array_spec (p->as);
2875 p->generic = old->generic;
2876 p->component_access = old->component_access;
2878 if (p->namelist != NULL && old->namelist == NULL)
2880 gfc_free_namelist (p->namelist);
2885 if (p->namelist_tail != old->namelist_tail)
2887 gfc_free_namelist (old->namelist_tail);
2888 old->namelist_tail->next = NULL;
2892 p->namelist_tail = old->namelist_tail;
2894 if (p->formal != old->formal)
2896 gfc_free_formal_arglist (p->formal);
2897 p->formal = old->formal;
2900 gfc_free (p->old_symbol);
2901 p->old_symbol = NULL;
2905 changed_syms = NULL;
2907 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2910 /* Procedure is already marked `error' by default. */
2913 tentative_tbp_list = NULL;
2917 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2918 components of old_symbol that might need deallocation are the "allocatables"
2919 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2920 namelist_tail. In case these differ between old_symbol and sym, it's just
2921 because sym->namelist has gotten a few more items. */
2924 free_old_symbol (gfc_symbol *sym)
2927 if (sym->old_symbol == NULL)
2930 if (sym->old_symbol->as != sym->as)
2931 gfc_free_array_spec (sym->old_symbol->as);
2933 if (sym->old_symbol->value != sym->value)
2934 gfc_free_expr (sym->old_symbol->value);
2936 if (sym->old_symbol->formal != sym->formal)
2937 gfc_free_formal_arglist (sym->old_symbol->formal);
2939 gfc_free (sym->old_symbol);
2940 sym->old_symbol = NULL;
2944 /* Makes the changes made in the current statement permanent-- gets
2945 rid of undo information. */
2948 gfc_commit_symbols (void)
2951 tentative_tbp *tbp, *tbq;
2953 for (p = changed_syms; p; p = q)
2959 free_old_symbol (p);
2961 changed_syms = NULL;
2963 for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2966 tbp->proc->error = 0;
2969 tentative_tbp_list = NULL;
2973 /* Makes the changes made in one symbol permanent -- gets rid of undo
2977 gfc_commit_symbol (gfc_symbol *sym)
2981 if (changed_syms == sym)
2982 changed_syms = sym->tlink;
2985 for (p = changed_syms; p; p = p->tlink)
2986 if (p->tlink == sym)
2988 p->tlink = sym->tlink;
2997 free_old_symbol (sym);
3001 /* Recursively free trees containing type-bound procedures. */
3004 free_tb_tree (gfc_symtree *t)
3009 free_tb_tree (t->left);
3010 free_tb_tree (t->right);
3012 /* TODO: Free type-bound procedure structs themselves; probably needs some
3013 sort of ref-counting mechanism. */
3019 /* Recursive function that deletes an entire tree and all the common
3020 head structures it points to. */
3023 free_common_tree (gfc_symtree * common_tree)
3025 if (common_tree == NULL)
3028 free_common_tree (common_tree->left);
3029 free_common_tree (common_tree->right);
3031 gfc_free (common_tree);
3035 /* Recursive function that deletes an entire tree and all the user
3036 operator nodes that it contains. */
3039 free_uop_tree (gfc_symtree *uop_tree)
3041 if (uop_tree == NULL)
3044 free_uop_tree (uop_tree->left);
3045 free_uop_tree (uop_tree->right);
3047 gfc_free_interface (uop_tree->n.uop->op);
3048 gfc_free (uop_tree->n.uop);
3049 gfc_free (uop_tree);
3053 /* Recursive function that deletes an entire tree and all the symbols
3054 that it contains. */
3057 free_sym_tree (gfc_symtree *sym_tree)
3062 if (sym_tree == NULL)
3065 free_sym_tree (sym_tree->left);
3066 free_sym_tree (sym_tree->right);
3068 sym = sym_tree->n.sym;
3072 gfc_internal_error ("free_sym_tree(): Negative refs");
3074 if (sym->formal_ns != NULL && sym->refs == 1)
3076 /* As formal_ns contains a reference to sym, delete formal_ns just
3077 before the deletion of sym. */
3078 ns = sym->formal_ns;
3079 sym->formal_ns = NULL;
3080 gfc_free_namespace (ns);
3082 else if (sym->refs == 0)
3084 /* Go ahead and delete the symbol. */
3085 gfc_free_symbol (sym);
3088 gfc_free (sym_tree);
3092 /* Free the derived type list. */
3095 gfc_free_dt_list (void)
3097 gfc_dt_list *dt, *n;
3099 for (dt = gfc_derived_types; dt; dt = n)
3105 gfc_derived_types = NULL;
3109 /* Free the gfc_equiv_info's. */
3112 gfc_free_equiv_infos (gfc_equiv_info *s)
3116 gfc_free_equiv_infos (s->next);
3121 /* Free the gfc_equiv_lists. */
3124 gfc_free_equiv_lists (gfc_equiv_list *l)
3128 gfc_free_equiv_lists (l->next);
3129 gfc_free_equiv_infos (l->equiv);
3134 /* Free a finalizer procedure list. */
3137 gfc_free_finalizer (gfc_finalizer* el)
3143 --el->proc_sym->refs;
3144 if (!el->proc_sym->refs)
3145 gfc_free_symbol (el->proc_sym);
3153 gfc_free_finalizer_list (gfc_finalizer* list)
3157 gfc_finalizer* current = list;
3159 gfc_free_finalizer (current);
3164 /* Create a new gfc_charlen structure and add it to a namespace.
3165 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3168 gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3171 cl = gfc_get_charlen ();
3173 /* Put into namespace. */
3174 cl->next = ns->cl_list;
3180 cl->length = gfc_copy_expr (old_cl->length);
3181 cl->length_from_typespec = old_cl->length_from_typespec;
3182 cl->backend_decl = old_cl->backend_decl;
3183 cl->passed_length = old_cl->passed_length;
3184 cl->resolved = old_cl->resolved;
3191 /* Free the charlen list from cl to end (end is not freed).
3192 Free the whole list if end is NULL. */
3194 void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3198 for (; cl != end; cl = cl2)
3203 gfc_free_expr (cl->length);
3209 /* Free a namespace structure and everything below it. Interface
3210 lists associated with intrinsic operators are not freed. These are
3211 taken care of when a specific name is freed. */
3214 gfc_free_namespace (gfc_namespace *ns)
3216 gfc_namespace *p, *q;
3225 gcc_assert (ns->refs == 0);
3227 gfc_free_statements (ns->code);
3229 free_sym_tree (ns->sym_root);
3230 free_uop_tree (ns->uop_root);
3231 free_common_tree (ns->common_root);
3232 free_tb_tree (ns->tb_sym_root);
3233 free_tb_tree (ns->tb_uop_root);
3234 gfc_free_finalizer_list (ns->finalizers);
3235 gfc_free_charlen (ns->cl_list, NULL);
3236 free_st_labels (ns->st_labels);
3238 gfc_free_equiv (ns->equiv);
3239 gfc_free_equiv_lists (ns->equiv_lists);
3240 gfc_free_use_stmts (ns->use_stmts);
3242 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3243 gfc_free_interface (ns->op[i]);
3245 gfc_free_data (ns->data);
3249 /* Recursively free any contained namespaces. */
3254 gfc_free_namespace (q);
3260 gfc_symbol_init_2 (void)
3263 gfc_current_ns = gfc_get_namespace (NULL, 0);
3268 gfc_symbol_done_2 (void)
3271 gfc_free_namespace (gfc_current_ns);
3272 gfc_current_ns = NULL;
3273 gfc_free_dt_list ();
3277 /* Clear mark bits from symbol nodes associated with a symtree node. */
3280 clear_sym_mark (gfc_symtree *st)
3283 st->n.sym->mark = 0;
3287 /* Recursively traverse the symtree nodes. */
3290 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
3295 gfc_traverse_symtree (st->left, func);
3297 gfc_traverse_symtree (st->right, func);
3301 /* Recursive namespace traversal function. */
3304 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
3310 traverse_ns (st->left, func);
3312 if (st->n.sym->mark == 0)
3313 (*func) (st->n.sym);
3314 st->n.sym->mark = 1;
3316 traverse_ns (st->right, func);
3320 /* Call a given function for all symbols in the namespace. We take
3321 care that each gfc_symbol node is called exactly once. */
3324 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3327 gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3329 traverse_ns (ns->sym_root, func);
3333 /* Return TRUE when name is the name of an intrinsic type. */
3336 gfc_is_intrinsic_typename (const char *name)
3338 if (strcmp (name, "integer") == 0
3339 || strcmp (name, "real") == 0
3340 || strcmp (name, "character") == 0
3341 || strcmp (name, "logical") == 0
3342 || strcmp (name, "complex") == 0
3343 || strcmp (name, "doubleprecision") == 0
3344 || strcmp (name, "doublecomplex") == 0)
3351 /* Return TRUE if the symbol is an automatic variable. */
3354 gfc_is_var_automatic (gfc_symbol *sym)
3356 /* Pointer and allocatable variables are never automatic. */
3357 if (sym->attr.pointer || sym->attr.allocatable)
3359 /* Check for arrays with non-constant size. */
3360 if (sym->attr.dimension && sym->as
3361 && !gfc_is_compile_time_shape (sym->as))
3363 /* Check for non-constant length character variables. */
3364 if (sym->ts.type == BT_CHARACTER
3366 && !gfc_is_constant_expr (sym->ts.u.cl->length))
3371 /* Given a symbol, mark it as SAVEd if it is allowed. */
3374 save_symbol (gfc_symbol *sym)
3377 if (sym->attr.use_assoc)
3380 if (sym->attr.in_common
3383 || sym->attr.flavor != FL_VARIABLE)
3385 /* Automatic objects are not saved. */
3386 if (gfc_is_var_automatic (sym))
3388 gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3392 /* Mark those symbols which can be SAVEd as such. */
3395 gfc_save_all (gfc_namespace *ns)
3397 gfc_traverse_ns (ns, save_symbol);
3402 /* Make sure that no changes to symbols are pending. */
3405 gfc_symbol_state(void) {
3407 if (changed_syms != NULL)
3408 gfc_internal_error("Symbol changes still pending!");
3413 /************** Global symbol handling ************/
3416 /* Search a tree for the global symbol. */
3419 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3428 c = strcmp (name, symbol->name);
3432 symbol = (c < 0) ? symbol->left : symbol->right;
3439 /* Compare two global symbols. Used for managing the BB tree. */
3442 gsym_compare (void *_s1, void *_s2)
3444 gfc_gsymbol *s1, *s2;
3446 s1 = (gfc_gsymbol *) _s1;
3447 s2 = (gfc_gsymbol *) _s2;
3448 return strcmp (s1->name, s2->name);
3452 /* Get a global symbol, creating it if it doesn't exist. */
3455 gfc_get_gsymbol (const char *name)
3459 s = gfc_find_gsymbol (gfc_gsym_root, name);
3463 s = XCNEW (gfc_gsymbol);
3464 s->type = GSYM_UNKNOWN;
3465 s->name = gfc_get_string (name);
3467 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3474 get_iso_c_binding_dt (int sym_id)
3476 gfc_dt_list *dt_list;
3478 dt_list = gfc_derived_types;
3480 /* Loop through the derived types in the name list, searching for
3481 the desired symbol from iso_c_binding. Search the parent namespaces
3482 if necessary and requested to (parent_flag). */
3483 while (dt_list != NULL)
3485 if (dt_list->derived->from_intmod != INTMOD_NONE
3486 && dt_list->derived->intmod_sym_id == sym_id)
3487 return dt_list->derived;
3489 dt_list = dt_list->next;
3496 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3497 with C. This is necessary for any derived type that is BIND(C) and for
3498 derived types that are parameters to functions that are BIND(C). All
3499 fields of the derived type are required to be interoperable, and are tested
3500 for such. If an error occurs, the errors are reported here, allowing for
3501 multiple errors to be handled for a single derived type. */
3504 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3506 gfc_component *curr_comp = NULL;
3507 gfc_try is_c_interop = FAILURE;
3508 gfc_try retval = SUCCESS;
3510 if (derived_sym == NULL)
3511 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3512 "unexpectedly NULL");
3514 /* If we've already looked at this derived symbol, do not look at it again
3515 so we don't repeat warnings/errors. */
3516 if (derived_sym->ts.is_c_interop)
3519 /* The derived type must have the BIND attribute to be interoperable
3520 J3/04-007, Section 15.2.3. */
3521 if (derived_sym->attr.is_bind_c != 1)
3523 derived_sym->ts.is_c_interop = 0;
3524 gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3525 "attribute to be C interoperable", derived_sym->name,
3526 &(derived_sym->declared_at));
3530 curr_comp = derived_sym->components;
3532 /* TODO: is this really an error? */
3533 if (curr_comp == NULL)
3535 gfc_error ("Derived type '%s' at %L is empty",
3536 derived_sym->name, &(derived_sym->declared_at));
3540 /* Initialize the derived type as being C interoperable.
3541 If we find an error in the components, this will be set false. */
3542 derived_sym->ts.is_c_interop = 1;
3544 /* Loop through the list of components to verify that the kind of
3545 each is a C interoperable type. */
3548 /* The components cannot be pointers (fortran sense).
3549 J3/04-007, Section 15.2.3, C1505. */
3550 if (curr_comp->attr.pointer != 0)
3552 gfc_error ("Component '%s' at %L cannot have the "
3553 "POINTER attribute because it is a member "
3554 "of the BIND(C) derived type '%s' at %L",
3555 curr_comp->name, &(curr_comp->loc),
3556 derived_sym->name, &(derived_sym->declared_at));
3560 if (curr_comp->attr.proc_pointer != 0)
3562 gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3563 " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3564 &curr_comp->loc, derived_sym->name,
3565 &derived_sym->declared_at);
3569 /* The components cannot be allocatable.
3570 J3/04-007, Section 15.2.3, C1505. */
3571 if (curr_comp->attr.allocatable != 0)
3573 gfc_error ("Component '%s' at %L cannot have the "
3574 "ALLOCATABLE attribute because it is a member "
3575 "of the BIND(C) derived type '%s' at %L",
3576 curr_comp->name, &(curr_comp->loc),
3577 derived_sym->name, &(derived_sym->declared_at));
3581 /* BIND(C) derived types must have interoperable components. */
3582 if (curr_comp->ts.type == BT_DERIVED
3583 && curr_comp->ts.u.derived->ts.is_iso_c != 1
3584 && curr_comp->ts.u.derived != derived_sym)
3586 /* This should be allowed; the draft says a derived-type can not
3587 have type parameters if it is has the BIND attribute. Type
3588 parameters seem to be for making parameterized derived types.
3589 There's no need to verify the type if it is c_ptr/c_funptr. */
3590 retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3594 /* Grab the typespec for the given component and test the kind. */
3595 is_c_interop = verify_c_interop (&(curr_comp->ts));
3597 if (is_c_interop != SUCCESS)
3599 /* Report warning and continue since not fatal. The
3600 draft does specify a constraint that requires all fields
3601 to interoperate, but if the user says real(4), etc., it
3602 may interoperate with *something* in C, but the compiler
3603 most likely won't know exactly what. Further, it may not
3604 interoperate with the same data type(s) in C if the user
3605 recompiles with different flags (e.g., -m32 and -m64 on
3606 x86_64 and using integer(4) to claim interop with a
3608 if (derived_sym->attr.is_bind_c == 1)
3609 /* If the derived type is bind(c), all fields must be
3611 gfc_warning ("Component '%s' in derived type '%s' at %L "
3612 "may not be C interoperable, even though "
3613 "derived type '%s' is BIND(C)",
3614 curr_comp->name, derived_sym->name,
3615 &(curr_comp->loc), derived_sym->name);
3617 /* If derived type is param to bind(c) routine, or to one
3618 of the iso_c_binding procs, it must be interoperable, so
3619 all fields must interop too. */
3620 gfc_warning ("Component '%s' in derived type '%s' at %L "
3621 "may not be C interoperable",
3622 curr_comp->name, derived_sym->name,
3627 curr_comp = curr_comp->next;
3628 } while (curr_comp != NULL);
3631 /* Make sure we don't have conflicts with the attributes. */
3632 if (derived_sym->attr.access == ACCESS_PRIVATE)
3634 gfc_error ("Derived type '%s' at %L cannot be declared with both "
3635 "PRIVATE and BIND(C) attributes", derived_sym->name,
3636 &(derived_sym->declared_at));
3640 if (derived_sym->attr.sequence != 0)
3642 gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3643 "attribute because it is BIND(C)", derived_sym->name,
3644 &(derived_sym->declared_at));
3648 /* Mark the derived type as not being C interoperable if we found an
3649 error. If there were only warnings, proceed with the assumption
3650 it's interoperable. */
3651 if (retval == FAILURE)
3652 derived_sym->ts.is_c_interop = 0;
3658 /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
3661 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3662 const char *module_name)
3664 gfc_symtree *tmp_symtree;
3665 gfc_symbol *tmp_sym;
3668 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3670 if (tmp_symtree != NULL)
3671 tmp_sym = tmp_symtree->n.sym;
3675 gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3676 "create symbol for %s", ptr_name);
3679 /* Set up the symbol's important fields. Save attr required so we can
3680 initialize the ptr to NULL. */
3681 tmp_sym->attr.save = SAVE_EXPLICIT;
3682 tmp_sym->ts.is_c_interop = 1;
3683 tmp_sym->attr.is_c_interop = 1;
3684 tmp_sym->ts.is_iso_c = 1;
3685 tmp_sym->ts.type = BT_DERIVED;
3687 /* The c_ptr and c_funptr derived types will provide the
3688 definition for c_null_ptr and c_null_funptr, respectively. */
3689 if (ptr_id == ISOCBINDING_NULL_PTR)
3690 tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3692 tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3693 if (tmp_sym->ts.u.derived == NULL)
3695 /* This can occur if the user forgot to declare c_ptr or
3696 c_funptr and they're trying to use one of the procedures
3697 that has arg(s) of the missing type. In this case, a
3698 regular version of the thing should have been put in the
3700 generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
3701 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3702 (const char *) (ptr_id == ISOCBINDING_NULL_PTR
3703 ? "_gfortran_iso_c_binding_c_ptr"
3704 : "_gfortran_iso_c_binding_c_funptr"));
3706 tmp_sym->ts.u.derived =
3707 get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3708 ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3711 /* Module name is some mangled version of iso_c_binding. */
3712 tmp_sym->module = gfc_get_string (module_name);
3714 /* Say it's from the iso_c_binding module. */
3715 tmp_sym->attr.is_iso_c = 1;
3717 tmp_sym->attr.use_assoc = 1;
3718 tmp_sym->attr.is_bind_c = 1;
3719 /* Set the binding_label. */
3720 sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3722 /* Set the c_address field of c_null_ptr and c_null_funptr to
3723 the value of NULL. */
3724 tmp_sym->value = gfc_get_expr ();
3725 tmp_sym->value->expr_type = EXPR_STRUCTURE;
3726 tmp_sym->value->ts.type = BT_DERIVED;
3727 tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
3728 gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
3729 c = gfc_constructor_first (tmp_sym->value->value.constructor);
3730 c->expr = gfc_get_expr ();
3731 c->expr->expr_type = EXPR_NULL;
3732 c->expr->ts.is_iso_c = 1;
3733 /* Must declare c_null_ptr and c_null_funptr as having the
3734 PARAMETER attribute so they can be used in init expressions. */
3735 tmp_sym->attr.flavor = FL_PARAMETER;
3741 /* Add a formal argument, gfc_formal_arglist, to the
3742 end of the given list of arguments. Set the reference to the
3743 provided symbol, param_sym, in the argument. */
3746 add_formal_arg (gfc_formal_arglist **head,
3747 gfc_formal_arglist **tail,
3748 gfc_formal_arglist *formal_arg,
3749 gfc_symbol *param_sym)
3751 /* Put in list, either as first arg or at the tail (curr arg). */
3753 *head = *tail = formal_arg;
3756 (*tail)->next = formal_arg;
3757 (*tail) = formal_arg;
3760 (*tail)->sym = param_sym;
3761 (*tail)->next = NULL;
3767 /* Generates a symbol representing the CPTR argument to an
3768 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3769 CPTR and add it to the provided argument list. */
3772 gen_cptr_param (gfc_formal_arglist **head,
3773 gfc_formal_arglist **tail,
3774 const char *module_name,
3775 gfc_namespace *ns, const char *c_ptr_name,
3778 gfc_symbol *param_sym = NULL;
3779 gfc_symbol *c_ptr_sym = NULL;
3780 gfc_symtree *param_symtree = NULL;
3781 gfc_formal_arglist *formal_arg = NULL;
3782 const char *c_ptr_in;
3783 const char *c_ptr_type = NULL;
3785 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3786 c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
3788 c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
3790 if(c_ptr_name == NULL)
3791 c_ptr_in = "gfc_cptr__";
3793 c_ptr_in = c_ptr_name;
3794 gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree, false);
3795 if (param_symtree != NULL)
3796 param_sym = param_symtree->n.sym;
3798 gfc_internal_error ("gen_cptr_param(): Unable to "
3799 "create symbol for %s", c_ptr_in);
3801 /* Set up the appropriate fields for the new c_ptr param sym. */
3803 param_sym->attr.flavor = FL_DERIVED;
3804 param_sym->ts.type = BT_DERIVED;
3805 param_sym->attr.intent = INTENT_IN;
3806 param_sym->attr.dummy = 1;
3808 /* This will pass the ptr to the iso_c routines as a (void *). */
3809 param_sym->attr.value = 1;
3810 param_sym->attr.use_assoc = 1;
3812 /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
3814 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3815 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3817 c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
3818 if (c_ptr_sym == NULL)
3820 /* This can happen if the user did not define c_ptr but they are
3821 trying to use one of the iso_c_binding functions that need it. */
3822 if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
3823 generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
3824 (const char *)c_ptr_type);
3826 generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
3827 (const char *)c_ptr_type);
3829 gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
3832 param_sym->ts.u.derived = c_ptr_sym;
3833 param_sym->module = gfc_get_string (module_name);
3835 /* Make new formal arg. */
3836 formal_arg = gfc_get_formal_arglist ();
3837 /* Add arg to list of formal args (the CPTR arg). */
3838 add_formal_arg (head, tail, formal_arg, param_sym);
3842 /* Generates a symbol representing the FPTR argument to an
3843 iso_c_binding procedure. Also, create a gfc_formal_arglist for the
3844 FPTR and add it to the provided argument list. */
3847 gen_fptr_param (gfc_formal_arglist **head,
3848 gfc_formal_arglist **tail,
3849 const char *module_name,
3850 gfc_namespace *ns, const char *f_ptr_name, int proc)
3852 gfc_symbol *param_sym = NULL;
3853 gfc_symtree *param_symtree = NULL;
3854 gfc_formal_arglist *formal_arg = NULL;
3855 const char *f_ptr_out = "gfc_fptr__";
3857 if (f_ptr_name != NULL)
3858 f_ptr_out = f_ptr_name;
3860 gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree, false);
3861 if (param_symtree != NULL)
3862 param_sym = param_symtree->n.sym;
3864 gfc_internal_error ("generateFPtrParam(): Unable to "
3865 "create symbol for %s", f_ptr_out);
3867 /* Set up the necessary fields for the fptr output param sym. */
3870 param_sym->attr.proc_pointer = 1;
3872 param_sym->attr.pointer = 1;
3873 param_sym->attr.dummy = 1;
3874 param_sym->attr.use_assoc = 1;
3876 /* ISO C Binding type to allow any pointer type as actual param. */
3877 param_sym->ts.type = BT_VOID;
3878 param_sym->module = gfc_get_string (module_name);
3881 formal_arg = gfc_get_formal_arglist ();
3882 /* Add arg to list of formal args. */
3883 add_formal_arg (head, tail, formal_arg, param_sym);
3887 /* Generates a symbol representing the optional SHAPE argument for the
3888 iso_c_binding c_f_pointer() procedure. Also, create a
3889 gfc_formal_arglist for the SHAPE and add it to the provided
3893 gen_shape_param (gfc_formal_arglist **head,
3894 gfc_formal_arglist **tail,
3895 const char *module_name,
3896 gfc_namespace *ns, const char *shape_param_name)
3898 gfc_symbol *param_sym = NULL;
3899 gfc_symtree *param_symtree = NULL;
3900 gfc_formal_arglist *formal_arg = NULL;
3901 const char *shape_param = "gfc_shape_array__";
3904 if (shape_param_name != NULL)
3905 shape_param = shape_param_name;
3907 gfc_get_sym_tree (shape_param, ns, ¶m_symtree, false);
3908 if (param_symtree != NULL)
3909 param_sym = param_symtree->n.sym;
3911 gfc_internal_error ("generateShapeParam(): Unable to "
3912 "create symbol for %s", shape_param);
3914 /* Set up the necessary fields for the shape input param sym. */
3916 param_sym->attr.dummy = 1;
3917 param_sym->attr.use_assoc = 1;
3919 /* Integer array, rank 1, describing the shape of the object. Make it's
3920 type BT_VOID initially so we can accept any type/kind combination of
3921 integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
3922 of BT_INTEGER type. */
3923 param_sym->ts.type = BT_VOID;
3925 /* Initialize the kind to default integer. However, it will be overridden
3926 during resolution to match the kind of the SHAPE parameter given as
3927 the actual argument (to allow for any valid integer kind). */
3928 param_sym->ts.kind = gfc_default_integer_kind;
3929 param_sym->as = gfc_get_array_spec ();
3931 /* Clear out the dimension info for the array. */
3932 for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
3934 param_sym->as->lower[i] = NULL;
3935 param_sym->as->upper[i] = NULL;
3937 param_sym->as->rank = 1;
3938 param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
3941 /* The extent is unknown until we get it. The length give us
3942 the rank the incoming pointer. */
3943 param_sym->as->type = AS_ASSUMED_SHAPE;
3945 /* The arg is also optional; it is required iff the second arg
3946 (fptr) is to an array, otherwise, it's ignored. */
3947 param_sym->attr.optional = 1;
3948 param_sym->attr.intent = INTENT_IN;
3949 param_sym->attr.dimension = 1;
3950 param_sym->module = gfc_get_string (module_name);
3953 formal_arg = gfc_get_formal_arglist ();
3954 /* Add arg to list of formal args. */
3955 add_formal_arg (head, tail, formal_arg, param_sym);
3959 /* Add a procedure interface to the given symbol (i.e., store a
3960 reference to the list of formal arguments). */
3963 add_proc_interface (gfc_symbol *sym, ifsrc source,
3964 gfc_formal_arglist *formal)
3967 sym->formal = formal;
3968 sym->attr.if_source = source;
3972 /* Copy the formal args from an existing symbol, src, into a new
3973 symbol, dest. New formal args are created, and the description of
3974 each arg is set according to the existing ones. This function is
3975 used when creating procedure declaration variables from a procedure
3976 declaration statement (see match_proc_decl()) to create the formal
3977 args based on the args of a given named interface. */
3980 gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
3982 gfc_formal_arglist *head = NULL;
3983 gfc_formal_arglist *tail = NULL;
3984 gfc_formal_arglist *formal_arg = NULL;
3985 gfc_formal_arglist *curr_arg = NULL;
3986 gfc_formal_arglist *formal_prev = NULL;
3987 /* Save current namespace so we can change it for formal args. */
3988 gfc_namespace *parent_ns = gfc_current_ns;
3990 /* Create a new namespace, which will be the formal ns (namespace
3991 of the formal args). */
3992 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
3993 gfc_current_ns->proc_name = dest;
3995 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
3997 formal_arg = gfc_get_formal_arglist ();
3998 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
4000 /* May need to copy more info for the symbol. */
4001 formal_arg->sym->attr = curr_arg->sym->attr;
4002 formal_arg->sym->ts = curr_arg->sym->ts;
4003 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
4004 gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
4006 /* If this isn't the first arg, set up the next ptr. For the
4007 last arg built, the formal_arg->next will never get set to
4008 anything other than NULL. */
4009 if (formal_prev != NULL)
4010 formal_prev->next = formal_arg;
4012 formal_arg->next = NULL;
4014 formal_prev = formal_arg;
4016 /* Add arg to list of formal args. */
4017 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4020 /* Add the interface to the symbol. */
4021 add_proc_interface (dest, IFSRC_DECL, head);
4023 /* Store the formal namespace information. */
4024 if (dest->formal != NULL)
4025 /* The current ns should be that for the dest proc. */
4026 dest->formal_ns = gfc_current_ns;
4027 /* Restore the current namespace to what it was on entry. */
4028 gfc_current_ns = parent_ns;
4033 gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
4035 gfc_formal_arglist *head = NULL;
4036 gfc_formal_arglist *tail = NULL;
4037 gfc_formal_arglist *formal_arg = NULL;
4038 gfc_intrinsic_arg *curr_arg = NULL;
4039 gfc_formal_arglist *formal_prev = NULL;
4040 /* Save current namespace so we can change it for formal args. */
4041 gfc_namespace *parent_ns = gfc_current_ns;
4043 /* Create a new namespace, which will be the formal ns (namespace
4044 of the formal args). */
4045 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4046 gfc_current_ns->proc_name = dest;
4048 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4050 formal_arg = gfc_get_formal_arglist ();
4051 gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4053 /* May need to copy more info for the symbol. */
4054 formal_arg->sym->ts = curr_arg->ts;
4055 formal_arg->sym->attr.optional = curr_arg->optional;
4056 formal_arg->sym->attr.intent = curr_arg->intent;
4057 formal_arg->sym->attr.flavor = FL_VARIABLE;
4058 formal_arg->sym->attr.dummy = 1;
4060 if (formal_arg->sym->ts.type == BT_CHARACTER)
4061 formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4063 /* If this isn't the first arg, set up the next ptr. For the
4064 last arg built, the formal_arg->next will never get set to
4065 anything other than NULL. */
4066 if (formal_prev != NULL)
4067 formal_prev->next = formal_arg;
4069 formal_arg->next = NULL;
4071 formal_prev = formal_arg;
4073 /* Add arg to list of formal args. */
4074 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4077 /* Add the interface to the symbol. */
4078 add_proc_interface (dest, IFSRC_DECL, head);
4080 /* Store the formal namespace information. */
4081 if (dest->formal != NULL)
4082 /* The current ns should be that for the dest proc. */
4083 dest->formal_ns = gfc_current_ns;
4084 /* Restore the current namespace to what it was on entry. */
4085 gfc_current_ns = parent_ns;
4090 gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
4092 gfc_formal_arglist *head = NULL;
4093 gfc_formal_arglist *tail = NULL;
4094 gfc_formal_arglist *formal_arg = NULL;
4095 gfc_formal_arglist *curr_arg = NULL;
4096 gfc_formal_arglist *formal_prev = NULL;
4097 /* Save current namespace so we can change it for formal args. */
4098 gfc_namespace *parent_ns = gfc_current_ns;
4100 /* Create a new namespace, which will be the formal ns (namespace
4101 of the formal args). */
4102 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4103 /* TODO: gfc_current_ns->proc_name = dest;*/
4105 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
4107 formal_arg = gfc_get_formal_arglist ();
4108 gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
4110 /* May need to copy more info for the symbol. */
4111 formal_arg->sym->attr = curr_arg->sym->attr;
4112 formal_arg->sym->ts = curr_arg->sym->ts;
4113 formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
4114 gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
4116 /* If this isn't the first arg, set up the next ptr. For the
4117 last arg built, the formal_arg->next will never get set to
4118 anything other than NULL. */
4119 if (formal_prev != NULL)
4120 formal_prev->next = formal_arg;
4122 formal_arg->next = NULL;
4124 formal_prev = formal_arg;
4126 /* Add arg to list of formal args. */
4127 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4130 /* Add the interface to the symbol. */
4131 dest->formal = head;
4132 dest->attr.if_source = IFSRC_DECL;
4134 /* Store the formal namespace information. */
4135 if (dest->formal != NULL)
4136 /* The current ns should be that for the dest proc. */
4137 dest->formal_ns = gfc_current_ns;
4138 /* Restore the current namespace to what it was on entry. */
4139 gfc_current_ns = parent_ns;
4143 /* Builds the parameter list for the iso_c_binding procedure
4144 c_f_pointer or c_f_procpointer. The old_sym typically refers to a
4145 generic version of either the c_f_pointer or c_f_procpointer
4146 functions. The new_proc_sym represents a "resolved" version of the
4147 symbol. The functions are resolved to match the types of their
4148 parameters; for example, c_f_pointer(cptr, fptr) would resolve to
4149 something similar to c_f_pointer_i4 if the type of data object fptr
4150 pointed to was a default integer. The actual name of the resolved
4151 procedure symbol is further mangled with the module name, etc., but
4152 the idea holds true. */
4155 build_formal_args (gfc_symbol *new_proc_sym,
4156 gfc_symbol *old_sym, int add_optional_arg)
4158 gfc_formal_arglist *head = NULL, *tail = NULL;
4159 gfc_namespace *parent_ns = NULL;
4161 parent_ns = gfc_current_ns;
4162 /* Create a new namespace, which will be the formal ns (namespace
4163 of the formal args). */
4164 gfc_current_ns = gfc_get_namespace(parent_ns, 0);
4165 gfc_current_ns->proc_name = new_proc_sym;
4167 /* Generate the params. */
4168 if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
4170 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4171 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4172 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4173 gfc_current_ns, "fptr", 1);
4175 else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
4177 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4178 gfc_current_ns, "cptr", old_sym->intmod_sym_id);
4179 gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
4180 gfc_current_ns, "fptr", 0);
4181 /* If we're dealing with c_f_pointer, it has an optional third arg. */
4182 gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
4183 gfc_current_ns, "shape");
4186 else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
4188 /* c_associated has one required arg and one optional; both
4190 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4191 gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
4192 if (add_optional_arg)
4194 gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
4195 gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
4196 /* The last param is optional so mark it as such. */
4197 tail->sym->attr.optional = 1;
4201 /* Add the interface (store formal args to new_proc_sym). */
4202 add_proc_interface (new_proc_sym, IFSRC_DECL, head);
4204 /* Set up the formal_ns pointer to the one created for the
4205 new procedure so it'll get cleaned up during gfc_free_symbol(). */
4206 new_proc_sym->formal_ns = gfc_current_ns;
4208 gfc_current_ns = parent_ns;
4212 std_for_isocbinding_symbol (int id)
4216 #define NAMED_INTCST(a,b,c,d) \
4219 #include "iso-c-binding.def"
4222 return GFC_STD_F2003;
4226 /* Generate the given set of C interoperable kind objects, or all
4227 interoperable kinds. This function will only be given kind objects
4228 for valid iso_c_binding defined types because this is verified when
4229 the 'use' statement is parsed. If the user gives an 'only' clause,
4230 the specific kinds are looked up; if they don't exist, an error is
4231 reported. If the user does not give an 'only' clause, all
4232 iso_c_binding symbols are generated. If a list of specific kinds
4233 is given, it must have a NULL in the first empty spot to mark the
4238 generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4239 const char *local_name)
4241 const char *const name = (local_name && local_name[0]) ? local_name
4242 : c_interop_kinds_table[s].name;
4243 gfc_symtree *tmp_symtree = NULL;
4244 gfc_symbol *tmp_sym = NULL;
4245 gfc_dt_list **dt_list_ptr = NULL;
4246 gfc_component *tmp_comp = NULL;
4247 char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
4250 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4252 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4254 /* Already exists in this scope so don't re-add it.
4255 TODO: we should probably check that it's really the same symbol. */
4256 if (tmp_symtree != NULL)
4259 /* Create the sym tree in the current ns. */
4260 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4262 tmp_sym = tmp_symtree->n.sym;
4264 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4267 /* Say what module this symbol belongs to. */
4268 tmp_sym->module = gfc_get_string (mod_name);
4269 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4270 tmp_sym->intmod_sym_id = s;
4275 #define NAMED_INTCST(a,b,c,d) case a :
4276 #define NAMED_REALCST(a,b,c) case a :
4277 #define NAMED_CMPXCST(a,b,c) case a :
4278 #define NAMED_LOGCST(a,b,c) case a :
4279 #define NAMED_CHARKNDCST(a,b,c) case a :
4280 #include "iso-c-binding.def"
4282 tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4283 c_interop_kinds_table[s].value);
4285 /* Initialize an integer constant expression node. */
4286 tmp_sym->attr.flavor = FL_PARAMETER;
4287 tmp_sym->ts.type = BT_INTEGER;
4288 tmp_sym->ts.kind = gfc_default_integer_kind;
4290 /* Mark this type as a C interoperable one. */
4291 tmp_sym->ts.is_c_interop = 1;
4292 tmp_sym->ts.is_iso_c = 1;
4293 tmp_sym->value->ts.is_c_interop = 1;
4294 tmp_sym->value->ts.is_iso_c = 1;
4295 tmp_sym->attr.is_c_interop = 1;
4297 /* Tell what f90 type this c interop kind is valid. */
4298 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4300 /* Say it's from the iso_c_binding module. */
4301 tmp_sym->attr.is_iso_c = 1;
4303 /* Make it use associated. */
4304 tmp_sym->attr.use_assoc = 1;
4308 #define NAMED_CHARCST(a,b,c) case a :
4309 #include "iso-c-binding.def"
4311 /* Initialize an integer constant expression node for the
4312 length of the character. */
4313 tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
4314 &gfc_current_locus, NULL, 1);
4315 tmp_sym->value->ts.is_c_interop = 1;
4316 tmp_sym->value->ts.is_iso_c = 1;
4317 tmp_sym->value->value.character.length = 1;
4318 tmp_sym->value->value.character.string[0]
4319 = (gfc_char_t) c_interop_kinds_table[s].value;
4320 tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4321 tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
4324 /* May not need this in both attr and ts, but do need in
4325 attr for writing module file. */
4326 tmp_sym->attr.is_c_interop = 1;
4328 tmp_sym->attr.flavor = FL_PARAMETER;
4329 tmp_sym->ts.type = BT_CHARACTER;
4331 /* Need to set it to the C_CHAR kind. */
4332 tmp_sym->ts.kind = gfc_default_character_kind;
4334 /* Mark this type as a C interoperable one. */
4335 tmp_sym->ts.is_c_interop = 1;
4336 tmp_sym->ts.is_iso_c = 1;
4338 /* Tell what f90 type this c interop kind is valid. */
4339 tmp_sym->ts.f90_type = BT_CHARACTER;
4341 /* Say it's from the iso_c_binding module. */
4342 tmp_sym->attr.is_iso_c = 1;
4344 /* Make it use associated. */
4345 tmp_sym->attr.use_assoc = 1;
4348 case ISOCBINDING_PTR:
4349 case ISOCBINDING_FUNPTR:
4351 /* Initialize an integer constant expression node. */
4352 tmp_sym->attr.flavor = FL_DERIVED;
4353 tmp_sym->ts.is_c_interop = 1;
4354 tmp_sym->attr.is_c_interop = 1;
4355 tmp_sym->attr.is_iso_c = 1;
4356 tmp_sym->ts.is_iso_c = 1;
4357 tmp_sym->ts.type = BT_DERIVED;
4359 /* A derived type must have the bind attribute to be
4360 interoperable (J3/04-007, Section 15.2.3), even though
4361 the binding label is not used. */
4362 tmp_sym->attr.is_bind_c = 1;
4364 tmp_sym->attr.referenced = 1;
4366 tmp_sym->ts.u.derived = tmp_sym;
4368 /* Add the symbol created for the derived type to the current ns. */
4369 dt_list_ptr = &(gfc_derived_types);
4370 while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
4371 dt_list_ptr = &((*dt_list_ptr)->next);
4373 /* There is already at least one derived type in the list, so append
4374 the one we're currently building for c_ptr or c_funptr. */
4375 if (*dt_list_ptr != NULL)
4376 dt_list_ptr = &((*dt_list_ptr)->next);
4377 (*dt_list_ptr) = gfc_get_dt_list ();
4378 (*dt_list_ptr)->derived = tmp_sym;
4379 (*dt_list_ptr)->next = NULL;
4381 /* Set up the component of the derived type, which will be
4382 an integer with kind equal to c_ptr_size. Mangle the name of
4383 the field for the c_address to prevent the curious user from
4384 trying to access it from Fortran. */
4385 sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
4386 gfc_add_component (tmp_sym, comp_name, &tmp_comp);
4387 if (tmp_comp == NULL)
4388 gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
4389 "create component for c_address");
4391 tmp_comp->ts.type = BT_INTEGER;
4393 /* Set this because the module will need to read/write this field. */
4394 tmp_comp->ts.f90_type = BT_INTEGER;
4396 /* The kinds for c_ptr and c_funptr are the same. */
4397 index = get_c_kind ("c_ptr", c_interop_kinds_table);
4398 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
4400 tmp_comp->attr.pointer = 0;
4401 tmp_comp->attr.dimension = 0;
4403 /* Mark the component as C interoperable. */
4404 tmp_comp->ts.is_c_interop = 1;
4406 /* Make it use associated (iso_c_binding module). */
4407 tmp_sym->attr.use_assoc = 1;
4410 case ISOCBINDING_NULL_PTR:
4411 case ISOCBINDING_NULL_FUNPTR:
4412 gen_special_c_interop_ptr (s, name, mod_name);
4415 case ISOCBINDING_F_POINTER:
4416 case ISOCBINDING_ASSOCIATED:
4417 case ISOCBINDING_LOC:
4418 case ISOCBINDING_FUNLOC:
4419 case ISOCBINDING_F_PROCPOINTER:
4421 tmp_sym->attr.proc = PROC_MODULE;
4423 /* Use the procedure's name as it is in the iso_c_binding module for
4424 setting the binding label in case the user renamed the symbol. */
4425 sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
4426 c_interop_kinds_table[s].name);
4427 tmp_sym->attr.is_iso_c = 1;
4428 if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
4429 tmp_sym->attr.subroutine = 1;
4432 /* TODO! This needs to be finished more for the expr of the
4433 function or something!
4434 This may not need to be here, because trying to do c_loc
4436 if (s == ISOCBINDING_ASSOCIATED)
4438 tmp_sym->attr.function = 1;
4439 tmp_sym->ts.type = BT_LOGICAL;
4440 tmp_sym->ts.kind = gfc_default_logical_kind;
4441 tmp_sym->result = tmp_sym;
4445 /* Here, we're taking the simple approach. We're defining
4446 c_loc as an external identifier so the compiler will put
4447 what we expect on the stack for the address we want the
4449 tmp_sym->ts.type = BT_DERIVED;
4450 if (s == ISOCBINDING_LOC)
4451 tmp_sym->ts.u.derived =
4452 get_iso_c_binding_dt (ISOCBINDING_PTR);
4454 tmp_sym->ts.u.derived =
4455 get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
4457 if (tmp_sym->ts.u.derived == NULL)
4459 /* Create the necessary derived type so we can continue
4460 processing the file. */
4461 generate_isocbinding_symbol
4462 (mod_name, s == ISOCBINDING_FUNLOC
4463 ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
4464 (const char *)(s == ISOCBINDING_FUNLOC
4465 ? "_gfortran_iso_c_binding_c_funptr"
4466 : "_gfortran_iso_c_binding_c_ptr"));
4467 tmp_sym->ts.u.derived =
4468 get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
4469 ? ISOCBINDING_FUNPTR
4473 /* The function result is itself (no result clause). */
4474 tmp_sym->result = tmp_sym;
4475 tmp_sym->attr.external = 1;
4476 tmp_sym->attr.use_assoc = 0;
4477 tmp_sym->attr.pure = 1;
4478 tmp_sym->attr.if_source = IFSRC_UNKNOWN;
4479 tmp_sym->attr.proc = PROC_UNKNOWN;
4483 tmp_sym->attr.flavor = FL_PROCEDURE;
4484 tmp_sym->attr.contained = 0;
4486 /* Try using this builder routine, with the new and old symbols
4487 both being the generic iso_c proc sym being created. This
4488 will create the formal args (and the new namespace for them).
4489 Don't build an arg list for c_loc because we're going to treat
4490 c_loc as an external procedure. */
4491 if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
4492 /* The 1 says to add any optional args, if applicable. */
4493 build_formal_args (tmp_sym, tmp_sym, 1);
4495 /* Set this after setting up the symbol, to prevent error messages. */
4496 tmp_sym->attr.use_assoc = 1;
4498 /* This symbol will not be referenced directly. It will be
4499 resolved to the implementation for the given f90 kind. */
4500 tmp_sym->attr.referenced = 0;
4510 /* Creates a new symbol based off of an old iso_c symbol, with a new
4511 binding label. This function can be used to create a new,
4512 resolved, version of a procedure symbol for c_f_pointer or
4513 c_f_procpointer that is based on the generic symbols. A new
4514 parameter list is created for the new symbol using
4515 build_formal_args(). The add_optional_flag specifies whether the
4516 to add the optional SHAPE argument. The new symbol is
4520 get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
4521 char *new_binding_label, int add_optional_arg)
4523 gfc_symtree *new_symtree = NULL;
4525 /* See if we have a symbol by that name already available, looking
4526 through any parent namespaces. */
4527 gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
4528 if (new_symtree != NULL)
4529 /* Return the existing symbol. */
4530 return new_symtree->n.sym;
4532 /* Create the symtree/symbol, with attempted host association. */
4533 gfc_get_ha_sym_tree (new_name, &new_symtree);
4534 if (new_symtree == NULL)
4535 gfc_internal_error ("get_iso_c_sym(): Unable to create "
4536 "symtree for '%s'", new_name);
4538 /* Now fill in the fields of the resolved symbol with the old sym. */
4539 strcpy (new_symtree->n.sym->binding_label, new_binding_label);
4540 new_symtree->n.sym->attr = old_sym->attr;
4541 new_symtree->n.sym->ts = old_sym->ts;
4542 new_symtree->n.sym->module = gfc_get_string (old_sym->module);
4543 new_symtree->n.sym->from_intmod = old_sym->from_intmod;
4544 new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
4545 if (old_sym->attr.function)
4546 new_symtree->n.sym->result = new_symtree->n.sym;
4547 /* Build the formal arg list. */
4548 build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
4550 gfc_commit_symbol (new_symtree->n.sym);
4552 return new_symtree->n.sym;
4556 /* Check that a symbol is already typed. If strict is not set, an untyped
4557 symbol is acceptable for non-standard-conforming mode. */
4560 gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
4561 bool strict, locus where)
4565 if (gfc_matching_prefix)
4568 /* Check for the type and try to give it an implicit one. */
4569 if (sym->ts.type == BT_UNKNOWN
4570 && gfc_set_default_type (sym, 0, ns) == FAILURE)
4574 gfc_error ("Symbol '%s' is used before it is typed at %L",
4579 if (gfc_notify_std (GFC_STD_GNU,
4580 "Extension: Symbol '%s' is used before"
4581 " it is typed at %L", sym->name, &where) == FAILURE)
4585 /* Everything is ok. */
4590 /* Construct a typebound-procedure structure. Those are stored in a tentative
4591 list and marked `error' until symbols are committed. */
4594 gfc_get_typebound_proc (void)
4596 gfc_typebound_proc *result;
4597 tentative_tbp *list_node;
4599 result = XCNEW (gfc_typebound_proc);
4602 list_node = XCNEW (tentative_tbp);
4603 list_node->next = tentative_tbp_list;
4604 list_node->proc = result;
4605 tentative_tbp_list = list_node;
4611 /* Get the super-type of a given derived type. */
4614 gfc_get_derived_super_type (gfc_symbol* derived)
4616 if (!derived->attr.extension)
4619 gcc_assert (derived->components);
4620 gcc_assert (derived->components->ts.type == BT_DERIVED);
4621 gcc_assert (derived->components->ts.u.derived);
4623 return derived->components->ts.u.derived;
4627 /* Get the ultimate super-type of a given derived type. */
4630 gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
4632 if (!derived->attr.extension)
4635 derived = gfc_get_derived_super_type (derived);
4637 if (derived->attr.extension)
4638 return gfc_get_ultimate_derived_super_type (derived);
4644 /* Check if a derived type t2 is an extension of (or equal to) a type t1. */
4647 gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
4649 while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
4650 t2 = gfc_get_derived_super_type (t2);
4651 return gfc_compare_derived_types (t1, t2);
4655 /* Check if two typespecs are type compatible (F03:5.1.1.2):
4656 If ts1 is nonpolymorphic, ts2 must be the same type.
4657 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
4660 gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
4662 bool is_class1 = (ts1->type == BT_CLASS);
4663 bool is_class2 = (ts2->type == BT_CLASS);
4664 bool is_derived1 = (ts1->type == BT_DERIVED);
4665 bool is_derived2 = (ts2->type == BT_DERIVED);
4667 if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
4668 return (ts1->type == ts2->type);
4670 if (is_derived1 && is_derived2)
4671 return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
4673 if (is_class1 && is_derived2)
4674 return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4676 else if (is_class1 && is_class2)
4677 return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
4678 ts2->u.derived->components->ts.u.derived);