+2008-07-29 Paul Thomas <pault@gcc.gnu.org>
+
+ * trans-expr.c (conv_parent_component_references): New function
+ to build missing parent references.
+ (gfc_conv_variable): Call it
+ * symbol.c (gfc_add_component): Check that component name in a
+ derived type extension does not appear in parent.
+ (gfc_find_component): For a derived type extension, check if
+ the component appears in the parent derived type by calling
+ self. Separate errors for private components and private types.
+ * decl.c (match_data_constant): Add extra arg to call to
+ gfc_match_structure_constructor.
+ (check_extended_derived_type): New function to check that a
+ parent derived type exists and that it is OK for exension.
+ (gfc_get_type_attr_spec): Add extra argument 'name' and return
+ it if extends is specified.
+ (gfc_match_derived_decl): Match derived type extension and
+ build a first component of the parent derived type if OK. Add
+ the f2k namespace if not present.
+ * gfortran.h : Add the extension attribute.
+ * module.c : Handle attribute 'extension'.
+ * match.h : Modify prototypes for gfc_get_type_attr_spec and
+ gfc_match_structure_constructor.
+ * primary.c (build_actual_constructor): New function extracted
+ from gfc_match_structure_constructor and modified to call self
+ iteratively to build derived type extensions, when f2k named
+ components are used.
+ (gfc_match_structure_constructor): Do not throw error for too
+ many components if a parent type is being handled. Use
+ gfc_find_component to generate errors for non-existent or
+ private components. Iteratively call self for derived type
+ extensions so that parent constructor is built. If extension
+ and components left over, throw error.
+ (gfc_match_rvalue): Add extra arg to call to
+ gfc_match_structure_constructor.
+
+ * trans-array.c (gfc_conv_resolve_dependencies): If lhs and rhs
+ are the same symbol, aliassing does not matter.
+
2008-07-29 Jan Hubicka <jh@suse.cz>
* options.c (gfc_post_options): Do not set flag_no_inline.
return MATCH_ERROR;
}
else if (sym->attr.flavor == FL_DERIVED)
- return gfc_match_structure_constructor (sym, result);
+ return gfc_match_structure_constructor (sym, result, false);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
}
+/* Check a derived type that is being extended. */
+static gfc_symbol*
+check_extended_derived_type (char *name)
+{
+ gfc_symbol *extended;
+
+ if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
+ {
+ gfc_error ("Ambiguous symbol in TYPE definition at %C");
+ return NULL;
+ }
+
+ if (!extended)
+ {
+ gfc_error ("No such symbol in TYPE definition at %C");
+ return NULL;
+ }
+
+ if (extended->attr.flavor != FL_DERIVED)
+ {
+ gfc_error ("'%s' in EXTENDS expression at %C is not a "
+ "derived type", name);
+ return NULL;
+ }
+
+ if (extended->attr.is_bind_c)
+ {
+ gfc_error ("'%s' cannot be extended at %C because it "
+ "is BIND(C)", extended->name);
+ return NULL;
+ }
+
+ if (extended->attr.sequence)
+ {
+ gfc_error ("'%s' cannot be extended at %C because it "
+ "is a SEQUENCE type", extended->name);
+ return NULL;
+ }
+
+ return extended;
+}
+
+
/* Match the optional attribute specifiers for a type declaration.
Return MATCH_ERROR if an error is encountered in one of the handled
attributes (public, private, bind(c)), MATCH_NO if what's found is
checking on attribute conflicts needs to be done. */
match
-gfc_get_type_attr_spec (symbol_attribute *attr)
+gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
{
/* See if the derived type is marked as private. */
if (gfc_match (" , private") == MATCH_YES)
/* TODO: attr conflicts need to be checked, probably in symbol.c. */
}
+ else if (name && gfc_match(" , extends ( %n )", name) == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: derived type "
+ "extended at %C") == FAILURE)
+ return MATCH_ERROR;
+ }
else
return MATCH_NO;
gfc_match_derived_decl (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
+ char parent[GFC_MAX_SYMBOL_LEN + 1];
symbol_attribute attr;
gfc_symbol *sym;
+ gfc_symbol *extended;
match m;
match is_type_attr_spec = MATCH_NO;
bool seen_attr = false;
if (gfc_current_state () == COMP_DERIVED)
return MATCH_NO;
+ name[0] = '\0';
+ parent[0] = '\0';
gfc_clear_attr (&attr);
+ extended = NULL;
do
{
- is_type_attr_spec = gfc_get_type_attr_spec (&attr);
+ is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
if (is_type_attr_spec == MATCH_ERROR)
return MATCH_ERROR;
if (is_type_attr_spec == MATCH_YES)
seen_attr = true;
} while (is_type_attr_spec == MATCH_YES);
+ /* Deal with derived type extensions. */
+ if (parent[0])
+ extended = check_extended_derived_type (parent);
+
+ if (parent[0] && !extended)
+ return MATCH_ERROR;
+
if (gfc_match (" ::") != MATCH_YES && seen_attr)
{
gfc_error ("Expected :: in TYPE definition at %C");
if (attr.is_bind_c != 0)
sym->attr.is_bind_c = attr.is_bind_c;
+
/* Construct the f2k_derived namespace if it is not yet there. */
if (!sym->f2k_derived)
sym->f2k_derived = gfc_get_namespace (NULL, 0);
+
+ if (extended && !sym->components)
+ {
+ gfc_component *p;
+ gfc_symtree *st;
+
+ /* Add the extended derived type as the first component. */
+ gfc_add_component (sym, parent, &p);
+ sym->attr.extension = 1;
+ extended->refs++;
+ gfc_set_sym_referenced (extended);
+
+ p->ts.type = BT_DERIVED;
+ p->ts.derived = extended;
+ p->initializer = gfc_default_initializer (&p->ts);
+
+ /* Provide the links between the extended type and its extension. */
+ if (!extended->f2k_derived)
+ extended->f2k_derived = gfc_get_namespace (NULL, 0);
+ st = gfc_new_symtree (&extended->f2k_derived->sym_root, sym->name);
+ st->n.sym = sym;
+ }
+
gfc_new_block = sym;
return MATCH_YES;
unsigned untyped:1; /* No implicit type could be found. */
unsigned is_bind_c:1; /* say if is bound to C */
+ unsigned extension:1; /* extends a derived type */
/* These flags are both in the typespec and attribute. The attribute
list is what gets read from/written to a module file. The typespec
gfc_formal_arglist *formal;
struct gfc_namespace *formal_ns;
-
- /* The namespace containing type-associated procedure symbols. */
- /* TODO: Make this union with formal? */
struct gfc_namespace *f2k_derived;
struct gfc_expr *value; /* Parameter/Initializer value */
match gfc_match_bind_c_stmt (void);
match gfc_match_suffix (gfc_symbol *, gfc_symbol **);
match gfc_match_bind_c (gfc_symbol *, bool);
-match gfc_get_type_attr_spec (symbol_attribute *);
+match gfc_get_type_attr_spec (symbol_attribute *, char*);
/* primary.c. */
-match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
+match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **, bool);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
match gfc_match_actual_arglist (int, gfc_actual_arglist **);
AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
- AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP
+ AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
+ AB_EXTENSION
}
ab_attribute;
minit ("ZERO_COMP", AB_ZERO_COMP),
minit ("PROTECTED", AB_PROTECTED),
minit ("ABSTRACT", AB_ABSTRACT),
+ minit ("EXTENSION", AB_EXTENSION),
minit (NULL, -1)
};
MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
if (attr->zero_comp)
MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
+ if (attr->extension)
+ MIO_NAME (ab_attribute) (AB_EXTENSION, attr_bits);
mio_rparen ();
case AB_ZERO_COMP:
attr->zero_comp = 1;
break;
+ case AB_EXTENSION:
+ attr->extension = 1;
+ break;
}
}
}
gfc_free_expr (comp->val);
}
-match
-gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
+
+/* Translate the component list into the actual constructor by sorting it in
+ the order required; this also checks along the way that each and every
+ component actually has an initializer and handles default initializers
+ for components without explicit value given. */
+static gfc_try
+build_actual_constructor (gfc_structure_ctor_component **comp_head,
+ gfc_constructor **ctor_head, gfc_symbol *sym)
{
- gfc_structure_ctor_component *comp_head, *comp_tail;
gfc_structure_ctor_component *comp_iter;
+ gfc_constructor *ctor_tail = NULL;
+ gfc_component *comp;
+
+ for (comp = sym->components; comp; comp = comp->next)
+ {
+ gfc_structure_ctor_component **next_ptr;
+ gfc_expr *value = NULL;
+
+ /* Try to find the initializer for the current component by name. */
+ next_ptr = comp_head;
+ for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
+ {
+ if (!strcmp (comp_iter->name, comp->name))
+ break;
+ next_ptr = &comp_iter->next;
+ }
+
+ /* If an extension, try building the parent derived type by building
+ a value expression for the parent derived type and calling self. */
+ if (!comp_iter && comp == sym->components && sym->attr.extension)
+ {
+ value = gfc_get_expr ();
+ value->expr_type = EXPR_STRUCTURE;
+ value->value.constructor = NULL;
+ value->ts = comp->ts;
+ value->where = gfc_current_locus;
+
+ if (build_actual_constructor (comp_head, &value->value.constructor,
+ comp->ts.derived) == FAILURE)
+ {
+ gfc_free_expr (value);
+ return FAILURE;
+ }
+ *ctor_head = ctor_tail = gfc_get_constructor ();
+ ctor_tail->expr = value;
+ continue;
+ }
+
+ /* If it was not found, try the default initializer if there's any;
+ otherwise, it's an error. */
+ if (!comp_iter)
+ {
+ if (comp->initializer)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
+ " constructor with missing optional arguments"
+ " at %C") == FAILURE)
+ return FAILURE;
+ value = gfc_copy_expr (comp->initializer);
+ }
+ else
+ {
+ gfc_error ("No initializer for component '%s' given in the"
+ " structure constructor at %C!", comp->name);
+ return FAILURE;
+ }
+ }
+ else
+ value = comp_iter->val;
+
+ /* Add the value to the constructor chain built. */
+ if (ctor_tail)
+ {
+ ctor_tail->next = gfc_get_constructor ();
+ ctor_tail = ctor_tail->next;
+ }
+ else
+ *ctor_head = ctor_tail = gfc_get_constructor ();
+ gcc_assert (value);
+ ctor_tail->expr = value;
+
+ /* Remove the entry from the component list. We don't want the expression
+ value to be free'd, so set it to NULL. */
+ if (comp_iter)
+ {
+ *next_ptr = comp_iter->next;
+ comp_iter->val = NULL;
+ gfc_free_structure_ctor_component (comp_iter);
+ }
+ }
+ return SUCCESS;
+}
+
+match
+gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, bool parent)
+{
+ gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
gfc_constructor *ctor_head, *ctor_tail;
gfc_component *comp; /* Is set NULL when named component is first seen */
gfc_expr *e;
match m;
const char* last_name = NULL;
- comp_head = comp_tail = NULL;
+ comp_tail = comp_head = NULL;
ctor_head = ctor_tail = NULL;
- if (gfc_match_char ('(') != MATCH_YES)
+ if (!parent && gfc_match_char ('(') != MATCH_YES)
goto syntax;
where = gfc_current_locus;
if (last_name)
gfc_error ("Component initializer without name after"
" component named %s at %C!", last_name);
- else
+ else if (!parent)
gfc_error ("Too many components in structure constructor at"
" %C!");
goto cleanup;
strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
}
- /* Find the current component in the structure definition; this is
- needed to get its access attribute in the private check below. */
+ /* Find the current component in the structure definition and check its
+ access is not private. */
if (comp)
- this_comp = comp;
+ this_comp = gfc_find_component (sym, comp->name);
else
{
- for (comp = sym->components; comp; comp = comp->next)
- if (!strcmp (comp->name, comp_tail->name))
- {
- this_comp = comp;
- break;
- }
+ this_comp = gfc_find_component (sym, (const char *)comp_tail->name);
comp = NULL; /* Reset needed! */
-
- /* Here we can check if a component name is given which does not
- correspond to any component of the defined structure. */
- if (!this_comp)
- {
- gfc_error ("Component '%s' in structure constructor at %C"
- " does not correspond to any component in the"
- " constructed structure!", comp_tail->name);
- goto cleanup;
- }
}
- gcc_assert (this_comp);
- /* Check the current component's access status. */
- if (sym->attr.use_assoc && this_comp->access == ACCESS_PRIVATE)
- {
- gfc_error ("Component '%s' is PRIVATE in structure constructor"
- " at %C!", comp_tail->name);
- goto cleanup;
- }
+ /* Here we can check if a component name is given which does not
+ correspond to any component of the defined structure. */
+ if (!this_comp)
+ goto cleanup;
/* Check if this component is already given a value. */
for (comp_iter = comp_head; comp_iter != comp_tail;
if (m == MATCH_ERROR)
goto cleanup;
- if (comp)
- comp = comp->next;
- }
- while (gfc_match_char (',') == MATCH_YES);
+ /* If not explicitly a parent constructor, gather up the components
+ and build one. */
+ if (comp && comp == sym->components
+ && sym->attr.extension
+ && (comp_tail->val->ts.type != BT_DERIVED
+ ||
+ comp_tail->val->ts.derived != this_comp->ts.derived))
+ {
+ gfc_current_locus = where;
+ gfc_free_expr (comp_tail->val);
- if (gfc_match_char (')') != MATCH_YES)
- goto syntax;
-
- /* If there were components given and all components are private, error
- out at this place. */
- if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
- {
- gfc_error ("All components of '%s' are PRIVATE in structure"
- " constructor at %C", sym->name);
- goto cleanup;
- }
- }
+ m = gfc_match_structure_constructor (comp->ts.derived,
+ &comp_tail->val, true);
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ }
- /* Translate the component list into the actual constructor by sorting it in
- the order required; this also checks along the way that each and every
- component actually has an initializer and handles default initializers
- for components without explicit value given. */
- for (comp = sym->components; comp; comp = comp->next)
- {
- gfc_structure_ctor_component **next_ptr;
- gfc_expr *value = NULL;
+ if (comp)
+ comp = comp->next;
- /* Try to find the initializer for the current component by name. */
- next_ptr = &comp_head;
- for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
- {
- if (!strcmp (comp_iter->name, comp->name))
+ if (parent && !comp)
break;
- next_ptr = &comp_iter->next;
- }
-
- /* If it was not found, try the default initializer if there's any;
- otherwise, it's an error. */
- if (!comp_iter)
- {
- if (comp->initializer)
- {
- if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
- " constructor with missing optional arguments"
- " at %C") == FAILURE)
- goto cleanup;
- value = gfc_copy_expr (comp->initializer);
- }
- else
- {
- gfc_error ("No initializer for component '%s' given in the"
- " structure constructor at %C!", comp->name);
- goto cleanup;
- }
}
- else
- value = comp_iter->val;
- /* Add the value to the constructor chain built. */
- if (ctor_tail)
- {
- ctor_tail->next = gfc_get_constructor ();
- ctor_tail = ctor_tail->next;
- }
- else
- ctor_head = ctor_tail = gfc_get_constructor ();
- gcc_assert (value);
- ctor_tail->expr = value;
+ while (gfc_match_char (',') == MATCH_YES);
- /* Remove the entry from the component list. We don't want the expression
- value to be free'd, so set it to NULL. */
- if (comp_iter)
- {
- *next_ptr = comp_iter->next;
- comp_iter->val = NULL;
- gfc_free_structure_ctor_component (comp_iter);
- }
+ if (!parent && gfc_match_char (')') != MATCH_YES)
+ goto syntax;
}
+ if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
+ goto cleanup;
+
/* No component should be left, as this should have caused an error in the
loop constructing the component-list (name that does not correspond to any
component in the structure definition). */
- gcc_assert (!comp_head);
+ if (comp_head && sym->attr.extension)
+ {
+ for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
+ {
+ gfc_error ("component '%s' at %L has already been set by a "
+ "parent derived type constructor", comp_iter->name,
+ &comp_iter->where);
+ }
+ goto cleanup;
+ }
+ else
+ gcc_assert (!comp_head);
e = gfc_get_expr ();
if (sym == NULL)
m = MATCH_ERROR;
else
- m = gfc_match_structure_constructor (sym, &e);
+ m = gfc_match_structure_constructor (sym, &e, false);
break;
/* If we're here, then the name is known to be the name of a
tail = p;
}
+ if (sym->attr.extension
+ && gfc_find_component (sym->components->ts.derived, name))
+ {
+ gfc_error ("Component '%s' at %C already in the parent type "
+ "at %L", name, &sym->components->ts.derived->declared_at);
+ return FAILURE;
+ }
+
/* Allocate a new component. */
p = gfc_get_component ();
if (strcmp (p->name, name) == 0)
break;
+ if (p == NULL
+ && sym->attr.extension
+ && sym->components->ts.type == BT_DERIVED)
+ {
+ p = gfc_find_component (sym->components->ts.derived, name);
+ /* Do not overwrite the error. */
+ if (p == NULL)
+ return p;
+ }
+
if (p == NULL)
gfc_error ("'%s' at %C is not a member of the '%s' structure",
name, sym->name);
- else
+
+ else if (sym->attr.use_assoc)
{
- if (sym->attr.use_assoc && (sym->component_access == ACCESS_PRIVATE
- || p->access == ACCESS_PRIVATE))
+ if (p->access == ACCESS_PRIVATE)
{
gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
name, sym->name);
- p = NULL;
+ return NULL;
+ }
+
+ /* If there were components given and all components are private, error
+ out at this place. */
+ if (p->access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE)
+ {
+ gfc_error ("All components of '%s' are PRIVATE in structure"
+ " constructor at %C", sym->name);
+ return NULL;
}
}
if (ss->type != GFC_SS_SECTION)
continue;
- if (gfc_could_be_alias (dest, ss)
- || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
+ if (dest->expr->symtree->n.sym != ss->expr->symtree->n.sym)
{
- nDepend = 1;
- break;
+ if (gfc_could_be_alias (dest, ss)
+ || gfc_are_equivalenced_arrays (dest->expr, ss->expr))
+ {
+ nDepend = 1;
+ break;
+ }
}
-
- if (dest->expr->symtree->n.sym == ss->expr->symtree->n.sym)
+ else
{
lref = dest->expr->ref;
rref = ss->expr->ref;
/* Expression translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
- Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
}
+/* This function deals with component references to components of the
+ parent type for derived type extensons. */
+static void
+conv_parent_component_references (gfc_se * se, gfc_ref * ref)
+{
+ gfc_component *c;
+ gfc_component *cmp;
+ gfc_symbol *dt;
+ gfc_ref parent;
+
+ dt = ref->u.c.sym;
+ c = ref->u.c.component;
+
+ /* Build a gfc_ref to recursively call gfc_conv_component_ref. */
+ parent.type = REF_COMPONENT;
+ parent.next = NULL;
+ parent.u.c.sym = dt;
+ parent.u.c.component = dt->components;
+
+ if (dt->attr.extension && dt->components)
+ {
+ /* Return if the component is not in the parent type. */
+ for (cmp = dt->components->next; cmp; cmp = cmp->next)
+ if (strcmp (c->name, cmp->name) == 0)
+ return;
+
+ /* Otherwise build the reference and call self. */
+ gfc_conv_component_ref (se, &parent);
+ parent.u.c.sym = dt->components->ts.derived;
+ parent.u.c.component = c;
+ conv_parent_component_references (se, &parent);
+ }
+}
+
/* Return the contents of a variable. Also handles reference/pointer
variables (all Fortran pointer references are implicit). */
break;
case REF_COMPONENT:
+ if (ref->u.c.sym->attr.extension)
+ conv_parent_component_references (se, ref);
+
gfc_conv_component_ref (se, ref);
break;
/* IO Code translation/library interface
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
- Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
+2008-07-29 Paul Thomas <pault@gcc.gnu.org>
+
+ * gfortran.dg/extends_1.f03: New test.
+ * gfortran.dg/extends_2.f03: New test.
+ * gfortran.dg/extends_3.f03: New test.
+ * gfortran.dg/extends_4.f03: New test.
+ * gfortran.dg/extends_5.f03: New test.
+ * gfortran.dg/extends_6.f03: New test.
+ * gfortran.dg/private_type_6.f90: Modify error message.
+ * gfortran.dg/structure_constructor_7.f03: Modify error message.
+ * gfortran.dg/structure_constructor_8.f03: Modify error message.
+
2008-07-29 Richard Guenther <rguenther@suse.de>
PR tree-optimization/36945
--- /dev/null
+! { dg-do run }
+! A basic functional test of derived type extension.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module persons
+ type :: person
+ character(24) :: name = ""
+ integer :: ss = 1
+ end type person
+end module persons
+
+module person_education
+ use persons
+ type, extends(person) :: education
+ integer :: attainment = 0
+ character(24) :: institution = ""
+ end type education
+end module person_education
+
+ use person_education
+ type, extends(education) :: service
+ integer :: personnel_number = 0
+ character(24) :: department = ""
+ end type service
+
+ type, extends(service) :: person_record
+ type (person_record), pointer :: supervisor => NULL ()
+ end type person_record
+
+ type(person_record), pointer :: recruit, supervisor
+
+! Check that references by ultimate component work
+
+ allocate (supervisor)
+ supervisor%name = "Joe Honcho"
+ supervisor%ss = 123455
+ supervisor%attainment = 100
+ supervisor%institution = "Celestial University"
+ supervisor%personnel_number = 1
+ supervisor%department = "Directorate"
+
+ recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", &
+ 99, "Records", supervisor)
+
+ if (trim (recruit%name) /= "John Smith") call abort
+ if (recruit%name /= recruit%service%name) call abort
+ if (recruit%supervisor%ss /= 123455) call abort
+ if (recruit%supervisor%ss /= supervisor%person%ss) call abort
+
+ deallocate (supervisor)
+ deallocate (recruit)
+contains
+ function entry (name, ss, attainment, institution, &
+ personnel_number, department, supervisor) result (new_person)
+ integer :: ss, attainment, personnel_number
+ character (*) :: name, institution, department
+ type (person_record), pointer :: supervisor, new_person
+
+ allocate (new_person)
+
+! Check mixtures of references
+ new_person%person%name = name
+ new_person%service%education%person%ss = ss
+ new_person%service%attainment = attainment
+ new_person%education%institution = institution
+ new_person%personnel_number = personnel_number
+ new_person%service%department = department
+ new_person%supervisor => supervisor
+ end function
+end
+
+! { dg-final { cleanup-modules "persons person_education" } }
--- /dev/null
+! { dg-do run }
+! A test of f95 style constructors with derived type extension.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module persons
+ type :: person
+ character(24) :: name = ""
+ integer :: ss = 1
+ end type person
+end module persons
+
+module person_education
+ use persons
+ type, extends(person) :: education
+ integer :: attainment = 0
+ character(24) :: institution = ""
+ end type education
+end module person_education
+
+ use person_education
+ type, extends(education) :: service
+ integer :: personnel_number = 0
+ character(24) :: department = ""
+ end type service
+
+ type, extends(service) :: person_record
+ type (person_record), pointer :: supervisor => NULL ()
+ end type person_record
+
+ type(person_record), pointer :: recruit, supervisor
+
+! Check that simple constructor works
+ allocate (supervisor)
+ supervisor%service = service ("Joe Honcho", 123455, 100, &
+ "Celestial University", 1, &
+ "Directorate")
+
+ recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", &
+ 99, "Records", supervisor)
+
+ if (trim (recruit%name) /= "John Smith") call abort
+ if (recruit%name /= recruit%service%name) call abort
+ if (recruit%supervisor%ss /= 123455) call abort
+ if (recruit%supervisor%ss /= supervisor%person%ss) call abort
+
+ deallocate (supervisor)
+ deallocate (recruit)
+contains
+ function entry (name, ss, attainment, institution, &
+ personnel_number, department, supervisor) result (new_person)
+ integer :: ss, attainment, personnel_number
+ character (*) :: name, institution, department
+ type (person_record), pointer :: supervisor, new_person
+
+ allocate (new_person)
+
+! Check nested constructors
+ new_person = person_record (education (person (name, ss), &
+ attainment, institution), &
+ personnel_number, department, &
+ supervisor)
+ end function
+end
+
+! { dg-final { cleanup-modules "persons person_education" } }
--- /dev/null
+! { dg-do run }
+! A test of f2k style constructors with derived type extension.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module persons
+ type :: person
+ character(24) :: name = ""
+ integer :: ss = 1
+ end type person
+end module persons
+
+module person_education
+ use persons
+ type, extends(person) :: education
+ integer :: attainment = 0
+ character(24) :: institution = ""
+ end type education
+end module person_education
+
+ use person_education
+ type, extends(education) :: service
+ integer :: personnel_number = 0
+ character(24) :: department = ""
+ end type service
+
+ type, extends(service) :: person_record
+ type (person_record), pointer :: supervisor => NULL ()
+ end type person_record
+
+ type(person_record), pointer :: recruit, supervisor
+
+! Check that F2K constructor with missing entries works
+ allocate (supervisor)
+ supervisor%service = service (NAME = "Joe Honcho", SS= 123455)
+
+ recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", &
+ 99, "Records", supervisor)
+
+ if (supervisor%ss /= 123455) call abort
+ if (trim (supervisor%name) /= "Joe Honcho") call abort
+ if (trim (supervisor%institution) /= "") call abort
+ if (supervisor%attainment /= 0) call abort
+
+ if (trim (recruit%name) /= "John Smith") call abort
+ if (recruit%name /= recruit%service%name) call abort
+ if (recruit%supervisor%ss /= 123455) call abort
+ if (recruit%supervisor%ss /= supervisor%person%ss) call abort
+
+ deallocate (supervisor)
+ deallocate (recruit)
+contains
+ function entry (name, ss, attainment, institution, &
+ personnel_number, department, supervisor) result (new_person)
+ integer :: ss, attainment, personnel_number
+ character (*) :: name, institution, department
+ type (person_record), pointer :: supervisor, new_person
+
+ allocate (new_person)
+
+! Check F2K constructor with order shuffled a bit
+ new_person = person_record (NAME = name, SS =ss, &
+ DEPARTMENT = department, &
+ INSTITUTION = institution, &
+ PERSONNEL_NUMBER = personnel_number, &
+ ATTAINMENT = attainment, &
+ SUPERVISOR = supervisor)
+ end function
+end
+
+! { dg-final { cleanup-modules "persons person_education" } }
--- /dev/null
+! { dg-do run }
+! Check that derived type extension is compatible with renaming
+! the parent type and that allocatable components are OK. At
+! the same time, private type and components are checked.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module mymod
+ type :: a
+ real, allocatable :: x(:)
+ integer, private :: ia = 0
+ end type a
+ type :: b
+ private
+ real, allocatable :: x(:)
+ integer :: i
+ end type b
+contains
+ function set_b () result (res)
+ type(b) :: res
+ allocate (res%x(2))
+ res%x = [10.0, 20.0]
+ res%i = 1
+ end function
+ subroutine check_b (arg)
+ type(b) :: arg
+ if (any (arg%x /= [10.0, 20.0])) call abort
+ if (arg%i /= 1) call abort
+ end subroutine
+end module mymod
+
+ use mymod, e => a
+ type, extends(e) :: f
+ integer :: if
+ end type f
+ type, extends(b) :: d
+ integer :: id
+ end type d
+
+ type(f) :: p
+ type(d) :: q
+
+ p = f (x = [1.0, 2.0], if = 3)
+ if (any (p%e%x /= [1.0, 2.0])) call abort
+
+ q%b = set_b ()
+ call check_b (q%b)
+ q = d (b = set_b (), id = 99)
+ call check_b (q%b)
+end
+
+! { dg-final { cleanup-modules "persons person_education" } }
--- /dev/null
+! { dg-do compile }
+! Some errors for derived type extension.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module m
+ use iso_c_binding
+ type :: date
+ sequence
+ integer :: yr, mon
+ integer,public :: day
+ end type
+ type, bind(c) :: dt
+ integer(c_int) :: yr, mon
+ integer(c_int) :: day
+ end type
+end module m
+
+ use m
+ type, extends(date) :: datetime ! { dg-error "because it is a SEQUENCE type" }
+ end type ! { dg-error "Expecting END PROGRAM" }
+
+ type, extends(dt) :: dt_type ! { dg-error "because it is BIND" }
+ end type ! { dg-error "Expecting END PROGRAM" }
+end
+
+! { dg-final { cleanup-modules "m" } }
--- /dev/null
+! { dg-do compile }
+! Some errors pointed out in the development of the patch.
+!
+! Contributed by Tobias Burnus <burnus@net-b.de>
+!
+module m
+ type :: date
+ private
+ integer :: yr, mon
+ integer,public :: day
+ end type
+ type :: dt
+ integer :: yr, mon
+ integer :: day
+ end type
+end module m
+
+ use m
+ type, extends(date) :: datetime
+ integer :: hr, min, sec
+ end type
+ type(datetime) :: o_dt
+
+ type :: one
+ integer :: i
+ end type one
+
+ type, extends(one) :: two
+ real :: r
+ end type two
+
+ o_dt%day = 5 ! VALID but failed in first version of EXTENDS patch
+ o_dt%yr = 5 ! { dg-error "All components of 'date' are PRIVATE" }
+
+ t = two(one = one(4), i = 5, r=4.4) ! { dg-error "has already been set" }
+
+ call foo
+contains
+ subroutine foo
+ use m, date_type => dt
+ type, extends(date_type) :: dt_type
+ end type
+ type (dt_type) :: foo_dt
+ foo_dt%date_type%day = 1
+ foo_dt%dt%day = 1 ! { dg-error "not a member" }
+ end subroutine
+end
+
+! { dg-final { cleanup-modules "m" } }
TYPE(footype) :: foo
TYPE(bartype) :: foo2
foo = footype(1) ! { dg-error "All components of 'footype' are PRIVATE" }
- foo2 = bartype(1,2) ! { dg-error "'dummy2' is PRIVATE" }
+ foo2 = bartype(1,2) ! { dg-error "is a PRIVATE component" }
foo2%dummy2 = 5 ! { dg-error "is a PRIVATE component" }
end program foo_test
! { dg-final { cleanup-modules "foomod" } }
TYPE(basics_t) :: basics
basics = basics_t (42, 1.5, 1000) ! { dg-error "Too many components" }
- basics = basics_t (42, xxx = 1000) ! { dg-error "Component 'xxx'" }
+ basics = basics_t (42, xxx = 1000) ! { dg-error "is not a member" }
END PROGRAM test
struct2 = allpriv_t ()
! These should fail
- struct1 = haspriv_t (1, 2) ! { dg-error "'b' is PRIVATE" }
- struct1 = haspriv_t (b = 2, a = 1) ! { dg-error "'b' is PRIVATE" }
+ struct1 = haspriv_t (1, 2) ! { dg-error "is a PRIVATE component" }
+ struct1 = haspriv_t (b = 2, a = 1) ! { dg-error "is a PRIVATE component" }
! This should fail as all components are private
struct2 = allpriv_t (5) ! { dg-error "of 'allpriv_t' are PRIVATE" }
projects / gcc.git / commitdiff