OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

primary.c: New private structure "gfc_structure_ctor_component".

Browse Source 
2008-05-16  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-16  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.
        * gfortran.dg/structure_constructor_9.f90:  New test.

From-SVN: r135410
This commit is contained in:
Daniel Kraft 2008-05-16 08:52:14 +02:00 committed by Tobias Burnus
parent d0208f9b64
commit fa9290d3b9
13 changed files with 537 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View File

@ -1,3 +1,10 @@
2008-05-16 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-15 Steven G. Kargl <kargls@comcast.net>
* simplify.c (gfc_simplify_dble, gfc_simplify_float,

257
gcc/fortran/primary.c
View File

@ -1966,17 +1966,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;
@ -1985,57 +2007,194 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
gfc_find_component (sym, NULL);
for (comp = sym->components; comp; comp = comp->next)
/* 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)
{
if (comp->access == ACCESS_PRIVATE)
comp = sym->components;
do
{
private_comp = true;
break;
}
if (head == NULL)
tail = head = gfc_get_constructor ();
else
{
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 (gfc_match_char (',') == MATCH_YES)
{
if (comp->next == NULL)
if (!comp_head)
comp_tail = comp_head = gfc_get_structure_ctor_component ();
else
{
gfc_error ("Too many components in structure constructor at %C");
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)
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
" constructor with named arguments at %C")
== FAILURE)
goto cleanup;
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;
}
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 ("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);
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;
}
}
/* 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;
/* 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;
}
break;
/* 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;
/* 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 (sym->attr.use_assoc
&& (sym->component_access == ACCESS_PRIVATE || private_comp))
{
gfc_error ("Structure constructor for '%s' at %C has PRIVATE "
"components", sym->name);
goto cleanup;
}
if (gfc_match_char (')') != MATCH_YES)
goto syntax;
if (comp && comp->next != NULL)
{
gfc_error ("Too few components in structure constructor at %C");
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);
e = gfc_get_expr ();
@ -2045,7 +2204,7 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
e->ts.derived = sym;
e->where = where;
e->value.constructor = head;
e->value.constructor = ctor_head;
*result = e;
return MATCH_YES;
@ -2054,7 +2213,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;
}

13
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,16 @@
2008-05-16 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.
* gfortran.dg/structure_constructor_9.f90: New test.
2008-05-15 H.J. Lu <hongjiu.lu@intel.com>
* gcc.target/i386/m128-check.h: New.

4
gcc/testsuite/gfortran.dg/private_type_6.f90
View File

@ -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 "All components of 'footype' are PRIVATE" }
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" } }

74
gcc/testsuite/gfortran.dg/structure_constructor_1.f03 Normal file
View File

@ -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

29
gcc/testsuite/gfortran.dg/structure_constructor_2.f03 Normal file
View File

@ -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

18
gcc/testsuite/gfortran.dg/structure_constructor_3.f03 Normal file
View File

@ -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

19
gcc/testsuite/gfortran.dg/structure_constructor_4.f03 Normal file
View File

@ -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

38
gcc/testsuite/gfortran.dg/structure_constructor_5.f03 Normal file
View File

@ -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

20
gcc/testsuite/gfortran.dg/structure_constructor_6.f03 Normal file
View File

@ -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

18
gcc/testsuite/gfortran.dg/structure_constructor_7.f03 Normal file
View File

@ -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

61
gcc/testsuite/gfortran.dg/structure_constructor_8.f03 Normal file
View File

@ -0,0 +1,61 @@
! { 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 :: allpriv_t
PRIVATE
INTEGER :: a = 25
END TYPE allpriv_t
TYPE, PRIVATE :: ispriv_t
INTEGER :: x
END TYPE ispriv_t
CONTAINS
SUBROUTINE testfunc ()
IMPLICIT NONE
TYPE(haspriv_t) :: struct1
TYPE(allpriv_t) :: struct2
TYPE(ispriv_t) :: struct3
! This should succeed from within the module, no error.
struct1 = haspriv_t (1, 2)
struct2 = allpriv_t (42)
struct3 = ispriv_t (42)
END SUBROUTINE testfunc
END MODULE privmod
PROGRAM test
USE privmod
IMPLICIT NONE
TYPE(haspriv_t) :: struct1
TYPE(allpriv_t) :: struct2
! This should succeed, not giving value to private component
struct1 = haspriv_t (5)
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" }
! This should fail as all components are private
struct2 = allpriv_t (5) ! { dg-error "of 'allpriv_t' are PRIVATE" }
! This should fail as the type itself is private, and the expression should
! be deduced as call to an undefined function.
WRITE (*,*) ispriv_t (5) ! { dg-error "has no IMPLICIT type" }
END PROGRAM test
! { dg-final { cleanup-modules privmod } }

27
gcc/testsuite/gfortran.dg/structure_constructor_9.f90 Normal file
View File

@ -0,0 +1,27 @@
! { dg-do compile }
! { dg-options "-std=f95" }
! Check for notify-std-messages when F2003 structure constructors are compiled
! with -std=f95.
PROGRAM test
IMPLICIT NONE
! Basic type with default initializers
TYPE :: basics_t
INTEGER :: i = 42
REAL :: r = 1.5
END TYPE basics_t
TYPE(basics_t) :: basics
! This is ok in F95
basics = basics_t (1, 2.)
! No argument naming in F95
basics = basics_t (1, r = 4.2) ! { dg-error "Fortran 2003" }
! No optional arguments in F95
basics = basics_t () ! { dg-error "Fortran 2003" }
basics = basics_t (5) ! { dg-error "Fortran 2003" }
END PROGRAM test