This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [Patch, fortran] PR29642 - Fortran 2003: VALUE Attribute (pass by value)


Tobias,

You will find that this reply breaks the thread; it comes about
because I have shifted to an ia64 to get these tests right and I do
not keep my mail on it - sorry about that.  The last link is:

http://gcc.gnu.org/ml/fortran/2006-11/msg00633.html

What I have done is:

(i) Get rid of the acos in value_1.f90 - it was completely arbitrary
anyway.  I have added a second call to foobar with a non-definable and
non-constant expression, just to verify that they work too.

(ii) In value_4.c, I now return a pointer to the second argument; ie.
the one passed by reference.  I did it this way to avoid any nonsense
with memory leaks.  The interfaces for these functions now delare them
to be pointers.  The code looks fine.

Regtested on an IA64/FC5 - OK for trunk?

Paul

Attachment: Change.Logs
Description: Binary data

Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 119407)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_variable (gfc_se * se, gfc_expr
*** 447,461 ****
  	 separately.  */
        if (sym->ts.type == BT_CHARACTER)
  	{
!           /* Dereference character pointer dummy arguments
  	     or results.  */
  	  if ((sym->attr.pointer || sym->attr.allocatable)
  	      && (sym->attr.dummy
  		  || sym->attr.function
  		  || sym->attr.result))
  	    se->expr = build_fold_indirect_ref (se->expr);
  	}
!       else
  	{
            /* Dereference non-character scalar dummy arguments.  */
  	  if (sym->attr.dummy && !sym->attr.dimension)
--- 447,467 ----
  	 separately.  */
        if (sym->ts.type == BT_CHARACTER)
  	{
! 	  /* Dereference character pointer dummy arguments
  	     or results.  */
  	  if ((sym->attr.pointer || sym->attr.allocatable)
  	      && (sym->attr.dummy
  		  || sym->attr.function
  		  || sym->attr.result))
  	    se->expr = build_fold_indirect_ref (se->expr);
+ 
+ 	  /* A character with VALUE attribute needs an address
+ 	     expression.  */
+ 	  if (sym->attr.value)
+ 	    se->expr = build_fold_addr_expr (se->expr);
+ 
  	}
!       else if (!sym->attr.value)
  	{
            /* Dereference non-character scalar dummy arguments.  */
  	  if (sym->attr.dummy && !sym->attr.dimension)
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 2005,2023 ****
  	  argss = gfc_walk_expr (e);
  
  	  if (argss == gfc_ss_terminator)
!             {
! 	      gfc_conv_expr_reference (&parmse, e);
  	      parm_kind = SCALAR;
!               if (fsym && fsym->attr.pointer
! 		  && e->expr_type != EXPR_NULL)
!                 {
!                   /* Scalar pointer dummy args require an extra level of
! 		  indirection. The null pointer already contains
! 		  this level of indirection.  */
! 		  parm_kind = SCALAR_POINTER;
!                   parmse.expr = build_fold_addr_expr (parmse.expr);
!                 }
!             }
  	  else
  	    {
                /* If the procedure requires an explicit interface, the actual
--- 2011,2036 ----
  	  argss = gfc_walk_expr (e);
  
  	  if (argss == gfc_ss_terminator)
! 	    {
  	      parm_kind = SCALAR;
! 	      if (fsym && fsym->attr.value)
! 		{
! 		  gfc_conv_expr (&parmse, e);
! 		}
! 	      else
! 		{
! 		  gfc_conv_expr_reference (&parmse, e);
! 		  if (fsym && fsym->attr.pointer
! 			&& e->expr_type != EXPR_NULL)
! 		    {
! 		      /* Scalar pointer dummy args require an extra level of
! 			 indirection. The null pointer already contains
! 			 this level of indirection.  */
! 		      parm_kind = SCALAR_POINTER;
! 		      parmse.expr = build_fold_addr_expr (parmse.expr);
! 		    }
! 		}
! 	    }
  	  else
  	    {
                /* If the procedure requires an explicit interface, the actual
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(revision 119407)
--- gcc/fortran/symbol.c	(working copy)
*************** check_conflict (symbol_attribute * attr,
*** 266,271 ****
--- 266,272 ----
    static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
      *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
      *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
+     *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
      *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
      *private = "PRIVATE", *recursive = "RECURSIVE",
      *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
*************** check_conflict (symbol_attribute * attr,
*** 273,279 ****
      *function = "FUNCTION", *subroutine = "SUBROUTINE",
      *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
      *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
!     *cray_pointee = "CRAY POINTEE", *data = "DATA", *volatile_ = "VOLATILE";
    static const char *threadprivate = "THREADPRIVATE";
  
    const char *a1, *a2;
--- 274,281 ----
      *function = "FUNCTION", *subroutine = "SUBROUTINE",
      *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
      *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
!     *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
!     *volatile_ = "VOLATILE";
    static const char *threadprivate = "THREADPRIVATE";
  
    const char *a1, *a2;
*************** check_conflict (symbol_attribute * attr,
*** 402,407 ****
--- 404,424 ----
    conf (data, allocatable);
    conf (data, use_assoc);
  
+   conf (value, pointer)
+   conf (value, allocatable)
+   conf (value, subroutine)
+   conf (value, function)
+   conf (value, volatile_)
+   conf (value, dimension)
+   conf (value, external)
+ 
+   if (attr->value && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
+     {
+       a1 = value;
+       a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
+       goto conflict;
+     }
+ 
    conf (volatile_, intrinsic)
    conf (volatile_, external)
  
*************** check_conflict (symbol_attribute * attr,
*** 524,529 ****
--- 541,547 ----
        conf2 (dummy);
        conf2 (in_common);
        conf2 (save);
+       conf2 (value);
        conf2 (volatile_);
        conf2 (threadprivate);
        break;
*************** gfc_add_save (symbol_attribute * attr, c
*** 805,810 ****
--- 823,848 ----
  }
  
  try
+ gfc_add_value (symbol_attribute * attr, const char *name, locus * where)
+ {
+ 
+   if (check_used (attr, name, where))
+     return FAILURE;
+ 
+   if (attr->value)
+     {
+ 	if (gfc_notify_std (GFC_STD_LEGACY, 
+ 			    "Duplicate VALUE attribute specified at %L",
+ 			    where) 
+ 	    == FAILURE)
+ 	  return FAILURE;
+     }
+ 
+   attr->value = 1;
+   return check_conflict (attr, name, where);
+ }
+ 
+ try
  gfc_add_volatile (symbol_attribute * attr, const char *name, locus * where)
  {
  
*************** gfc_copy_attr (symbol_attribute * dest, 
*** 1257,1262 ****
--- 1295,1302 ----
      goto fail;
    if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
      goto fail;
+   if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
+     goto fail;
    if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
      goto fail;
    if (src->threadprivate && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c	(revision 119407)
--- gcc/fortran/decl.c	(working copy)
*************** match_attr_spec (void)
*** 2117,2123 ****
      DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
      DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
      DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
!     DECL_TARGET, DECL_VOLATILE, DECL_COLON, DECL_NONE,
      GFC_DECL_END /* Sentinel */
    }
    decl_types;
--- 2117,2123 ----
      DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
      DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
      DECL_PARAMETER, DECL_POINTER, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE,
!     DECL_TARGET, DECL_VALUE, DECL_VOLATILE, DECL_COLON, DECL_NONE,
      GFC_DECL_END /* Sentinel */
    }
    decl_types;
*************** match_attr_spec (void)
*** 2140,2145 ****
--- 2140,2146 ----
      minit (", public", DECL_PUBLIC),
      minit (", save", DECL_SAVE),
      minit (", target", DECL_TARGET),
+     minit (", value", DECL_VALUE),
      minit (", volatile", DECL_VOLATILE),
      minit ("::", DECL_COLON),
      minit (NULL, DECL_NONE)
*************** match_attr_spec (void)
*** 2261,2266 ****
--- 2262,2270 ----
  	  case DECL_TARGET:
  	    attr = "TARGET";
  	    break;
+ 	  case DECL_VALUE:
+ 	    attr = "VALUE";
+ 	    break;
  	  case DECL_VOLATILE:
  	    attr = "VOLATILE";
  	    break;
*************** match_attr_spec (void)
*** 2378,2383 ****
--- 2382,2396 ----
  	  t = gfc_add_target (&current_attr, &seen_at[d]);
  	  break;
  
+ 	case DECL_VALUE:
+ 	  if (gfc_notify_std (GFC_STD_F2003,
+                               "Fortran 2003: VALUE attribute at %C")
+ 	      == FAILURE)
+ 	    t = FAILURE;
+ 	  else
+ 	    t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
+ 	  break;
+ 
  	case DECL_VOLATILE:
  	  if (gfc_notify_std (GFC_STD_F2003,
                                "Fortran 2003: VOLATILE attribute at %C")
*************** syntax:
*** 4051,4056 ****
--- 4064,4120 ----
  
  
  match
+ gfc_match_value (void)
+ {
+   gfc_symbol *sym;
+   match m;
+ 
+   if (gfc_notify_std (GFC_STD_F2003, 
+ 		      "Fortran 2003: VALUE statement at %C")
+       == FAILURE)
+     return MATCH_ERROR;
+ 
+   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
+     {
+       return MATCH_ERROR;
+     }
+ 
+   if (gfc_match_eos () == MATCH_YES)
+     goto syntax;
+ 
+   for(;;)
+     {
+       m = gfc_match_symbol (&sym, 0);
+       switch (m)
+ 	{
+ 	case MATCH_YES:
+ 	  if (gfc_add_value (&sym->attr, sym->name,
+   			        &gfc_current_locus) == FAILURE)
+ 	    return MATCH_ERROR;
+ 	  goto next_item;
+ 
+ 	case MATCH_NO:
+ 	  break;
+ 
+ 	case MATCH_ERROR:
+ 	  return MATCH_ERROR;
+ 	}
+ 
+     next_item:
+       if (gfc_match_eos () == MATCH_YES)
+ 	break;
+       if (gfc_match_char (',') != MATCH_YES)
+ 	goto syntax;
+     }
+ 
+   return MATCH_YES;
+ 
+ syntax:
+   gfc_error ("Syntax error in VALUE statement at %C");
+   return MATCH_ERROR;
+ }
+ 
+ match
  gfc_match_volatile (void)
  {
    gfc_symbol *sym;
Index: gcc/fortran/dump-parse-tree.c
===================================================================
*** gcc/fortran/dump-parse-tree.c	(revision 119407)
--- gcc/fortran/dump-parse-tree.c	(working copy)
*************** gfc_show_attr (symbol_attribute * attr)
*** 552,557 ****
--- 552,559 ----
      gfc_status (" POINTER");
    if (attr->save)
      gfc_status (" SAVE");
+   if (attr->value)
+     gfc_status (" VALUE");
    if (attr->volatile_)
      gfc_status (" VOLATILE");
    if (attr->threadprivate)
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h	(revision 119407)
--- gcc/fortran/gfortran.h	(working copy)
*************** typedef struct
*** 476,482 ****
  {
    /* Variable attributes.  */
    unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
!     optional:1, pointer:1, save:1, target:1, volatile_:1,
      dummy:1, result:1, assign:1, threadprivate:1;
  
    unsigned data:1,		/* Symbol is named in a DATA statement.  */
--- 476,482 ----
  {
    /* Variable attributes.  */
    unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
!     optional:1, pointer:1, save:1, target:1, value:1, volatile_:1,
      dummy:1, result:1, assign:1, threadprivate:1;
  
    unsigned data:1,		/* Symbol is named in a DATA statement.  */
*************** try gfc_add_pure (symbol_attribute *, lo
*** 1868,1873 ****
--- 1868,1874 ----
  try gfc_add_recursive (symbol_attribute *, locus *);
  try gfc_add_function (symbol_attribute *, const char *, locus *);
  try gfc_add_subroutine (symbol_attribute *, const char *, locus *);
+ try gfc_add_value (symbol_attribute *, const char *, locus *);
  try gfc_add_volatile (symbol_attribute *, const char *, locus *);
  
  try gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *);
Index: gcc/fortran/module.c
===================================================================
*** gcc/fortran/module.c	(revision 119407)
--- gcc/fortran/module.c	(working copy)
*************** mio_internal_string (char *string)
*** 1487,1497 ****
  
  typedef enum
  { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
!   AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT,
!   AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON, 
!   AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
!   AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
!   AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP, AB_VOLATILE
  }
  ab_attribute;
  
--- 1487,1497 ----
  
  typedef enum
  { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
!   AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
!   AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
!   AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
!   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
!   AB_VALUE, AB_VOLATILE
  }
  ab_attribute;
  
*************** static const mstring attr_bits[] =
*** 1504,1509 ****
--- 1504,1510 ----
      minit ("OPTIONAL", AB_OPTIONAL),
      minit ("POINTER", AB_POINTER),
      minit ("SAVE", AB_SAVE),
+     minit ("VALUE", AB_VALUE),
      minit ("VOLATILE", AB_VOLATILE),
      minit ("TARGET", AB_TARGET),
      minit ("THREADPRIVATE", AB_THREADPRIVATE),
*************** mio_symbol_attribute (symbol_attribute *
*** 1575,1580 ****
--- 1576,1583 ----
  	MIO_NAME(ab_attribute) (AB_POINTER, attr_bits);
        if (attr->save)
  	MIO_NAME(ab_attribute) (AB_SAVE, attr_bits);
+       if (attr->value)
+ 	MIO_NAME(ab_attribute) (AB_VALUE, attr_bits);
        if (attr->volatile_)
  	MIO_NAME(ab_attribute) (AB_VOLATILE, attr_bits);
        if (attr->target)
*************** mio_symbol_attribute (symbol_attribute *
*** 1655,1660 ****
--- 1658,1666 ----
  	    case AB_SAVE:
  	      attr->save = 1;
  	      break;
+ 	    case AB_VALUE:
+ 	      attr->value = 1;
+ 	      break;
  	    case AB_VOLATILE:
  	      attr->volatile_ = 1;
  	      break;
Index: gcc/fortran/trans-types.c
===================================================================
*** gcc/fortran/trans-types.c	(revision 119407)
--- gcc/fortran/trans-types.c	(working copy)
*************** gfc_sym_type (gfc_symbol * sym)
*** 1343,1349 ****
        sym->ts.kind = gfc_default_real_kind;
      }
  
!   if (sym->attr.dummy && !sym->attr.function)
      byref = 1;
    else
      byref = 0;
--- 1343,1349 ----
        sym->ts.kind = gfc_default_real_kind;
      }
  
!   if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
      byref = 1;
    else
      byref = 0;
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 119407)
--- gcc/fortran/resolve.c	(working copy)
*************** was_declared (gfc_symbol * sym)
*** 675,681 ****
      return 1;
  
    if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
!       || a.optional || a.pointer || a.save || a.target || a.volatile_
        || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
      return 1;
  
--- 675,681 ----
      return 1;
  
    if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic
!       || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value
        || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN)
      return 1;
  
*************** resolve_symbol (gfc_symbol * sym)
*** 5961,5966 ****
--- 5961,5974 ----
        return;
      }
  
+   if (sym->attr.value && !sym->attr.dummy)
+     {
+       gfc_error ("'%s' at %L cannot have the VALUE attribute because "
+ 		 "it is not a dummy", sym->name, &sym->declared_at);
+       return;
+     }
+ 
+ 
    /* If a derived type symbol has reached this point, without its
       type being declared, we have an error.  Notice that most
       conditions that produce undefined derived types have already
Index: gcc/fortran/match.h
===================================================================
*** gcc/fortran/match.h	(revision 119407)
--- gcc/fortran/match.h	(working copy)
*************** match gfc_match_public (gfc_statement *)
*** 147,152 ****
--- 147,153 ----
  match gfc_match_save (void);
  match gfc_match_modproc (void);
  match gfc_match_target (void);
+ match gfc_match_value (void);
  match gfc_match_volatile (void);
  
  /* primary.c */
Index: gcc/fortran/parse.c
===================================================================
*** gcc/fortran/parse.c	(revision 119407)
--- gcc/fortran/parse.c	(working copy)
*************** decode_statement (void)
*** 284,289 ****
--- 284,290 ----
        break;
  
      case 'v':
+       match ("value", gfc_match_value, ST_ATTR_DECL);
        match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
        break;
  
Index: gcc/testsuite/gfortran.dg/value_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/value_1.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/value_1.f90	(revision 0)
***************
*** 0 ****
--- 1,84 ----
+ ! { dg-do run }
+ ! { dg-options "-std=f2003 -fall-intrinsics" }
+ ! Tests the functionality of the patch for PR29642, which requested the
+ ! implementation of the F2003 VALUE attribute for gfortran.
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org> 
+ !
+ module global
+   type :: mytype
+     real(4) :: x
+     character(4) :: c
+   end type mytype
+ contains
+   subroutine typhoo (dt)
+     type(mytype), value :: dt
+     if (dtne (dt, mytype (42.0, "lmno"))) call abort ()
+     dt = mytype (21.0, "wxyz")
+     if (dtne (dt, mytype (21.0, "wxyz"))) call abort ()
+   end subroutine typhoo
+ 
+   logical function dtne (a, b)
+     type(mytype) :: a, b
+     dtne = .FALSE.
+     if ((a%x /= b%x) .or. (a%c /= b%c)) dtne = .TRUE.
+   end function dtne
+ end module global
+ 
+ program test_value
+   use global
+   integer(8) :: i = 42
+   real(8) :: r = 42.0
+   character(2) ::   c = "ab"
+   complex(8) :: z = (-99.0, 199.0)
+   type(mytype) :: dt = mytype (42.0, "lmno")
+ 
+   call foo (c)
+   if (c /= "ab") call abort ()
+ 
+   call bar (i)
+   if (i /= 42) call abort ()
+ 
+   call foobar (r)
+   if (r /= 42.0) call abort ()
+ 
+   call complex_foo (z)
+   if (z /= (-99.0, 199.0)) call abort ()
+ 
+   call typhoo (dt)
+   if (dtne (dt, mytype (42.0, "lmno"))) call abort ()
+ 
+   r = 20.0
+   call foobar (r*2.0 + 2.0)
+ 
+ contains
+   subroutine foo (c)
+     character(2), value :: c
+     if (c /= "ab") call abort ()
+     c = "cd"
+     if (c /= "cd") call abort ()
+   end subroutine foo
+ 
+   subroutine bar (i)
+     integer(8), value :: i
+     if (i /= 42) call abort ()
+     i = 99
+     if (i /= 99) call abort ()
+   end subroutine bar
+ 
+   subroutine foobar (r)
+     real(8), value :: r
+     if (r /= 42.0) call abort ()
+     r = 99.0
+     if (r /= 99.0) call abort ()
+   end subroutine foobar
+ 
+   subroutine complex_foo (z)
+     COMPLEX(8), value :: z
+     if (z /= (-99.0, 199.0)) call abort ()
+     z = (77.0, -42.0)
+     if (z /= (77.0, -42.0)) call abort ()
+   end subroutine complex_foo
+ 
+ end program test_value
+ ! { dg-final { cleanup-modules "global" } }
Index: gcc/testsuite/gfortran.dg/value_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/value_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/value_2.f90	(revision 0)
***************
*** 0 ****
--- 1,21 ----
+ ! { dg-do compile }
+ ! { dg-options "-std=f95" }
+ ! Tests the standard check in the patch for PR29642, which requested the
+ ! implementation of the F2003 VALUE attribute for gfortran.
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org> 
+ !
+ program test_value
+   integer(8) :: i = 42
+ 
+   call bar (i)
+   if (i /= 42) call abort ()
+ contains
+   subroutine bar (i)
+     integer(8) :: i
+     value :: i      ! { dg-error "Fortran 2003: VALUE" }
+     if (i /= 42) call abort ()
+     i = 99
+     if (i /= 99) call abort ()
+   end subroutine bar
+ end program test_value
Index: gcc/testsuite/gfortran.dg/value_4.c
===================================================================
*** gcc/testsuite/gfortran.dg/value_4.c	(revision 0)
--- gcc/testsuite/gfortran.dg/value_4.c	(revision 0)
***************
*** 0 ****
--- 1,48 ----
+ /*  Passing from fortran to C by value, using VALUE.  This is identical
+     to c_by_val_1.c, which performs the same function for %VAL.
+ 
+     Contributed by Paul Thomas <pault@gcc.gnu.org>  */
+ 
+ typedef struct { float r, i; } complex;
+ extern float *f_to_f__ (float, float*);
+ extern int *i_to_i__ (int, int*);
+ extern void c_to_c__ (complex*, complex, complex*);
+ extern void abort (void);
+ 
+ /* In f_to_f and i_to_i we return the second argument, so that we do
+    not have to worry about keeping track of memory allocation between
+    fortran and C.  All three functions check that the argument passed
+    by value is the same as that passed by reference.  Then the passed
+    by value argument is modified so that the caller can check that
+    its version has not changed.*/
+ 
+ float *
+ f_to_f__(float a1, float *a2)
+ {
+   if ( a1 != *a2 ) abort();
+   *a2 = a1 * 2.0;
+   a1 = 0.0;
+   return a2;
+ }
+ 
+ int *
+ i_to_i__(int i1, int *i2)
+ {
+   if ( i1 != *i2 ) abort();
+   *i2 = i1 * 3;
+   i1 = 0;
+   return i2;
+ }
+ 
+ void
+ c_to_c__(complex *retval, complex c1, complex *c2)
+ {
+   if ( c1.r != c2->r ) abort();
+   if ( c1.i != c2->i ) abort();
+   c1.r = 0.0;
+   c1.i = 0.0;
+   retval->r = c2->r * 4.0;
+   retval->i = c2->i * 4.0;
+   return;
+ }
+ 
Index: gcc/testsuite/gfortran.dg/value_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/value_3.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/value_3.f90	(revision 0)
***************
*** 0 ****
--- 1,53 ----
+ ! { dg-do compile }
+ ! Tests the constraints in the patch for PR29642, which requested the
+ ! implementation of the F2003 VALUE attribute for gfortran.
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org> 
+ !
+ program test_value
+   integer(8) :: i = 42, j   ! { dg-error "not a dummy" }
+   integer(8), value :: k    ! { dg-error "not a dummy" }
+   value :: j
+ 
+ contains
+   subroutine bar_1 (i)
+     integer(8) :: i
+     dimension i(8)
+     value :: i  ! { dg-error "conflicts with DIMENSION" }
+     i = 0
+   end subroutine bar_1
+ 
+   subroutine bar_2 (i)
+     integer(8) :: i
+     pointer :: i
+     value :: i  ! { dg-error "conflicts with POINTER" }
+     i = 0
+   end subroutine bar_2
+ 
+   integer function bar_3 (i)
+     integer(8) :: i
+     dimension i(8)
+     value :: bar_3  ! { dg-error "conflicts with FUNCTION" }
+     i = 0
+     bar_3 = 0
+   end function bar_3
+ 
+   subroutine bar_4 (i, j)
+     integer(8), intent(inout) :: i
+     integer(8), intent(out) :: j
+     value :: i  ! { dg-error "conflicts with INTENT" }
+     value :: j  ! { dg-error "conflicts with INTENT" }
+     i = 0
+     j = 0
+   end subroutine bar_4
+ 
+   integer function bar_5 ()
+     integer(8) :: i
+     external :: i
+     integer, parameter :: j = 99
+     value :: i  ! { dg-error "conflicts with EXTERNAL" }
+     value :: j  ! { dg-error "PARAMETER attribute conflicts with" }
+     bar_5 = 0
+   end function bar_5
+ 
+ end program test_value
Index: gcc/testsuite/gfortran.dg/value_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/value_4.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/value_4.f90	(revision 0)
***************
*** 0 ****
--- 1,84 ----
+ ! { dg-do run }
+ ! { dg-additional-sources value_4.c }
+ ! { dg-options "-ff2c -w -O0" }
+ !
+ ! Tests the functionality of the patch for PR29642, which requested the
+ ! implementation of the F2003 VALUE attribute for gfortran, by calling
+ ! external C functions by value and by reference.  This is effectively
+ ! identical to c_by_val_1.f, which does the same for %VAL.
+ !
+ ! Contributed by Paul Thomas  <pault@gcc.gnu.org> 
+ !
+ module global
+   interface delta
+     module procedure deltai, deltar, deltac
+   end interface delta
+   real(4) :: epsi = epsilon (1.0_4)
+ contains
+   function deltai (a, b) result (c)
+     integer(4) :: a, b
+     logical :: c
+     c = (a /= b)
+   end function deltai
+ 
+   function deltar (a, b) result (c)
+     real(4) :: a, b
+     logical :: c
+     c = (abs (a-b) > epsi)
+   end function deltar
+ 
+   function deltac (a, b) result (c)
+     complex(4) :: a, b
+     logical :: c
+     c = ((abs (real (a-b)) > epsi).or.(abs (aimag (a-b)) > epsi))
+   end function deltac
+ end module global  
+ 
+ program value_4
+   use global
+   interface
+     function f_to_f (x, y)
+       real(4), pointer :: f_to_f
+       real(4) :: x, y
+       value :: x
+     end function f_to_f
+   end interface
+ 
+   interface
+     function i_to_i (x, y)
+       integer(4), pointer :: i_to_i
+       integer(4) :: x, y
+       value :: x
+     end function i_to_i
+   end interface
+ 
+   interface
+     complex(4) function c_to_c (x, y)
+       complex(4) :: x, y
+       value :: x
+     end function c_to_c
+   end interface
+ 
+   real(4)       a, b, c
+   integer(4)    i, j, k
+   complex(4)    u, v, w
+ 
+   a = 42.0
+   b = 0.0
+   c = a
+   b = f_to_f (a, c)
+   if (delta ((2.0 * a), b)) call abort ()
+ 
+   i = 99
+   j = 0
+   k = i
+   j = i_to_i (i, k)
+   if (delta ((3 * i), j)) call abort ()
+ 
+   u = (-1.0, 2.0)
+   v = (1.0, -2.0)
+   w = u
+   v = c_to_c (u, w)
+   if (delta ((4.0 * u), v)) call abort ()
+ end program value_4
+ ! { dg-final { cleanup-modules "global" } }

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]