+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,
/* 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;
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;
e->ts.derived = sym;
e->where = where;
- e->value.constructor = head;
+ e->value.constructor = ctor_head;
*result = e;
return MATCH_YES;
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;
}
+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.
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" } }
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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 } }
--- /dev/null
+! { 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
projects / gcc.git / commitdiff