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.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@135410 138bc75d-0d04-0410-961f-82ee72b054a4

10 files changed, 306 insertions, 2 deletions

diff --git a/gcc/testsuite/gfortran.dg/private_type_6.f90 b/gcc/testsuite/gfortran.dg/private_type_6.f90
index c44661f2362..d3cc809dfef 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 00000000000..8f8f58ef920
--- /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 00000000000..c551ebfde88
--- /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 00000000000..aa5934951c4
--- /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 00000000000..647be5fbb7d
--- /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 00000000000..064db66a2bf
--- /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 00000000000..9952e2e7c93
--- /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 00000000000..3ba79ea373b
--- /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 00000000000..995fd806a96
--- /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 00000000000..75120856e13
--- /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