+
+
+static gfc_symbol *
+get_iso_c_binding_dt (int sym_id)
+{
+ gfc_dt_list *dt_list;
+
+ dt_list = gfc_derived_types;
+
+ /* Loop through the derived types in the name list, searching for
+ the desired symbol from iso_c_binding. Search the parent namespaces
+ if necessary and requested to (parent_flag). */
+ while (dt_list != NULL)
+ {
+ if (dt_list->derived->from_intmod != INTMOD_NONE
+ && dt_list->derived->intmod_sym_id == sym_id)
+ return dt_list->derived;
+
+ dt_list = dt_list->next;
+ }
+
+ return NULL;
+}
+
+
+/* Verifies that the given derived type symbol, derived_sym, is interoperable
+ with C. This is necessary for any derived type that is BIND(C) and for
+ derived types that are parameters to functions that are BIND(C). All
+ fields of the derived type are required to be interoperable, and are tested
+ for such. If an error occurs, the errors are reported here, allowing for
+ multiple errors to be handled for a single derived type. */
+
+gfc_try
+verify_bind_c_derived_type (gfc_symbol *derived_sym)
+{
+ gfc_component *curr_comp = NULL;
+ gfc_try is_c_interop = FAILURE;
+ gfc_try retval = SUCCESS;
+
+ if (derived_sym == NULL)
+ gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
+ "unexpectedly NULL");
+
+ /* If we've already looked at this derived symbol, do not look at it again
+ so we don't repeat warnings/errors. */
+ if (derived_sym->ts.is_c_interop)
+ return SUCCESS;
+
+ /* The derived type must have the BIND attribute to be interoperable
+ J3/04-007, Section 15.2.3. */
+ if (derived_sym->attr.is_bind_c != 1)
+ {
+ derived_sym->ts.is_c_interop = 0;
+ gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
+ "attribute to be C interoperable", derived_sym->name,
+ &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ curr_comp = derived_sym->components;
+
+ /* TODO: is this really an error? */
+ if (curr_comp == NULL)
+ {
+ gfc_error ("Derived type '%s' at %L is empty",
+ derived_sym->name, &(derived_sym->declared_at));
+ return FAILURE;
+ }
+
+ /* Initialize the derived type as being C interoperable.
+ If we find an error in the components, this will be set false. */
+ derived_sym->ts.is_c_interop = 1;
+
+ /* Loop through the list of components to verify that the kind of
+ each is a C interoperable type. */
+ do
+ {
+ /* The components cannot be pointers (fortran sense).
+ J3/04-007, Section 15.2.3, C1505. */
+ if (curr_comp->attr.pointer != 0)
+ {
+ gfc_error ("Component '%s' at %L cannot have the "
+ "POINTER attribute because it is a member "
+ "of the BIND(C) derived type '%s' at %L",
+ curr_comp->name, &(curr_comp->loc),
+ derived_sym->name, &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ if (curr_comp->attr.proc_pointer != 0)
+ {
+ gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
+ " of the BIND(C) derived type '%s' at %L", curr_comp->name,
+ &curr_comp->loc, derived_sym->name,
+ &derived_sym->declared_at);
+ retval = FAILURE;
+ }
+
+ /* The components cannot be allocatable.
+ J3/04-007, Section 15.2.3, C1505. */
+ if (curr_comp->attr.allocatable != 0)
+ {
+ gfc_error ("Component '%s' at %L cannot have the "
+ "ALLOCATABLE attribute because it is a member "
+ "of the BIND(C) derived type '%s' at %L",
+ curr_comp->name, &(curr_comp->loc),
+ derived_sym->name, &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ /* BIND(C) derived types must have interoperable components. */
+ if (curr_comp->ts.type == BT_DERIVED
+ && curr_comp->ts.u.derived->ts.is_iso_c != 1
+ && curr_comp->ts.u.derived != derived_sym)
+ {
+ /* This should be allowed; the draft says a derived-type can not
+ have type parameters if it is has the BIND attribute. Type
+ parameters seem to be for making parameterized derived types.
+ There's no need to verify the type if it is c_ptr/c_funptr. */
+ retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
+ }
+ else
+ {
+ /* Grab the typespec for the given component and test the kind. */
+ is_c_interop = verify_c_interop (&(curr_comp->ts));
+
+ if (is_c_interop != SUCCESS)
+ {
+ /* Report warning and continue since not fatal. The
+ draft does specify a constraint that requires all fields
+ to interoperate, but if the user says real(4), etc., it
+ may interoperate with *something* in C, but the compiler
+ most likely won't know exactly what. Further, it may not
+ interoperate with the same data type(s) in C if the user
+ recompiles with different flags (e.g., -m32 and -m64 on
+ x86_64 and using integer(4) to claim interop with a
+ C_LONG). */
+ if (derived_sym->attr.is_bind_c == 1)
+ /* If the derived type is bind(c), all fields must be
+ interop. */
+ gfc_warning ("Component '%s' in derived type '%s' at %L "
+ "may not be C interoperable, even though "
+ "derived type '%s' is BIND(C)",
+ curr_comp->name, derived_sym->name,
+ &(curr_comp->loc), derived_sym->name);
+ else
+ /* If derived type is param to bind(c) routine, or to one
+ of the iso_c_binding procs, it must be interoperable, so
+ all fields must interop too. */
+ gfc_warning ("Component '%s' in derived type '%s' at %L "
+ "may not be C interoperable",
+ curr_comp->name, derived_sym->name,
+ &(curr_comp->loc));
+ }
+ }
+
+ curr_comp = curr_comp->next;
+ } while (curr_comp != NULL);
+
+
+ /* Make sure we don't have conflicts with the attributes. */
+ if (derived_sym->attr.access == ACCESS_PRIVATE)
+ {
+ gfc_error ("Derived type '%s' at %L cannot be declared with both "
+ "PRIVATE and BIND(C) attributes", derived_sym->name,
+ &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ if (derived_sym->attr.sequence != 0)
+ {
+ gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
+ "attribute because it is BIND(C)", derived_sym->name,
+ &(derived_sym->declared_at));
+ retval = FAILURE;
+ }
+
+ /* Mark the derived type as not being C interoperable if we found an
+ error. If there were only warnings, proceed with the assumption
+ it's interoperable. */
+ if (retval == FAILURE)
+ derived_sym->ts.is_c_interop = 0;
+
+ return retval;
+}
+
+
+/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
+
+static gfc_try
+gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
+ const char *module_name)
+{
+ gfc_symtree *tmp_symtree;
+ gfc_symbol *tmp_sym;
+
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
+
+ if (tmp_symtree != NULL)
+ tmp_sym = tmp_symtree->n.sym;
+ else
+ {
+ tmp_sym = NULL;
+ gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
+ "create symbol for %s", ptr_name);
+ }
+
+ /* Set up the symbol's important fields. Save attr required so we can
+ initialize the ptr to NULL. */
+ tmp_sym->attr.save = SAVE_EXPLICIT;
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->attr.is_c_interop = 1;
+ tmp_sym->ts.is_iso_c = 1;
+ tmp_sym->ts.type = BT_DERIVED;
+
+ /* The c_ptr and c_funptr derived types will provide the
+ definition for c_null_ptr and c_null_funptr, respectively. */
+ if (ptr_id == ISOCBINDING_NULL_PTR)
+ tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
+ else
+ tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+ if (tmp_sym->ts.u.derived == NULL)
+ {
+ /* This can occur if the user forgot to declare c_ptr or
+ c_funptr and they're trying to use one of the procedures
+ that has arg(s) of the missing type. In this case, a
+ regular version of the thing should have been put in the
+ current ns. */
+ generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
+ ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
+ (const char *) (ptr_id == ISOCBINDING_NULL_PTR
+ ? "_gfortran_iso_c_binding_c_ptr"
+ : "_gfortran_iso_c_binding_c_funptr"));
+
+ tmp_sym->ts.u.derived =
+ get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
+ ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
+ }
+
+ /* Module name is some mangled version of iso_c_binding. */
+ tmp_sym->module = gfc_get_string (module_name);
+
+ /* Say it's from the iso_c_binding module. */
+ tmp_sym->attr.is_iso_c = 1;
+
+ tmp_sym->attr.use_assoc = 1;
+ tmp_sym->attr.is_bind_c = 1;
+ /* Set the binding_label. */
+ sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
+
+ /* Set the c_address field of c_null_ptr and c_null_funptr to
+ the value of NULL. */
+ tmp_sym->value = gfc_get_expr ();
+ tmp_sym->value->expr_type = EXPR_STRUCTURE;
+ tmp_sym->value->ts.type = BT_DERIVED;
+ tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
+ /* Create a constructor with no expr, that way we can recognize if the user
+ tries to call the structure constructor for one of the iso_c_binding
+ derived types during resolution (resolve_structure_cons). */
+ tmp_sym->value->value.constructor = gfc_get_constructor ();
+ /* Must declare c_null_ptr and c_null_funptr as having the
+ PARAMETER attribute so they can be used in init expressions. */
+ tmp_sym->attr.flavor = FL_PARAMETER;
+
+ return SUCCESS;
+}
+
+
+/* Add a formal argument, gfc_formal_arglist, to the
+ end of the given list of arguments. Set the reference to the
+ provided symbol, param_sym, in the argument. */
+
+static void
+add_formal_arg (gfc_formal_arglist **head,
+ gfc_formal_arglist **tail,
+ gfc_formal_arglist *formal_arg,
+ gfc_symbol *param_sym)
+{
+ /* Put in list, either as first arg or at the tail (curr arg). */
+ if (*head == NULL)
+ *head = *tail = formal_arg;
+ else
+ {
+ (*tail)->next = formal_arg;
+ (*tail) = formal_arg;
+ }
+
+ (*tail)->sym = param_sym;
+ (*tail)->next = NULL;
+
+ return;
+}
+
+
+/* Generates a symbol representing the CPTR argument to an
+ iso_c_binding procedure. Also, create a gfc_formal_arglist for the
+ CPTR and add it to the provided argument list. */
+
+static void
+gen_cptr_param (gfc_formal_arglist **head,
+ gfc_formal_arglist **tail,
+ const char *module_name,
+ gfc_namespace *ns, const char *c_ptr_name,
+ int iso_c_sym_id)
+{
+ gfc_symbol *param_sym = NULL;
+ gfc_symbol *c_ptr_sym = NULL;
+ gfc_symtree *param_symtree = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ const char *c_ptr_in;
+ const char *c_ptr_type = NULL;
+
+ if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
+ c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
+ else
+ c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
+
+ if(c_ptr_name == NULL)
+ c_ptr_in = "gfc_cptr__";
+ else
+ c_ptr_in = c_ptr_name;
+ gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree, false);
+ if (param_symtree != NULL)
+ param_sym = param_symtree->n.sym;
+ else
+ gfc_internal_error ("gen_cptr_param(): Unable to "
+ "create symbol for %s", c_ptr_in);
+
+ /* Set up the appropriate fields for the new c_ptr param sym. */
+ param_sym->refs++;
+ param_sym->attr.flavor = FL_DERIVED;
+ param_sym->ts.type = BT_DERIVED;
+ param_sym->attr.intent = INTENT_IN;
+ param_sym->attr.dummy = 1;
+
+ /* This will pass the ptr to the iso_c routines as a (void *). */
+ param_sym->attr.value = 1;
+ param_sym->attr.use_assoc = 1;
+
+ /* Get the symbol for c_ptr or c_funptr, no matter what it's name is
+ (user renamed). */
+ if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
+ c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+ else
+ c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
+ if (c_ptr_sym == NULL)
+ {
+ /* This can happen if the user did not define c_ptr but they are
+ trying to use one of the iso_c_binding functions that need it. */
+ if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
+ generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
+ (const char *)c_ptr_type);
+ else
+ generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
+ (const char *)c_ptr_type);
+
+ gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
+ }
+
+ param_sym->ts.u.derived = c_ptr_sym;
+ param_sym->module = gfc_get_string (module_name);
+
+ /* Make new formal arg. */
+ formal_arg = gfc_get_formal_arglist ();
+ /* Add arg to list of formal args (the CPTR arg). */
+ add_formal_arg (head, tail, formal_arg, param_sym);
+}
+
+
+/* Generates a symbol representing the FPTR argument to an
+ iso_c_binding procedure. Also, create a gfc_formal_arglist for the
+ FPTR and add it to the provided argument list. */
+
+static void
+gen_fptr_param (gfc_formal_arglist **head,
+ gfc_formal_arglist **tail,
+ const char *module_name,
+ gfc_namespace *ns, const char *f_ptr_name, int proc)
+{
+ gfc_symbol *param_sym = NULL;
+ gfc_symtree *param_symtree = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ const char *f_ptr_out = "gfc_fptr__";
+
+ if (f_ptr_name != NULL)
+ f_ptr_out = f_ptr_name;
+
+ gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree, false);
+ if (param_symtree != NULL)
+ param_sym = param_symtree->n.sym;
+ else
+ gfc_internal_error ("generateFPtrParam(): Unable to "
+ "create symbol for %s", f_ptr_out);
+
+ /* Set up the necessary fields for the fptr output param sym. */
+ param_sym->refs++;
+ if (proc)
+ param_sym->attr.proc_pointer = 1;
+ else
+ param_sym->attr.pointer = 1;
+ param_sym->attr.dummy = 1;
+ param_sym->attr.use_assoc = 1;
+
+ /* ISO C Binding type to allow any pointer type as actual param. */
+ param_sym->ts.type = BT_VOID;
+ param_sym->module = gfc_get_string (module_name);
+
+ /* Make the arg. */
+ formal_arg = gfc_get_formal_arglist ();
+ /* Add arg to list of formal args. */
+ add_formal_arg (head, tail, formal_arg, param_sym);
+}
+
+
+/* Generates a symbol representing the optional SHAPE argument for the
+ iso_c_binding c_f_pointer() procedure. Also, create a
+ gfc_formal_arglist for the SHAPE and add it to the provided
+ argument list. */
+
+static void
+gen_shape_param (gfc_formal_arglist **head,
+ gfc_formal_arglist **tail,
+ const char *module_name,
+ gfc_namespace *ns, const char *shape_param_name)
+{
+ gfc_symbol *param_sym = NULL;
+ gfc_symtree *param_symtree = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ const char *shape_param = "gfc_shape_array__";
+ int i;
+
+ if (shape_param_name != NULL)
+ shape_param = shape_param_name;
+
+ gfc_get_sym_tree (shape_param, ns, ¶m_symtree, false);
+ if (param_symtree != NULL)
+ param_sym = param_symtree->n.sym;
+ else
+ gfc_internal_error ("generateShapeParam(): Unable to "
+ "create symbol for %s", shape_param);
+
+ /* Set up the necessary fields for the shape input param sym. */
+ param_sym->refs++;
+ param_sym->attr.dummy = 1;
+ param_sym->attr.use_assoc = 1;
+
+ /* Integer array, rank 1, describing the shape of the object. Make it's
+ type BT_VOID initially so we can accept any type/kind combination of
+ integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it
+ of BT_INTEGER type. */
+ param_sym->ts.type = BT_VOID;
+
+ /* Initialize the kind to default integer. However, it will be overridden
+ during resolution to match the kind of the SHAPE parameter given as
+ the actual argument (to allow for any valid integer kind). */
+ param_sym->ts.kind = gfc_default_integer_kind;
+ param_sym->as = gfc_get_array_spec ();
+
+ /* Clear out the dimension info for the array. */
+ for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+ {
+ param_sym->as->lower[i] = NULL;
+ param_sym->as->upper[i] = NULL;
+ }
+ param_sym->as->rank = 1;
+ param_sym->as->lower[0] = gfc_int_expr (1);
+
+ /* The extent is unknown until we get it. The length give us
+ the rank the incoming pointer. */
+ param_sym->as->type = AS_ASSUMED_SHAPE;
+
+ /* The arg is also optional; it is required iff the second arg
+ (fptr) is to an array, otherwise, it's ignored. */
+ param_sym->attr.optional = 1;
+ param_sym->attr.intent = INTENT_IN;
+ param_sym->attr.dimension = 1;
+ param_sym->module = gfc_get_string (module_name);
+
+ /* Make the arg. */
+ formal_arg = gfc_get_formal_arglist ();
+ /* Add arg to list of formal args. */
+ add_formal_arg (head, tail, formal_arg, param_sym);
+}
+
+
+/* Add a procedure interface to the given symbol (i.e., store a
+ reference to the list of formal arguments). */
+
+static void
+add_proc_interface (gfc_symbol *sym, ifsrc source,
+ gfc_formal_arglist *formal)
+{
+
+ sym->formal = formal;
+ sym->attr.if_source = source;
+}
+
+
+/* Copy the formal args from an existing symbol, src, into a new
+ symbol, dest. New formal args are created, and the description of
+ each arg is set according to the existing ones. This function is
+ used when creating procedure declaration variables from a procedure
+ declaration statement (see match_proc_decl()) to create the formal
+ args based on the args of a given named interface. */
+
+void
+gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
+{
+ gfc_formal_arglist *head = NULL;
+ gfc_formal_arglist *tail = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ gfc_formal_arglist *curr_arg = NULL;
+ gfc_formal_arglist *formal_prev = NULL;
+ /* Save current namespace so we can change it for formal args. */
+ gfc_namespace *parent_ns = gfc_current_ns;
+
+ /* Create a new namespace, which will be the formal ns (namespace
+ of the formal args). */
+ gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+ gfc_current_ns->proc_name = dest;
+
+ for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+ {
+ formal_arg = gfc_get_formal_arglist ();
+ gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
+
+ /* May need to copy more info for the symbol. */
+ formal_arg->sym->attr = curr_arg->sym->attr;
+ formal_arg->sym->ts = curr_arg->sym->ts;
+ formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
+ gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
+
+ /* If this isn't the first arg, set up the next ptr. For the
+ last arg built, the formal_arg->next will never get set to
+ anything other than NULL. */
+ if (formal_prev != NULL)
+ formal_prev->next = formal_arg;
+ else
+ formal_arg->next = NULL;
+
+ formal_prev = formal_arg;
+
+ /* Add arg to list of formal args. */
+ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+ }
+
+ /* Add the interface to the symbol. */
+ add_proc_interface (dest, IFSRC_DECL, head);
+
+ /* Store the formal namespace information. */
+ if (dest->formal != NULL)
+ /* The current ns should be that for the dest proc. */
+ dest->formal_ns = gfc_current_ns;
+ /* Restore the current namespace to what it was on entry. */
+ gfc_current_ns = parent_ns;
+}
+
+
+void
+gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src)
+{
+ gfc_formal_arglist *head = NULL;
+ gfc_formal_arglist *tail = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ gfc_intrinsic_arg *curr_arg = NULL;
+ gfc_formal_arglist *formal_prev = NULL;
+ /* Save current namespace so we can change it for formal args. */
+ gfc_namespace *parent_ns = gfc_current_ns;
+
+ /* Create a new namespace, which will be the formal ns (namespace
+ of the formal args). */
+ gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+ gfc_current_ns->proc_name = dest;
+
+ for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+ {
+ formal_arg = gfc_get_formal_arglist ();
+ gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
+
+ /* May need to copy more info for the symbol. */
+ formal_arg->sym->ts = curr_arg->ts;
+ formal_arg->sym->attr.optional = curr_arg->optional;
+ formal_arg->sym->attr.intent = curr_arg->intent;
+ formal_arg->sym->attr.flavor = FL_VARIABLE;
+ formal_arg->sym->attr.dummy = 1;
+
+ if (formal_arg->sym->ts.type == BT_CHARACTER)
+ formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+
+ /* If this isn't the first arg, set up the next ptr. For the
+ last arg built, the formal_arg->next will never get set to
+ anything other than NULL. */
+ if (formal_prev != NULL)
+ formal_prev->next = formal_arg;
+ else
+ formal_arg->next = NULL;
+
+ formal_prev = formal_arg;
+
+ /* Add arg to list of formal args. */
+ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+ }
+
+ /* Add the interface to the symbol. */
+ add_proc_interface (dest, IFSRC_DECL, head);
+
+ /* Store the formal namespace information. */
+ if (dest->formal != NULL)
+ /* The current ns should be that for the dest proc. */
+ dest->formal_ns = gfc_current_ns;
+ /* Restore the current namespace to what it was on entry. */
+ gfc_current_ns = parent_ns;
+}
+
+
+void
+gfc_copy_formal_args_ppc (gfc_component *dest, gfc_symbol *src)
+{
+ gfc_formal_arglist *head = NULL;
+ gfc_formal_arglist *tail = NULL;
+ gfc_formal_arglist *formal_arg = NULL;
+ gfc_formal_arglist *curr_arg = NULL;
+ gfc_formal_arglist *formal_prev = NULL;
+ /* Save current namespace so we can change it for formal args. */
+ gfc_namespace *parent_ns = gfc_current_ns;
+
+ /* Create a new namespace, which will be the formal ns (namespace
+ of the formal args). */
+ gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+ /* TODO: gfc_current_ns->proc_name = dest;*/
+
+ for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+ {
+ formal_arg = gfc_get_formal_arglist ();
+ gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
+
+ /* May need to copy more info for the symbol. */
+ formal_arg->sym->attr = curr_arg->sym->attr;
+ formal_arg->sym->ts = curr_arg->sym->ts;
+ formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as);
+ gfc_copy_formal_args (formal_arg->sym, curr_arg->sym);
+
+ /* If this isn't the first arg, set up the next ptr. For the
+ last arg built, the formal_arg->next will never get set to
+ anything other than NULL. */
+ if (formal_prev != NULL)
+ formal_prev->next = formal_arg;
+ else
+ formal_arg->next = NULL;
+
+ formal_prev = formal_arg;
+
+ /* Add arg to list of formal args. */
+ add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+ }
+
+ /* Add the interface to the symbol. */
+ dest->formal = head;
+ dest->attr.if_source = IFSRC_DECL;
+
+ /* Store the formal namespace information. */
+ if (dest->formal != NULL)
+ /* The current ns should be that for the dest proc. */
+ dest->formal_ns = gfc_current_ns;
+ /* Restore the current namespace to what it was on entry. */
+ gfc_current_ns = parent_ns;
+}
+
+
+/* Builds the parameter list for the iso_c_binding procedure
+ c_f_pointer or c_f_procpointer. The old_sym typically refers to a
+ generic version of either the c_f_pointer or c_f_procpointer
+ functions. The new_proc_sym represents a "resolved" version of the
+ symbol. The functions are resolved to match the types of their
+ parameters; for example, c_f_pointer(cptr, fptr) would resolve to
+ something similar to c_f_pointer_i4 if the type of data object fptr
+ pointed to was a default integer. The actual name of the resolved
+ procedure symbol is further mangled with the module name, etc., but
+ the idea holds true. */
+
+static void
+build_formal_args (gfc_symbol *new_proc_sym,
+ gfc_symbol *old_sym, int add_optional_arg)
+{
+ gfc_formal_arglist *head = NULL, *tail = NULL;
+ gfc_namespace *parent_ns = NULL;
+
+ parent_ns = gfc_current_ns;
+ /* Create a new namespace, which will be the formal ns (namespace
+ of the formal args). */
+ gfc_current_ns = gfc_get_namespace(parent_ns, 0);
+ gfc_current_ns->proc_name = new_proc_sym;
+
+ /* Generate the params. */
+ if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
+ {
+ gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "cptr", old_sym->intmod_sym_id);
+ gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "fptr", 1);
+ }
+ else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
+ {
+ gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "cptr", old_sym->intmod_sym_id);
+ gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "fptr", 0);
+ /* If we're dealing with c_f_pointer, it has an optional third arg. */
+ gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
+ gfc_current_ns, "shape");
+
+ }
+ else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
+ {
+ /* c_associated has one required arg and one optional; both
+ are c_ptrs. */
+ gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED);
+ if (add_optional_arg)
+ {
+ gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED);
+ /* The last param is optional so mark it as such. */
+ tail->sym->attr.optional = 1;
+ }
+ }
+
+ /* Add the interface (store formal args to new_proc_sym). */
+ add_proc_interface (new_proc_sym, IFSRC_DECL, head);
+
+ /* Set up the formal_ns pointer to the one created for the
+ new procedure so it'll get cleaned up during gfc_free_symbol(). */
+ new_proc_sym->formal_ns = gfc_current_ns;
+
+ gfc_current_ns = parent_ns;
+}
+
+static int
+std_for_isocbinding_symbol (int id)
+{
+ switch (id)
+ {
+#define NAMED_INTCST(a,b,c,d) \
+ case a:\
+ return d;
+#include "iso-c-binding.def"
+#undef NAMED_INTCST
+ default:
+ return GFC_STD_F2003;
+ }
+}
+
+/* Generate the given set of C interoperable kind objects, or all
+ interoperable kinds. This function will only be given kind objects
+ for valid iso_c_binding defined types because this is verified when
+ the 'use' statement is parsed. If the user gives an 'only' clause,
+ the specific kinds are looked up; if they don't exist, an error is
+ reported. If the user does not give an 'only' clause, all
+ iso_c_binding symbols are generated. If a list of specific kinds
+ is given, it must have a NULL in the first empty spot to mark the
+ end of the list. */
+
+
+void
+generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
+ const char *local_name)
+{
+ const char *const name = (local_name && local_name[0]) ? local_name
+ : c_interop_kinds_table[s].name;
+ gfc_symtree *tmp_symtree = NULL;
+ gfc_symbol *tmp_sym = NULL;
+ gfc_dt_list **dt_list_ptr = NULL;
+ gfc_component *tmp_comp = NULL;
+ char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
+ int index;
+
+ if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
+ return;
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+
+ /* Already exists in this scope so don't re-add it.
+ TODO: we should probably check that it's really the same symbol. */
+ if (tmp_symtree != NULL)
+ return;
+
+ /* Create the sym tree in the current ns. */
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+ if (tmp_symtree)
+ tmp_sym = tmp_symtree->n.sym;
+ else
+ gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
+ "create symbol");
+
+ /* Say what module this symbol belongs to. */
+ tmp_sym->module = gfc_get_string (mod_name);
+ tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
+ tmp_sym->intmod_sym_id = s;
+
+ switch (s)
+ {
+
+#define NAMED_INTCST(a,b,c,d) case a :
+#define NAMED_REALCST(a,b,c) case a :
+#define NAMED_CMPXCST(a,b,c) case a :
+#define NAMED_LOGCST(a,b,c) case a :
+#define NAMED_CHARKNDCST(a,b,c) case a :
+#include "iso-c-binding.def"
+
+ tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
+
+ /* Initialize an integer constant expression node. */
+ tmp_sym->attr.flavor = FL_PARAMETER;
+ tmp_sym->ts.type = BT_INTEGER;
+ tmp_sym->ts.kind = gfc_default_integer_kind;
+
+ /* Mark this type as a C interoperable one. */
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->ts.is_iso_c = 1;
+ tmp_sym->value->ts.is_c_interop = 1;
+ tmp_sym->value->ts.is_iso_c = 1;
+ tmp_sym->attr.is_c_interop = 1;
+
+ /* Tell what f90 type this c interop kind is valid. */
+ tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
+
+ /* Say it's from the iso_c_binding module. */
+ tmp_sym->attr.is_iso_c = 1;
+
+ /* Make it use associated. */
+ tmp_sym->attr.use_assoc = 1;
+ break;
+
+
+#define NAMED_CHARCST(a,b,c) case a :
+#include "iso-c-binding.def"
+
+ /* Initialize an integer constant expression node for the
+ length of the character. */
+ tmp_sym->value = gfc_get_expr ();
+ tmp_sym->value->expr_type = EXPR_CONSTANT;
+ tmp_sym->value->ts.type = BT_CHARACTER;
+ tmp_sym->value->ts.kind = gfc_default_character_kind;
+ tmp_sym->value->where = gfc_current_locus;
+ tmp_sym->value->ts.is_c_interop = 1;
+ tmp_sym->value->ts.is_iso_c = 1;
+ tmp_sym->value->value.character.length = 1;
+ tmp_sym->value->value.character.string = gfc_get_wide_string (2);
+ tmp_sym->value->value.character.string[0]
+ = (gfc_char_t) c_interop_kinds_table[s].value;
+ tmp_sym->value->value.character.string[1] = '\0';
+ tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ tmp_sym->ts.u.cl->length = gfc_int_expr (1);
+
+ /* May not need this in both attr and ts, but do need in
+ attr for writing module file. */
+ tmp_sym->attr.is_c_interop = 1;
+
+ tmp_sym->attr.flavor = FL_PARAMETER;
+ tmp_sym->ts.type = BT_CHARACTER;
+
+ /* Need to set it to the C_CHAR kind. */
+ tmp_sym->ts.kind = gfc_default_character_kind;
+
+ /* Mark this type as a C interoperable one. */
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->ts.is_iso_c = 1;
+
+ /* Tell what f90 type this c interop kind is valid. */
+ tmp_sym->ts.f90_type = BT_CHARACTER;
+
+ /* Say it's from the iso_c_binding module. */
+ tmp_sym->attr.is_iso_c = 1;
+
+ /* Make it use associated. */
+ tmp_sym->attr.use_assoc = 1;
+ break;
+
+ case ISOCBINDING_PTR:
+ case ISOCBINDING_FUNPTR:
+
+ /* Initialize an integer constant expression node. */
+ tmp_sym->attr.flavor = FL_DERIVED;
+ tmp_sym->ts.is_c_interop = 1;
+ tmp_sym->attr.is_c_interop = 1;
+ tmp_sym->attr.is_iso_c = 1;
+ tmp_sym->ts.is_iso_c = 1;
+ tmp_sym->ts.type = BT_DERIVED;
+
+ /* A derived type must have the bind attribute to be
+ interoperable (J3/04-007, Section 15.2.3), even though
+ the binding label is not used. */
+ tmp_sym->attr.is_bind_c = 1;
+
+ tmp_sym->attr.referenced = 1;
+
+ tmp_sym->ts.u.derived = tmp_sym;
+
+ /* Add the symbol created for the derived type to the current ns. */
+ dt_list_ptr = &(gfc_derived_types);
+ while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
+ dt_list_ptr = &((*dt_list_ptr)->next);
+
+ /* There is already at least one derived type in the list, so append
+ the one we're currently building for c_ptr or c_funptr. */
+ if (*dt_list_ptr != NULL)
+ dt_list_ptr = &((*dt_list_ptr)->next);
+ (*dt_list_ptr) = gfc_get_dt_list ();
+ (*dt_list_ptr)->derived = tmp_sym;
+ (*dt_list_ptr)->next = NULL;
+
+ /* Set up the component of the derived type, which will be
+ an integer with kind equal to c_ptr_size. Mangle the name of
+ the field for the c_address to prevent the curious user from
+ trying to access it from Fortran. */
+ sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
+ gfc_add_component (tmp_sym, comp_name, &tmp_comp);
+ if (tmp_comp == NULL)
+ gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
+ "create component for c_address");
+
+ tmp_comp->ts.type = BT_INTEGER;
+
+ /* Set this because the module will need to read/write this field. */
+ tmp_comp->ts.f90_type = BT_INTEGER;
+
+ /* The kinds for c_ptr and c_funptr are the same. */
+ index = get_c_kind ("c_ptr", c_interop_kinds_table);
+ tmp_comp->ts.kind = c_interop_kinds_table[index].value;
+
+ tmp_comp->attr.pointer = 0;
+ tmp_comp->attr.dimension = 0;
+
+ /* Mark the component as C interoperable. */
+ tmp_comp->ts.is_c_interop = 1;
+
+ /* Make it use associated (iso_c_binding module). */
+ tmp_sym->attr.use_assoc = 1;
+ break;
+
+ case ISOCBINDING_NULL_PTR:
+ case ISOCBINDING_NULL_FUNPTR:
+ gen_special_c_interop_ptr (s, name, mod_name);
+ break;
+
+ case ISOCBINDING_F_POINTER:
+ case ISOCBINDING_ASSOCIATED:
+ case ISOCBINDING_LOC:
+ case ISOCBINDING_FUNLOC:
+ case ISOCBINDING_F_PROCPOINTER:
+
+ tmp_sym->attr.proc = PROC_MODULE;
+
+ /* Use the procedure's name as it is in the iso_c_binding module for
+ setting the binding label in case the user renamed the symbol. */
+ sprintf (tmp_sym->binding_label, "%s_%s", mod_name,
+ c_interop_kinds_table[s].name);
+ tmp_sym->attr.is_iso_c = 1;
+ if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER)
+ tmp_sym->attr.subroutine = 1;
+ else
+ {
+ /* TODO! This needs to be finished more for the expr of the
+ function or something!
+ This may not need to be here, because trying to do c_loc
+ as an external. */
+ if (s == ISOCBINDING_ASSOCIATED)
+ {
+ tmp_sym->attr.function = 1;
+ tmp_sym->ts.type = BT_LOGICAL;
+ tmp_sym->ts.kind = gfc_default_logical_kind;
+ tmp_sym->result = tmp_sym;
+ }
+ else
+ {
+ /* Here, we're taking the simple approach. We're defining
+ c_loc as an external identifier so the compiler will put
+ what we expect on the stack for the address we want the
+ C address of. */
+ tmp_sym->ts.type = BT_DERIVED;
+ if (s == ISOCBINDING_LOC)
+ tmp_sym->ts.u.derived =
+ get_iso_c_binding_dt (ISOCBINDING_PTR);
+ else
+ tmp_sym->ts.u.derived =
+ get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
+
+ if (tmp_sym->ts.u.derived == NULL)
+ {
+ /* Create the necessary derived type so we can continue
+ processing the file. */
+ generate_isocbinding_symbol
+ (mod_name, s == ISOCBINDING_FUNLOC
+ ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
+ (const char *)(s == ISOCBINDING_FUNLOC
+ ? "_gfortran_iso_c_binding_c_funptr"
+ : "_gfortran_iso_c_binding_c_ptr"));
+ tmp_sym->ts.u.derived =
+ get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
+ ? ISOCBINDING_FUNPTR
+ : ISOCBINDING_PTR);
+ }
+
+ /* The function result is itself (no result clause). */
+ tmp_sym->result = tmp_sym;
+ tmp_sym->attr.external = 1;
+ tmp_sym->attr.use_assoc = 0;
+ tmp_sym->attr.pure = 1;
+ tmp_sym->attr.if_source = IFSRC_UNKNOWN;
+ tmp_sym->attr.proc = PROC_UNKNOWN;
+ }
+ }
+
+ tmp_sym->attr.flavor = FL_PROCEDURE;
+ tmp_sym->attr.contained = 0;
+
+ /* Try using this builder routine, with the new and old symbols
+ both being the generic iso_c proc sym being created. This
+ will create the formal args (and the new namespace for them).
+ Don't build an arg list for c_loc because we're going to treat
+ c_loc as an external procedure. */
+ if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC)
+ /* The 1 says to add any optional args, if applicable. */
+ build_formal_args (tmp_sym, tmp_sym, 1);
+
+ /* Set this after setting up the symbol, to prevent error messages. */
+ tmp_sym->attr.use_assoc = 1;
+
+ /* This symbol will not be referenced directly. It will be
+ resolved to the implementation for the given f90 kind. */
+ tmp_sym->attr.referenced = 0;
+
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
+
+/* Creates a new symbol based off of an old iso_c symbol, with a new
+ binding label. This function can be used to create a new,
+ resolved, version of a procedure symbol for c_f_pointer or
+ c_f_procpointer that is based on the generic symbols. A new
+ parameter list is created for the new symbol using
+ build_formal_args(). The add_optional_flag specifies whether the
+ to add the optional SHAPE argument. The new symbol is
+ returned. */
+
+gfc_symbol *
+get_iso_c_sym (gfc_symbol *old_sym, char *new_name,
+ char *new_binding_label, int add_optional_arg)
+{
+ gfc_symtree *new_symtree = NULL;
+
+ /* See if we have a symbol by that name already available, looking
+ through any parent namespaces. */
+ gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree);
+ if (new_symtree != NULL)
+ /* Return the existing symbol. */
+ return new_symtree->n.sym;
+
+ /* Create the symtree/symbol, with attempted host association. */
+ gfc_get_ha_sym_tree (new_name, &new_symtree);
+ if (new_symtree == NULL)
+ gfc_internal_error ("get_iso_c_sym(): Unable to create "
+ "symtree for '%s'", new_name);
+
+ /* Now fill in the fields of the resolved symbol with the old sym. */
+ strcpy (new_symtree->n.sym->binding_label, new_binding_label);
+ new_symtree->n.sym->attr = old_sym->attr;
+ new_symtree->n.sym->ts = old_sym->ts;
+ new_symtree->n.sym->module = gfc_get_string (old_sym->module);
+ new_symtree->n.sym->from_intmod = old_sym->from_intmod;
+ new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id;
+ /* Build the formal arg list. */
+ build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg);
+
+ gfc_commit_symbol (new_symtree->n.sym);
+
+ return new_symtree->n.sym;
+}
+
+
+/* Check that a symbol is already typed. If strict is not set, an untyped
+ symbol is acceptable for non-standard-conforming mode. */
+
+gfc_try
+gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
+ bool strict, locus where)
+{
+ gcc_assert (sym);
+
+ if (gfc_matching_prefix)
+ return SUCCESS;
+
+ /* Check for the type and try to give it an implicit one. */
+ if (sym->ts.type == BT_UNKNOWN
+ && gfc_set_default_type (sym, 0, ns) == FAILURE)
+ {
+ if (strict)
+ {
+ gfc_error ("Symbol '%s' is used before it is typed at %L",
+ sym->name, &where);
+ return FAILURE;
+ }
+
+ if (gfc_notify_std (GFC_STD_GNU,
+ "Extension: Symbol '%s' is used before"
+ " it is typed at %L", sym->name, &where) == FAILURE)
+ return FAILURE;
+ }
+
+ /* Everything is ok. */
+ return SUCCESS;
+}
+
+
+/* Construct a typebound-procedure structure. Those are stored in a tentative
+ list and marked `error' until symbols are committed. */
+
+gfc_typebound_proc*
+gfc_get_typebound_proc (void)
+{
+ gfc_typebound_proc *result;
+ tentative_tbp *list_node;
+
+ result = XCNEW (gfc_typebound_proc);
+ result->error = 1;
+
+ list_node = XCNEW (tentative_tbp);
+ list_node->next = tentative_tbp_list;
+ list_node->proc = result;
+ tentative_tbp_list = list_node;
+
+ return result;
+}
+
+
+/* Get the super-type of a given derived type. */
+
+gfc_symbol*
+gfc_get_derived_super_type (gfc_symbol* derived)
+{
+ if (!derived->attr.extension)
+ return NULL;
+
+ gcc_assert (derived->components);
+ gcc_assert (derived->components->ts.type == BT_DERIVED);
+ gcc_assert (derived->components->ts.u.derived);
+
+ return derived->components->ts.u.derived;
+}
+
+
+/* Get the ultimate super-type of a given derived type. */
+
+gfc_symbol*
+gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
+{
+ if (!derived->attr.extension)
+ return NULL;
+
+ derived = gfc_get_derived_super_type (derived);
+
+ if (derived->attr.extension)
+ return gfc_get_ultimate_derived_super_type (derived);
+ else
+ return derived;
+}
+
+
+/* Check if a derived type t2 is an extension of (or equal to) a type t1. */
+
+bool
+gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
+{
+ while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
+ t2 = gfc_get_derived_super_type (t2);
+ return gfc_compare_derived_types (t1, t2);
+}
+
+
+/* Check if two typespecs are type compatible (F03:5.1.1.2):
+ If ts1 is nonpolymorphic, ts2 must be the same type.
+ If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
+
+bool
+gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
+{
+ gfc_component *cmp1, *cmp2;
+
+ bool is_class1 = (ts1->type == BT_CLASS);
+ bool is_class2 = (ts2->type == BT_CLASS);
+ bool is_derived1 = (ts1->type == BT_DERIVED);
+ bool is_derived2 = (ts2->type == BT_DERIVED);
+
+ if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2)
+ return (ts1->type == ts2->type);
+
+ if (is_derived1 && is_derived2)
+ return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
+
+ cmp1 = cmp2 = NULL;
+
+ if (is_class1)
+ {
+ cmp1 = gfc_find_component (ts1->u.derived, "$data", true, false);
+ if (cmp1 == NULL)
+ return 0;
+ }
+
+ if (is_class2)
+ {
+ cmp2 = gfc_find_component (ts2->u.derived, "$data", true, false);
+ if (cmp2 == NULL)
+ return 0;
+ }
+
+ if (is_class1 && is_derived2)
+ return gfc_type_is_extension_of (cmp1->ts.u.derived, ts2->u.derived);
+
+ else if (is_class1 && is_class2)
+ return gfc_type_is_extension_of (cmp1->ts.u.derived, cmp2->ts.u.derived);
+
+ else
+ return 0;
+}
+
+
+/* Build a polymorphic CLASS entity, using the symbol that comes from
+ build_sym. A CLASS entity is represented by an encapsulating type,
+ which contains the declared type as '$data' component, plus a pointer
+ component '$vptr' which determines the dynamic type. */
+
+gfc_try
+gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
+ gfc_array_spec **as)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 5];
+ gfc_symbol *fclass;
+ gfc_symbol *vtab;
+ gfc_component *c;
+
+ /* Determine the name of the encapsulating type. */
+ if ((*as) && (*as)->rank && attr->allocatable)
+ sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
+ else if ((*as) && (*as)->rank)
+ sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
+ else if (attr->allocatable)
+ sprintf (name, ".class.%s.a", ts->u.derived->name);
+ else
+ sprintf (name, ".class.%s", ts->u.derived->name);
+
+ gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
+ if (fclass == NULL)
+ {
+ gfc_symtree *st;
+ /* If not there, create a new symbol. */
+ fclass = gfc_new_symbol (name, ts->u.derived->ns);
+ st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
+ st->n.sym = fclass;
+ gfc_set_sym_referenced (fclass);
+ fclass->refs++;
+ fclass->ts.type = BT_UNKNOWN;
+ fclass->attr.abstract = ts->u.derived->attr.abstract;
+ if (ts->u.derived->f2k_derived)
+ fclass->f2k_derived = gfc_get_namespace (NULL, 0);
+ if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
+ NULL, &gfc_current_locus) == FAILURE)
+ return FAILURE;
+
+ /* Add component '$data'. */
+ if (gfc_add_component (fclass, "$data", &c) == FAILURE)
+ return FAILURE;
+ c->ts = *ts;
+ c->ts.type = BT_DERIVED;
+ c->attr.access = ACCESS_PRIVATE;
+ c->ts.u.derived = ts->u.derived;
+ c->attr.class_pointer = attr->pointer;
+ c->attr.pointer = attr->pointer || attr->dummy;
+ c->attr.allocatable = attr->allocatable;
+ c->attr.dimension = attr->dimension;
+ c->attr.abstract = ts->u.derived->attr.abstract;
+ c->as = (*as);
+ c->initializer = gfc_get_expr ();
+ c->initializer->expr_type = EXPR_NULL;
+
+ /* Add component '$vptr'. */
+ if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
+ return FAILURE;
+ c->ts.type = BT_DERIVED;
+ vtab = gfc_find_derived_vtab (ts->u.derived);
+ gcc_assert (vtab);
+ c->ts.u.derived = vtab->ts.u.derived;
+ c->attr.pointer = 1;
+ c->initializer = gfc_get_expr ();
+ c->initializer->expr_type = EXPR_NULL;
+ }
+
+ /* Since the extension field is 8 bit wide, we can only have
+ up to 255 extension levels. */
+ if (ts->u.derived->attr.extension == 255)
+ {
+ gfc_error ("Maximum extension level reached with type '%s' at %L",
+ ts->u.derived->name, &ts->u.derived->declared_at);
+ return FAILURE;
+ }
+
+ fclass->attr.extension = ts->u.derived->attr.extension + 1;
+ fclass->attr.is_class = 1;
+ ts->u.derived = fclass;
+ attr->allocatable = attr->pointer = attr->dimension = 0;
+ (*as) = NULL; /* XXX */
+ return SUCCESS;
+}
+
+
+/* Find the symbol for a derived type's vtab. */
+
+gfc_symbol *
+gfc_find_derived_vtab (gfc_symbol *derived)
+{
+ gfc_namespace *ns;
+ gfc_symbol *vtab = NULL, *vtype = NULL;
+ char name[2 * GFC_MAX_SYMBOL_LEN + 8];
+
+ ns = gfc_current_ns;
+
+ for (; ns; ns = ns->parent)
+ if (!ns->parent)
+ break;
+
+ if (ns)
+ {
+ sprintf (name, "vtab$%s", derived->name);
+ gfc_find_symbol (name, ns, 0, &vtab);
+
+ if (vtab == NULL)
+ {
+ gfc_get_symbol (name, ns, &vtab);
+ vtab->ts.type = BT_DERIVED;
+ vtab->attr.flavor = FL_VARIABLE;
+ vtab->attr.target = 1;
+ vtab->attr.save = SAVE_EXPLICIT;
+ vtab->attr.vtab = 1;
+ vtab->attr.access = ACCESS_PRIVATE;
+ vtab->refs++;
+ gfc_set_sym_referenced (vtab);
+ sprintf (name, "vtype$%s", derived->name);
+
+ gfc_find_symbol (name, ns, 0, &vtype);
+ if (vtype == NULL)
+ {
+ gfc_component *c;
+ gfc_symbol *parent = NULL, *parent_vtab = NULL;
+
+ gfc_get_symbol (name, ns, &vtype);
+ if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
+ NULL, &gfc_current_locus) == FAILURE)
+ return NULL;
+ vtype->refs++;
+ gfc_set_sym_referenced (vtype);
+ vtype->attr.access = ACCESS_PRIVATE;
+
+ /* Add component '$hash'. */
+ if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
+ return NULL;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = 4;
+ c->attr.access = ACCESS_PRIVATE;
+ c->initializer = gfc_int_expr (derived->hash_value);
+
+ /* Add component '$size'. */
+ if (gfc_add_component (vtype, "$size", &c) == FAILURE)
+ return NULL;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = 4;
+ c->attr.access = ACCESS_PRIVATE;
+ /* Remember the derived type in ts.u.derived,
+ so that the correct initializer can be set later on
+ (in gfc_conv_structure). */
+ c->ts.u.derived = derived;
+ c->initializer = gfc_int_expr (0);
+
+ /* Add component $extends. */
+ if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
+ return NULL;
+ c->attr.pointer = 1;
+ c->attr.access = ACCESS_PRIVATE;
+ c->initializer = gfc_get_expr ();
+ parent = gfc_get_derived_super_type (derived);
+ if (parent)
+ {
+ parent_vtab = gfc_find_derived_vtab (parent);
+ c->ts.type = BT_DERIVED;
+ c->ts.u.derived = parent_vtab->ts.u.derived;
+ c->initializer->expr_type = EXPR_VARIABLE;
+ gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
+ &c->initializer->symtree);
+ }
+ else
+ {
+ c->ts.type = BT_DERIVED;
+ c->ts.u.derived = vtype;
+ c->initializer->expr_type = EXPR_NULL;
+ }
+ }
+ vtab->ts.u.derived = vtype;
+
+ vtab->value = gfc_default_initializer (&vtab->ts);
+ }
+ }
+
+ return vtab;
+}
+
+
+/* General worker function to find either a type-bound procedure or a
+ type-bound user operator. */
+
+static gfc_symtree*
+find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess, bool uop,
+ locus* where)
+{
+ gfc_symtree* res;
+ gfc_symtree* root;
+
+ /* Set correct symbol-root. */
+ gcc_assert (derived->f2k_derived);
+ root = (uop ? derived->f2k_derived->tb_uop_root
+ : derived->f2k_derived->tb_sym_root);
+
+ /* Set default to failure. */
+ if (t)
+ *t = FAILURE;
+
+ /* Try to find it in the current type's namespace. */
+ res = gfc_find_symtree (root, name);
+ if (res && res->n.tb && !res->n.tb->error)
+ {
+ /* We found one. */
+ if (t)
+ *t = SUCCESS;
+
+ if (!noaccess && derived->attr.use_assoc
+ && res->n.tb->access == ACCESS_PRIVATE)
+ {
+ if (where)
+ gfc_error ("'%s' of '%s' is PRIVATE at %L",
+ name, derived->name, where);
+ if (t)
+ *t = FAILURE;
+ }
+
+ return res;
+ }
+
+ /* Otherwise, recurse on parent type if derived is an extension. */
+ if (derived->attr.extension)
+ {
+ gfc_symbol* super_type;
+ super_type = gfc_get_derived_super_type (derived);
+ gcc_assert (super_type);
+
+ return find_typebound_proc_uop (super_type, t, name,
+ noaccess, uop, where);
+ }
+
+ /* Nothing found. */
+ return NULL;
+}
+
+
+/* Find a type-bound procedure or user operator by name for a derived-type
+ (looking recursively through the super-types). */
+
+gfc_symtree*
+gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess, locus* where)
+{
+ return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
+}
+
+gfc_symtree*
+gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess, locus* where)
+{
+ return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
+}
+
+
+/* Find a type-bound intrinsic operator looking recursively through the
+ super-type hierarchy. */
+
+gfc_typebound_proc*
+gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
+ gfc_intrinsic_op op, bool noaccess,
+ locus* where)
+{
+ gfc_typebound_proc* res;
+
+ /* Set default to failure. */
+ if (t)
+ *t = FAILURE;
+
+ /* Try to find it in the current type's namespace. */
+ if (derived->f2k_derived)
+ res = derived->f2k_derived->tb_op[op];
+ else
+ res = NULL;
+
+ /* Check access. */
+ if (res && !res->error)
+ {
+ /* We found one. */
+ if (t)
+ *t = SUCCESS;
+
+ if (!noaccess && derived->attr.use_assoc
+ && res->access == ACCESS_PRIVATE)
+ {
+ if (where)
+ gfc_error ("'%s' of '%s' is PRIVATE at %L",
+ gfc_op2string (op), derived->name, where);
+ if (t)
+ *t = FAILURE;
+ }
+
+ return res;
+ }
+
+ /* Otherwise, recurse on parent type if derived is an extension. */
+ if (derived->attr.extension)
+ {
+ gfc_symbol* super_type;
+ super_type = gfc_get_derived_super_type (derived);
+ gcc_assert (super_type);
+
+ return gfc_find_typebound_intrinsic_op (super_type, t, op,
+ noaccess, where);
+ }
+
+ /* Nothing found. */
+ return NULL;
+}
+
+
+/* Get a typebound-procedure symtree or create and insert it if not yet
+ present. This is like a very simplified version of gfc_get_sym_tree for
+ tbp-symtrees rather than regular ones. */
+
+gfc_symtree*
+gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
+{
+ gfc_symtree *result;
+
+ result = gfc_find_symtree (*root, name);
+ if (!result)
+ {
+ result = gfc_new_symtree (root, name);
+ gcc_assert (result);
+ result->n.tb = NULL;
+ }
+
+ return result;
+}
OSDN Git Service
