From: Daniel Kraft Date: Fri, 16 May 2008 06:52:14 +0000 (+0200) Subject: primary.c: New private structure "gfc_structure_ctor_component". X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=fa9290d3b9b4b1d981a25c06d8450b88d022f6ed;p=platform%2Fupstream%2Fgcc.git primary.c: New private structure "gfc_structure_ctor_component". 2008-05-16 Daniel Kraft * 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 * 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 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index cea13ba..2bc0d2c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2008-05-16 Daniel Kraft + + * 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 * simplify.c (gfc_simplify_dble, gfc_simplify_float, diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index fbc26af..be5fca0 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -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,58 +2007,195 @@ 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) - { - private_comp = true; - break; - } - if (head == NULL) - tail = head = gfc_get_constructor (); - else + 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; - if (gfc_match_char (',') == MATCH_YES) - { - if (comp->next == NULL) + /* 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 { - gfc_error ("Too many components in structure constructor at %C"); + /* 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); - break; + 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; + } } - 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) + { + 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); + } } + /* 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; @@ -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; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 45ea522..e256308 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,16 @@ +2008-05-16 Daniel Kraft + + * 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 * gcc.target/i386/m128-check.h: New. diff --git a/gcc/testsuite/gfortran.dg/private_type_6.f90 b/gcc/testsuite/gfortran.dg/private_type_6.f90 index c44661f..d3cc809 100644 --- a/gcc/testsuite/gfortran.dg/private_type_6.f90 +++ b/gcc/testsuite/gfortran.dg/private_type_6.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_1.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_1.f03 new file mode 100644 index 0000000..8f8f58e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/structure_constructor_1.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_2.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_2.f03 new file mode 100644 index 0000000..c551ebf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/structure_constructor_2.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_3.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_3.f03 new file mode 100644 index 0000000..aa59349 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/structure_constructor_3.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_4.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_4.f03 new file mode 100644 index 0000000..647be5f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/structure_constructor_4.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_5.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_5.f03 new file mode 100644 index 0000000..064db66 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/structure_constructor_5.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_6.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_6.f03 new file mode 100644 index 0000000..9952e2e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/structure_constructor_6.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_7.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_7.f03 new file mode 100644 index 0000000..3ba79ea --- /dev/null +++ b/gcc/testsuite/gfortran.dg/structure_constructor_7.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 b/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 new file mode 100644 index 0000000..995fd80 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/structure_constructor_8.f03 @@ -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 } } diff --git a/gcc/testsuite/gfortran.dg/structure_constructor_9.f90 b/gcc/testsuite/gfortran.dg/structure_constructor_9.f90 new file mode 100644 index 0000000..7512085 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/structure_constructor_9.f90 @@ -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