This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[PATCH, Fortran] Extend F2003 structure constructor support
- From: Daniel Kraft <d at domob dot eu>
- To: FX <fxcoudert at gmail dot com>
- Cc: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches at gcc dot gnu dot org
- Date: Sun, 11 May 2008 12:50:51 +0000
- Subject: [PATCH, Fortran] Extend F2003 structure constructor support
Hi,
I've attached a patch and its ChangeLog that makes
gfc_match_structure_constructor interpret named arguments for structure
constructors and use default initializers for components not
explicitelly given a value; I also somewhat rewrote the error handling
for PRIVATE components both to support named arguments and to give (what
I believe) more useful error messages including the particular
component's name that is PRIVATE.
The algorithm(s) used is probably not the most efficient, but I believe
it is by far fast enough for this usage and tried to make the code as
clear as possible without unneccessary complication.
I'm not sure about where to insert gfc_notify_std calls; maybe F2003
notify-std when an argument with name is parsed and possibly also when a
default value is inserted? Or is that allowed for -std=f95, too? I
will then of course also add tests for these messages as appropriate.
This patch succeeds the test-suite with GNU/Linux-x86-32.
Cheers,
Daniel
--
Done: Bar-Sam-Val-Wiz, Dwa-Elf-Hum-Orc, Cha-Law, Fem-Mal
Underway: Ran-Gno-Neu-Fem
To go: Arc-Cav-Hea-Kni-Mon-Pri-Rog-Tou
2008-05-11 Daniel Kraft <d@domob.eu>
* primary.c: New private structure "gfc_structure_ctor_component".
(gfc_free_structure_ctor_component): New helper function.
(gfc_match_structure_constructor): Extended largely to support named
arguments and default initialization for structure constructors.
2008-05-11 Daniel Kraft <d@domob.eu>
* gfortran.dg/private_type_6.f90: Adapted expected error messages.
* gfortran.dg/structure_constructor_1.f03: New test
* gfortran.dg/structure_constructor_2.f03: New test
* gfortran.dg/structure_constructor_3.f03: New test
* gfortran.dg/structure_constructor_4.f03: New test
* gfortran.dg/structure_constructor_5.f03: New test
* gfortran.dg/structure_constructor_6.f03: New test
* gfortran.dg/structure_constructor_7.f03: New test
* gfortran.dg/structure_constructor_8.f03: New test
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (revision 134946)
+++ gcc/fortran/primary.c (working copy)
@@ -1936,17 +1936,39 @@ gfc_expr_attr (gfc_expr *e)
/* Match a structure constructor. The initial symbol has already been
seen. */
+typedef struct gfc_structure_ctor_component
+{
+ char* name;
+ gfc_expr* val;
+ locus where;
+ struct gfc_structure_ctor_component* next;
+}
+gfc_structure_ctor_component;
+
+#define gfc_get_structure_ctor_component() \
+ gfc_getmem(sizeof(gfc_structure_ctor_component))
+
+static void
+gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
+{
+ gfc_free (comp->name);
+ gfc_free_expr (comp->val);
+}
+
match
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
{
- gfc_constructor *head, *tail;
- gfc_component *comp;
+ gfc_structure_ctor_component *comp_head, *comp_tail;
+ gfc_structure_ctor_component *comp_iter;
+ gfc_constructor *ctor_head, *ctor_tail;
+ gfc_component *comp; /* Is set NULL when named component is first seen */
gfc_expr *e;
locus where;
match m;
- bool private_comp = false;
+ const char* last_name = NULL;
- head = tail = NULL;
+ comp_head = comp_tail = NULL;
+ ctor_head = ctor_tail = NULL;
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
@@ -1955,58 +1977,183 @@ gfc_match_structure_constructor (gfc_sym
gfc_find_component (sym, NULL);
- for (comp = sym->components; comp; comp = comp->next)
+ if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE)
{
- if (comp->access == ACCESS_PRIVATE)
- {
- private_comp = true;
- break;
- }
- if (head == NULL)
- tail = head = gfc_get_constructor ();
- else
+ gfc_error ("Structure constructor for '%s' at %C has PRIVATE access",
+ sym->name);
+ goto cleanup;
+ }
+
+ /* Match the component list and store it in a list together with the
+ corresponding component names. Check for empty argument list first. */
+ if (gfc_match_char (')') != MATCH_YES)
+ {
+ comp = sym->components;
+ do
{
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
+ gfc_component *this_comp = NULL;
- m = gfc_match_expr (&tail->expr);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
+ if (!comp_head)
+ comp_tail = comp_head = gfc_get_structure_ctor_component ();
+ else
+ {
+ comp_tail->next = gfc_get_structure_ctor_component ();
+ comp_tail = comp_tail->next;
+ }
+ comp_tail->name = gfc_getmem(GFC_MAX_SYMBOL_LEN + 1);
+ comp_tail->val = NULL;
+ comp_tail->where = gfc_current_locus;
+
+ /* Try matching a component name. */
+ if (gfc_match_name (comp_tail->name) == MATCH_YES
+ && gfc_match_char ('=') == MATCH_YES)
+ {
+ /* XXX: Insert appropriate notify standard? */
+ last_name = comp_tail->name;
+ comp = NULL;
+ }
+ else
+ {
+ /* Components without name are not allowed after the first named
+ component initializer! */
+ if (!comp)
+ {
+ if (last_name)
+ gfc_error ("Component initializer without name after"
+ " component named %s at %C!", last_name);
+ else
+ gfc_error ("Too many components in structure constructor at"
+ " %C!");
+ goto cleanup;
+ }
- if (gfc_match_char (',') == MATCH_YES)
- {
- if (comp->next == NULL)
+ gfc_current_locus = comp_tail->where;
+ 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. */
+ if (comp)
+ this_comp = comp;
+ else
+ {
+ for (comp = sym->components; comp; comp = comp->next)
+ if (!strcmp (comp->name, comp_tail->name))
+ {
+ this_comp = comp;
+ break;
+ }
+ 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 ("Too many components in structure constructor at %C");
+ gfc_error ("Component '%s' is PRIVATE in structure constructor"
+ " at %C!", comp_tail->name);
goto cleanup;
}
- continue;
+ /* Check if this component is already given a value. */
+ for (comp_iter = comp_head; comp_iter != comp_tail;
+ comp_iter = comp_iter->next)
+ {
+ gcc_assert (comp_iter);
+ if (!strcmp (comp_iter->name, comp_tail->name))
+ {
+ gfc_error ("Component '%s' is initialized twice in the"
+ " structure constructor at %C!", comp_tail->name);
+ goto cleanup;
+ }
+ }
+
+ /* Match the current initializer expression. */
+ m = gfc_match_expr (&comp_tail->val);
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ if (comp)
+ comp = comp->next;
}
+ while (gfc_match_char (',') == MATCH_YES);
- break;
+ if (gfc_match_char (')') != MATCH_YES)
+ goto syntax;
}
- if (sym->attr.use_assoc
- && (sym->component_access == ACCESS_PRIVATE || private_comp))
+ /* 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_error ("Structure constructor for '%s' at %C has PRIVATE "
- "components", sym->name);
- goto cleanup;
- }
+ gfc_structure_ctor_component **next_ptr;
+ gfc_expr *value = NULL;
- if (gfc_match_char (')') != MATCH_YES)
- goto syntax;
+ /* 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 (comp && comp->next != NULL)
- {
- gfc_error ("Too few components in structure constructor at %C");
- goto cleanup;
+ /* If it was not found, try the default initializer if there's any;
+ otherwise, it's an error. */
+ if (!comp_iter)
+ {
+ if (comp->initializer)
+ 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;
+
+ /* 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);
+ }
}
+ /* 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);
+
e = gfc_get_expr ();
e->expr_type = EXPR_STRUCTURE;
@@ -2015,7 +2162,7 @@ gfc_match_structure_constructor (gfc_sym
e->ts.derived = sym;
e->where = where;
- e->value.constructor = head;
+ e->value.constructor = ctor_head;
*result = e;
return MATCH_YES;
@@ -2024,7 +2171,13 @@ syntax:
gfc_error ("Syntax error in structure constructor at %C");
cleanup:
- gfc_free_constructor (head);
+ for (comp_iter = comp_head; comp_iter; )
+ {
+ gfc_structure_ctor_component *next = comp_iter->next;
+ gfc_free_structure_ctor_component (comp_iter);
+ comp_iter = next;
+ }
+ gfc_free_constructor (ctor_head);
return MATCH_ERROR;
}
Index: gcc/testsuite/gfortran.dg/private_type_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/private_type_6.f90 (revision 134946)
+++ gcc/testsuite/gfortran.dg/private_type_6.f90 (working copy)
@@ -18,8 +18,8 @@ program foo_test
implicit none
TYPE(footype) :: foo
TYPE(bartype) :: foo2
- foo = footype(1) ! { dg-error "has PRIVATE components" }
- foo2 = bartype(1,2) ! { dg-error "has PRIVATE components" }
+ foo = footype(1) ! { dg-error "has PRIVATE access" }
+ foo2 = bartype(1,2) ! { dg-error "'dummy2' is PRIVATE" }
foo2%dummy2 = 5 ! { dg-error "is a PRIVATE component" }
end program foo_test
! { dg-final { cleanup-modules "foomod" } }
Index: gcc/testsuite/gfortran.dg/structure_constructor_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/structure_constructor_1.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/structure_constructor_1.f03 (revision 0)
@@ -0,0 +1,74 @@
+! { dg-do run }
+! Simple structure constructors, without naming arguments, default values
+! or inheritance and the like.
+
+PROGRAM test
+ IMPLICIT NONE
+
+ ! Empty structuer
+ TYPE :: empty_t
+ END TYPE empty_t
+
+ ! Structure of basic data types
+ TYPE :: basics_t
+ INTEGER :: i
+ REAL :: r
+ COMPLEX :: c
+ LOGICAL :: l
+ END TYPE basics_t
+
+ ! Structure with strings
+ TYPE :: strings_t
+ CHARACTER(len=5) :: str1, str2
+ CHARACTER(len=10) :: long
+ END TYPE strings_t
+
+ ! Structure with arrays
+ TYPE :: array_t
+ INTEGER :: ints(2:5)
+ REAL :: matrix(2, 2)
+ END TYPE array_t
+
+ ! Structure containing structures
+ TYPE :: nestedStruct_t
+ TYPE(basics_t) :: basics
+ TYPE(array_t) :: arrays
+ END TYPE nestedStruct_t
+
+ TYPE(empty_t) :: empty
+ TYPE(basics_t) :: basics
+ TYPE(strings_t) :: strings
+ TYPE(array_t) :: arrays
+ TYPE(nestedStruct_t) :: nestedStruct
+
+ empty = empty_t ()
+
+ basics = basics_t (42, -1.5, (.5, .5), .FALSE.)
+ IF (basics%i /= 42 .OR. basics%r /= -1.5 &
+ .OR. basics%c /= (.5, .5) .OR. basics%l) THEN
+ CALL abort()
+ END IF
+
+ strings = strings_t ("hello", "abc", "this one is long")
+ IF (strings%str1 /= "hello" .OR. strings%str2 /= "abc" &
+ .OR. strings%long /= "this one i") THEN
+ CALL abort()
+ END IF
+
+ arrays = array_t ( (/ 1, 2, 3, 4 /), RESHAPE((/ 5, 6, 7, 8 /), (/ 2, 2 /)) )
+ IF (arrays%ints(2) /= 1 .OR. arrays%ints(3) /= 2 &
+ .OR. arrays%ints(4) /= 3 .OR. arrays%ints(5) /= 4 &
+ .OR. arrays%matrix(1, 1) /= 5. .OR. arrays%matrix(2, 1) /= 6. &
+ .OR. arrays%matrix(1, 2) /= 7. .OR. arrays%matrix(2, 2) /= 8.) THEN
+ CALL abort()
+ END IF
+
+ nestedStruct = nestedStruct_t (basics_t (42, -1.5, (.5, .5), .FALSE.), arrays)
+ IF (nestedStruct%basics%i /= 42 .OR. nestedStruct%basics%r /= -1.5 &
+ .OR. nestedStruct%basics%c /= (.5, .5) .OR. nestedStruct%basics%l &
+ .OR. ANY(nestedStruct%arrays%ints /= arrays%ints) &
+ .OR. ANY(nestedStruct%arrays%matrix /= arrays%matrix)) THEN
+ CALL abort()
+ END IF
+
+END PROGRAM test
Index: gcc/testsuite/gfortran.dg/structure_constructor_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/structure_constructor_2.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/structure_constructor_2.f03 (revision 0)
@@ -0,0 +1,29 @@
+! { dg-do run }
+! Structure constructor with component naming.
+
+PROGRAM test
+ IMPLICIT NONE
+
+ ! Structure of basic data types
+ TYPE :: basics_t
+ INTEGER :: i
+ REAL :: r
+ COMPLEX :: c
+ LOGICAL :: l
+ END TYPE basics_t
+
+ TYPE(basics_t) :: basics
+
+ basics = basics_t (42, -1.5, c=(.5, .5), l=.FALSE.)
+ IF (basics%i /= 42 .OR. basics%r /= -1.5 &
+ .OR. basics%c /= (.5, .5) .OR. basics%l) THEN
+ CALL abort()
+ END IF
+
+ basics = basics_t (r=-1.5, i=42, l=.FALSE., c=(.5, .5))
+ IF (basics%i /= 42 .OR. basics%r /= -1.5 &
+ .OR. basics%c /= (.5, .5) .OR. basics%l) THEN
+ CALL abort()
+ END IF
+
+END PROGRAM test
Index: gcc/testsuite/gfortran.dg/structure_constructor_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/structure_constructor_3.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/structure_constructor_3.f03 (revision 0)
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! Structure constructor with component naming, test that an error is emitted
+! if there are arguments without name after ones with name.
+
+PROGRAM test
+ IMPLICIT NONE
+
+ ! Structure of basic data types
+ TYPE :: basics_t
+ INTEGER :: i
+ REAL :: r
+ END TYPE basics_t
+
+ TYPE(basics_t) :: basics
+
+ basics = basics_t (i=42, 1.5) ! { dg-error "without name after" }
+
+END PROGRAM test
Index: gcc/testsuite/gfortran.dg/structure_constructor_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/structure_constructor_4.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/structure_constructor_4.f03 (revision 0)
@@ -0,0 +1,19 @@
+! { dg-do compile }
+! Structure constructor with component naming, test that an error is emitted if
+! a component is given two initializers.
+
+PROGRAM test
+ IMPLICIT NONE
+
+ ! Structure of basic data types
+ TYPE :: basics_t
+ INTEGER :: i
+ REAL :: r
+ END TYPE basics_t
+
+ TYPE(basics_t) :: basics
+
+ basics = basics_t (42, r=1.5, i=15) ! { dg-error "'i' is initialized twice" }
+ basics = basics_t (42, r=1., r=-2.) ! { dg-error "'r' is initialized twice" }
+
+END PROGRAM test
Index: gcc/testsuite/gfortran.dg/structure_constructor_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/structure_constructor_5.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/structure_constructor_5.f03 (revision 0)
@@ -0,0 +1,38 @@
+! { dg-do run }
+! Structure constructor with default initialization.
+
+PROGRAM test
+ IMPLICIT NONE
+
+ ! Type with all default values
+ TYPE :: quasiempty_t
+ CHARACTER(len=5) :: greeting = "hello"
+ END TYPE quasiempty_t
+
+ ! Structure of basic data types
+ TYPE :: basics_t
+ INTEGER :: i = 42
+ REAL :: r
+ COMPLEX :: c = (0., 1.)
+ END TYPE basics_t
+
+ TYPE(quasiempty_t) :: empty
+ TYPE(basics_t) :: basics
+
+ empty = quasiempty_t ()
+ IF (empty%greeting /= "hello") THEN
+ CALL abort()
+ END IF
+
+ basics = basics_t (r = 1.5)
+ IF (basics%i /= 42 .OR. basics%r /= 1.5 .OR. basics%c /= (0., 1.)) THEN
+ CALL abort()
+ END IF
+
+ basics%c = (0., 0.) ! So we see it's surely gotten re-initialized
+ basics = basics_t (1, 5.1)
+ IF (basics%i /= 1 .OR. basics%r /= 5.1 .OR. basics%c /= (0., 1.)) THEN
+ CALL abort()
+ END IF
+
+END PROGRAM test
Index: gcc/testsuite/gfortran.dg/structure_constructor_6.f03
===================================================================
--- gcc/testsuite/gfortran.dg/structure_constructor_6.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/structure_constructor_6.f03 (revision 0)
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! Structure constructor with default initialization, test that an error is
+! emitted for components without default initializer missing value.
+
+PROGRAM test
+ IMPLICIT NONE
+
+ ! Structure of basic data types
+ TYPE :: basics_t
+ INTEGER :: i = 42
+ REAL :: r
+ COMPLEX :: c = (0., 1.)
+ END TYPE basics_t
+
+ TYPE(basics_t) :: basics
+
+ basics = basics_t (i = 42) ! { dg-error "No initializer for component 'r'" }
+ basics = basics_t (42) ! { dg-error "No initializer for component 'r'" }
+
+END PROGRAM test
Index: gcc/testsuite/gfortran.dg/structure_constructor_7.f03
===================================================================
--- gcc/testsuite/gfortran.dg/structure_constructor_7.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/structure_constructor_7.f03 (revision 0)
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! Test for errors when excess components are given for a structure-constructor.
+
+PROGRAM test
+ IMPLICIT NONE
+
+ ! Structure of basic data types
+ TYPE :: basics_t
+ INTEGER :: i
+ REAL :: r = 1.5
+ END TYPE basics_t
+
+ 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'" }
+
+END PROGRAM test
Index: gcc/testsuite/gfortran.dg/structure_constructor_8.f03
===================================================================
--- gcc/testsuite/gfortran.dg/structure_constructor_8.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/structure_constructor_8.f03 (revision 0)
@@ -0,0 +1,50 @@
+! { dg-do compile }
+! Test for errors when setting private components inside a structure constructor
+! or when constructing a private structure.
+
+MODULE privmod
+ IMPLICIT NONE
+
+ TYPE :: haspriv_t
+ INTEGER :: a
+ INTEGER, PRIVATE :: b = 42
+ END TYPE haspriv_t
+
+ TYPE :: ispriv_t
+ PRIVATE
+ INTEGER :: a
+ END TYPE ispriv_t
+
+CONTAINS
+
+ SUBROUTINE testfunc ()
+ IMPLICIT NONE
+ TYPE(haspriv_t) :: struct1
+ TYPE(ispriv_t) :: struct2
+
+ ! This should succeed from within the module, no error.
+ struct1 = haspriv_t (1, 2)
+ struct2 = ispriv_t (42)
+ END SUBROUTINE testfunc
+
+END MODULE privmod
+
+PROGRAM test
+ USE privmod
+ IMPLICIT NONE
+
+ TYPE(haspriv_t) :: struct1
+ TYPE(ispriv_t) :: struct2
+
+ ! This should succeed, not giving value to private component
+ struct1 = haspriv_t (5)
+
+ ! 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" }
+
+ ! This should fail as the type itself is private
+ struct2 = ispriv_t (5) ! { dg-error "has PRIVATE access" }
+
+END PROGRAM test
+! { dg-final { cleanup-modules privmod } }