void gfc_conv_constant (gfc_se * se, gfc_expr * expr) { gfc_ss *ss; /* We may be receiving an expression for C_NULL_PTR or C_NULL_FUNPTR. If so, the expr_type will not yet be an EXPR_CONSTANT. We need to make it so here. */ if (expr->ts.type == BT_DERIVED && expr->ts.u.derived && expr->ts.u.derived->attr.is_iso_c) { if (expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_PTR || expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR) { /* Create a new EXPR_CONSTANT expression for our local uses. */ expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); } } if (expr->expr_type != EXPR_CONSTANT) { gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0); gfc_error ("non-constant initialization expression at %L", &expr->where); se->expr = gfc_conv_constant_to_tree (e); return; } ss = se->ss; if (ss != NULL) { gfc_ss_info *ss_info; ss_info = ss->info; gcc_assert (ss != gfc_ss_terminator); gcc_assert (ss_info->type == GFC_SS_SCALAR); gcc_assert (ss_info->expr == expr); se->expr = ss_info->data.scalar.value; se->string_length = ss_info->string_length; gfc_advance_se_ss_chain (se); return; } /* Translate the constant and put it in the simplifier structure. */ se->expr = gfc_conv_constant_to_tree (expr); /* If this is a CHARACTER string, set its length in the simplifier structure, too. */ if (expr->ts.type == BT_CHARACTER) se->string_length = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (se->expr))); }
gfc_symbol * gfc_find_derived_vtab (gfc_symbol *derived) { gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; /* Find the top-level namespace (MODULE or PROGRAM). */ for (ns = gfc_current_ns; ns; ns = ns->parent) if (!ns->parent) break; /* If the type is a class container, use the underlying derived type. */ if (derived->attr.is_class) derived = gfc_get_derived_super_type (derived); if (ns) { char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; get_unique_hashed_string (tname, derived); sprintf (name, "__vtab_%s", tname); /* Look for the vtab symbol in various namespaces. */ gfc_find_symbol (name, gfc_current_ns, 0, &vtab); if (vtab == NULL) gfc_find_symbol (name, ns, 0, &vtab); if (vtab == NULL) gfc_find_symbol (name, derived->ns, 0, &vtab); if (vtab == NULL) { gfc_get_symbol (name, ns, &vtab); vtab->ts.type = BT_DERIVED; if (gfc_add_flavor (&vtab->attr, FL_VARIABLE, NULL, &gfc_current_locus) == FAILURE) goto cleanup; vtab->attr.target = 1; vtab->attr.save = SAVE_IMPLICIT; vtab->attr.vtab = 1; vtab->attr.access = ACCESS_PUBLIC; gfc_set_sym_referenced (vtab); sprintf (name, "__vtype_%s", tname); 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) goto cleanup; vtype->attr.access = ACCESS_PUBLIC; vtype->attr.vtype = 1; gfc_set_sym_referenced (vtype); /* Add component '_hash'. */ if (gfc_add_component (vtype, "_hash", &c) == FAILURE) goto cleanup; c->ts.type = BT_INTEGER; c->ts.kind = 4; c->attr.access = ACCESS_PRIVATE; c->initializer = gfc_get_int_expr (gfc_default_integer_kind, NULL, derived->hash_value); /* Add component '_size'. */ if (gfc_add_component (vtype, "_size", &c) == FAILURE) goto cleanup; 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_get_int_expr (gfc_default_integer_kind, NULL, 0); /* Add component _extends. */ if (gfc_add_component (vtype, "_extends", &c) == FAILURE) goto cleanup; c->attr.pointer = 1; c->attr.access = ACCESS_PRIVATE; 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 = gfc_get_expr (); 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 = gfc_get_null_expr (NULL); } if (derived->components == NULL && !derived->attr.zero_comp) { /* At this point an error must have occurred. Prevent further errors on the vtype components. */ found_sym = vtab; goto have_vtype; } /* Add component _def_init. */ if (gfc_add_component (vtype, "_def_init", &c) == FAILURE) goto cleanup; c->attr.pointer = 1; c->attr.access = ACCESS_PRIVATE; c->ts.type = BT_DERIVED; c->ts.u.derived = derived; if (derived->attr.abstract) c->initializer = gfc_get_null_expr (NULL); else { /* Construct default initialization variable. */ sprintf (name, "__def_init_%s", tname); gfc_get_symbol (name, ns, &def_init); def_init->attr.target = 1; def_init->attr.save = SAVE_IMPLICIT; def_init->attr.access = ACCESS_PUBLIC; def_init->attr.flavor = FL_VARIABLE; gfc_set_sym_referenced (def_init); def_init->ts.type = BT_DERIVED; def_init->ts.u.derived = derived; def_init->value = gfc_default_initializer (&def_init->ts); c->initializer = gfc_lval_expr_from_sym (def_init); } /* Add component _copy. */ if (gfc_add_component (vtype, "_copy", &c) == FAILURE) goto cleanup; c->attr.proc_pointer = 1; c->attr.access = ACCESS_PRIVATE; c->tb = XCNEW (gfc_typebound_proc); c->tb->ppc = 1; if (derived->attr.abstract) c->initializer = gfc_get_null_expr (NULL); else { /* Set up namespace. */ gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); sub_ns->sibling = ns->contained; ns->contained = sub_ns; sub_ns->resolved = 1; /* Set up procedure symbol. */ sprintf (name, "__copy_%s", tname); gfc_get_symbol (name, sub_ns, ©); sub_ns->proc_name = copy; copy->attr.flavor = FL_PROCEDURE; copy->attr.if_source = IFSRC_DECL; if (ns->proc_name->attr.flavor == FL_MODULE) copy->module = ns->proc_name->name; gfc_set_sym_referenced (copy); /* Set up formal arguments. */ gfc_get_symbol ("src", sub_ns, &src); src->ts.type = BT_DERIVED; src->ts.u.derived = derived; src->attr.flavor = FL_VARIABLE; src->attr.dummy = 1; gfc_set_sym_referenced (src); copy->formal = gfc_get_formal_arglist (); copy->formal->sym = src; gfc_get_symbol ("dst", sub_ns, &dst); dst->ts.type = BT_DERIVED; dst->ts.u.derived = derived; dst->attr.flavor = FL_VARIABLE; dst->attr.dummy = 1; gfc_set_sym_referenced (dst); copy->formal->next = gfc_get_formal_arglist (); copy->formal->next->sym = dst; /* Set up code. */ sub_ns->code = gfc_get_code (); sub_ns->code->op = EXEC_INIT_ASSIGN; sub_ns->code->expr1 = gfc_lval_expr_from_sym (dst); sub_ns->code->expr2 = gfc_lval_expr_from_sym (src); /* Set initializer. */ c->initializer = gfc_lval_expr_from_sym (copy); c->ts.interface = copy; } /* Add procedure pointers for type-bound procedures. */ add_procs_to_declared_vtab (derived, vtype); } have_vtype: vtab->ts.u.derived = vtype; vtab->value = gfc_default_initializer (&vtab->ts); } } found_sym = vtab; cleanup: /* It is unexpected to have some symbols added at resolution or code generation time. We commit the changes in order to keep a clean state. */ if (found_sym) { gfc_commit_symbol (vtab); if (vtype) gfc_commit_symbol (vtype); if (def_init) gfc_commit_symbol (def_init); if (copy) gfc_commit_symbol (copy); if (src) gfc_commit_symbol (src); if (dst) gfc_commit_symbol (dst); } else gfc_undo_symbols (); return found_sym; }
gfc_symbol * gfc_find_derived_vtab (gfc_symbol *derived) { gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = 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->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) goto cleanup; vtype->refs++; gfc_set_sym_referenced (vtype); /* Add component '$hash'. */ if (gfc_add_component (vtype, "$hash", &c) == FAILURE) goto cleanup; c->ts.type = BT_INTEGER; c->ts.kind = 4; c->attr.access = ACCESS_PRIVATE; c->initializer = gfc_get_int_expr (gfc_default_integer_kind, NULL, derived->hash_value); /* Add component '$size'. */ if (gfc_add_component (vtype, "$size", &c) == FAILURE) goto cleanup; 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_get_int_expr (gfc_default_integer_kind, NULL, 0); /* Add component $extends. */ if (gfc_add_component (vtype, "$extends", &c) == FAILURE) goto cleanup; c->attr.pointer = 1; c->attr.access = ACCESS_PRIVATE; 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 = gfc_get_expr (); 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 = gfc_get_null_expr (NULL); } add_procs_to_declared_vtab (derived, vtype); vtype->attr.vtype = 1; } vtab->ts.u.derived = vtype; vtab->value = gfc_default_initializer (&vtab->ts); } } found_sym = vtab; cleanup: /* It is unexpected to have some symbols added at resolution or code generation time. We commit the changes in order to keep a clean state. */ if (found_sym) gfc_commit_symbols (); else gfc_undo_symbols (); return found_sym; }