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]

[Patch, fortran] PR23060 - %VAL, %LOC and %REF


:ADDPATCH fortran:

This patch implements the argument list "functions" %VAL, %LOC and %REF.

It is straightforward upto the following remarks:
(i) It was not evident how to implement these so-called functions
because their context is so specific.  Rather than implementing
intrinsic functions, I have chosen to signal them using the keyword
name field of the actual_arglist structure.  This does not lead to any
problems because these relics commence with '%'.  I thought that it
would be too cumbersome to make this field a union of two names.
(ii) I have chosen to dodge the CHARACTER question by implementing
these functions as for Digital Fortran; ie. I have not allowed
CHARACTER arguments!
(iii) Unlike Digital Fortran, complex arguments are permitted in %VAL.
(iv) The tests are a minimum to check the basic functionailty.

Bootstrapped and regtested on ia64/FC5 - OK for trunk?

Paul
2006-12-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/23060
	* intrinsic.c (compare_actual_formal ): Distinguish argument
	list functions from keywords.
	* intrinsic.c (sort_actual): If formal is NULL, the presence of
	an argument list function actual is an error.
	* trans-expr.c (conv_arglist_function) : New function to
	implement argument list functions %VAL, %REF and %LOC.
	(gfc_conv_function_call): Call it.
	* resolve.c (resolve_actual_arglist): Add arg ptype and check
	argument list functions.
	(resolve_function, resolve_call): Set value of ptype before
	calls to resolve_actual_arglist.
	* primary.c (match_arg_list_function): New function.
	(gfc_match_actual_arglist): Call it before trying for a
	keyword argument.

2006-12-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/23060
	* gfortran.dg/c_by_val.c: Called by c_by_val_1.f.
	* gfortran.dg/c_by_val_1.f: New test.
	* gfortran.dg/c_by_val_2.f: New test.
	* gfortran.dg/c_by_val_3.f: New test.
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(revision 120260)
--- gcc/fortran/interface.c	(working copy)
*************** compare_actual_formal (gfc_actual_arglis
*** 1293,1299 ****
  
    for (a = actual; a; a = a->next, f = f->next)
      {
!       if (a->name != NULL)
  	{
  	  i = 0;
  	  for (f = formal; f; f = f->next, i++)
--- 1293,1300 ----
  
    for (a = actual; a; a = a->next, f = f->next)
      {
!       /* Look for keywords but ignore g77 extensions like %VAL.  */
!       if (a->name != NULL && a->name[0] != '%')
  	{
  	  i = 0;
  	  for (f = formal; f; f = f->next, i++)
Index: gcc/fortran/intrinsic.c
===================================================================
*** gcc/fortran/intrinsic.c	(revision 120260)
--- gcc/fortran/intrinsic.c	(working copy)
*************** keywords:
*** 2864,2870 ****
  
        if (f == NULL)
  	{
! 	  gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
  		     a->name, name, where);
  	  return FAILURE;
  	}
--- 2864,2874 ----
  
        if (f == NULL)
  	{
! 	  if (a->name[0] == '%')
! 	    gfc_error ("Argument list function at %L is not allowed in this "
! 		       "context.", where);
! 	  else
! 	    gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
  		     a->name, name, where);
  	  return FAILURE;
  	}
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 120260)
--- gcc/fortran/trans-expr.c	(working copy)
*************** is_aliased_array (gfc_expr * e)
*** 1906,1911 ****
--- 1906,1962 ----
    return false;
  }
  
+ /* Generate the code for argument list functions.  */
+ 
+ static void
+ conv_arglist_function (gfc_se * se, gfc_expr * expr, const char * name)
+ {
+   tree type = NULL_TREE;
+   /* Pass by value for g77 %VAL(arg), pass the address
+      indirectly for %LOC, else by reference.  Thus %REF
+      is a "do-nothing" and %LOC is the same as an F95
+      pointer.  */
+   if (strncmp (name, "%VAL", 4) == 0)
+     {
+       gfc_conv_expr (se, expr);
+       /* %VAL is converts argument to default kind.  */
+       switch (expr->ts.type)
+ 	{
+ 	  case BT_REAL:
+ 	    type = gfc_get_real_type (gfc_default_real_kind);
+ 	    se->expr = fold_convert (type, se->expr);
+ 	    break;
+ 	  case BT_COMPLEX:
+ 	    type = gfc_get_complex_type (gfc_default_complex_kind);
+ 	    se->expr = fold_convert (type, se->expr);
+ 	    break;
+ 	  case BT_INTEGER:
+ 	    type = gfc_get_int_type (gfc_default_integer_kind);
+ 	    se->expr = fold_convert (type, se->expr);
+ 	    break;
+ 	  case BT_LOGICAL:
+ 	    type = gfc_get_logical_type (gfc_default_logical_kind);
+ 	    se->expr = fold_convert (type, se->expr);
+ 	    break;
+ 	  /* This should have been resolved away.  */
+ 	  case BT_UNKNOWN: case BT_CHARACTER: case BT_DERIVED:
+ 	  case BT_PROCEDURE: case BT_HOLLERITH:
+ 	    gfc_error ("Bad type in conv_arglist_function");
+ 	}
+ 	  
+     }
+   else if (strncmp (name, "%LOC", 4) == 0)
+     {
+       gfc_conv_expr_reference (se, expr);
+       se->expr = gfc_build_addr_expr (NULL, se->expr);
+     }
+   else if (strncmp (name, "%REF", 4) == 0)
+     gfc_conv_expr_reference (se, expr);
+   else
+     gfc_error ("Unknown argument list function at %L", &expr->where);
+ }
+ 
+ 
  /* Generate code for a procedure call.  Note can return se->post != NULL.
     If se->direct_byref is set then se->expr contains the return parameter.
     Return nonzero, if the call has alternate specifiers.  */
*************** gfc_conv_function_call (gfc_se * se, gfc
*** 2024,2029 ****
--- 2075,2084 ----
  		{
  		  gfc_conv_expr (&parmse, e);
  		}
+ 	      else if (arg->name && arg->name[0] == '%')
+ 		/* Argument list functions %VAL, %LOC and %REF are signalled
+ 		   through arg->name.  */
+ 		conv_arglist_function (&parmse, arg->expr, arg->name);
  	      else
  		{
  		  gfc_conv_expr_reference (&parmse, e);
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 120260)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_assumed_size_actual (gfc_expr *e
*** 844,850 ****
     references.  */
  
  static try
! resolve_actual_arglist (gfc_actual_arglist * arg)
  {
    gfc_symbol *sym;
    gfc_symtree *parent_st;
--- 844,850 ----
     references.  */
  
  static try
! resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype)
  {
    gfc_symbol *sym;
    gfc_symtree *parent_st;
*************** resolve_actual_arglist (gfc_actual_argli
*** 852,858 ****
  
    for (; arg; arg = arg->next)
      {
- 
        e = arg->expr;
        if (e == NULL)
          {
--- 852,857 ----
*************** resolve_actual_arglist (gfc_actual_argli
*** 873,879 ****
  	{
  	  if (gfc_resolve_expr (e) != SUCCESS)
  	    return FAILURE;
! 	  continue;
  	}
  
        /* See if the expression node should really be a variable
--- 872,878 ----
  	{
  	  if (gfc_resolve_expr (e) != SUCCESS)
  	    return FAILURE;
! 	  goto argument_list;
  	}
  
        /* See if the expression node should really be a variable
*************** resolve_actual_arglist (gfc_actual_argli
*** 938,944 ****
  		      && sym->ns->parent->proc_name == sym)))
  	    goto got_variable;
  
! 	  continue;
  	}
  
        /* See if the name is a module procedure in a parent unit.  */
--- 937,943 ----
  		      && sym->ns->parent->proc_name == sym)))
  	    goto got_variable;
  
! 	  goto argument_list;
  	}
  
        /* See if the name is a module procedure in a parent unit.  */
*************** resolve_actual_arglist (gfc_actual_argli
*** 962,968 ****
  	  || sym->attr.intrinsic
  	  || sym->attr.external)
  	{
! 	  continue;
  	}
  
      got_variable:
--- 961,967 ----
  	  || sym->attr.intrinsic
  	  || sym->attr.external)
  	{
! 	  goto argument_list;
  	}
  
      got_variable:
*************** resolve_actual_arglist (gfc_actual_argli
*** 976,981 ****
--- 975,1036 ----
  	  e->ref->u.ar.type = AR_FULL;
  	  e->ref->u.ar.as = sym->as;
  	}
+ 
+     argument_list:
+       /* Check argument list functions %VAL, %LOC and %REF.  There is
+ 	 nothing to do for %REF.  */
+       if (arg->name && arg->name[0] == '%')
+ 	{
+ 	  if (strncmp ("%VAL", arg->name, 4) == 0)
+ 	    {
+ 	      if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED)
+ 		{
+ 		  gfc_error ("By-value argument at %L is not of numeric "
+ 			     "type.", &e->where);
+ 		  return FAILURE;
+ 		}
+ 
+ 	      if (e->rank)
+ 		{
+ 		  gfc_error ("By-value argument at %L cannot be an array or "
+ 			     "an array section.", &e->where);
+ 		return FAILURE;
+ 		}
+ 
+ 	      /* Intrinsics are still PROC_UNKNOWN here.  However,
+ 		 since same file external procedures are not resolvable
+ 		 in gfortran, it is a good deal easier to leave them to
+ 		 intrinsic.c.  */
+ 	      if (ptype != PROC_UNKNOWN && ptype != PROC_EXTERNAL)
+ 		{
+ 		  gfc_error ("By-value argument at %L is not allowed "
+ 			     "in this context.", &e->where);
+ 		  return FAILURE;
+ 		}
+ 
+ 	      if (((e->ts.type == BT_REAL || e->ts.type == BT_COMPLEX)
+ 		    && e->ts.kind > gfc_default_real_kind)
+ 		      || (e->ts.kind > gfc_default_integer_kind))
+ 		{
+ 		  gfc_error ("Kind of by-value argument at %L is larger "
+ 			     "than default kind.", &e->where);
+ 		  return FAILURE;
+ 		}
+ 
+ 	    }
+ 
+ 	  /* Statement functions have already been excluded above.  */
+ 	  else if (strncmp ("%LOC", arg->name, 4) == 0
+ 		     && e->ts.type == BT_PROCEDURE)
+ 	    {
+ 	      if (e->symtree->n.sym->attr.proc == PROC_INTERNAL)
+ 		{
+ 		  gfc_error ("Passing internal procedure at %L by location "
+ 			     "not allowed.", &e->where);
+ 		  return FAILURE;
+ 		}
+ 	    }
+ 	}
      }
  
    return SUCCESS;
*************** resolve_function (gfc_expr * expr)
*** 1451,1456 ****
--- 1506,1512 ----
    const char *name;
    try t;
    int temp;
+   procedure_type p = PROC_INTRINSIC;
  
    sym = NULL;
    if (expr->symtree)
*************** resolve_function (gfc_expr * expr)
*** 1467,1474 ****
       of procedure, once the procedure itself is resolved.  */
    need_full_assumed_size++;
  
!   if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
!     return FAILURE;
  
    /* Resume assumed_size checking. */
    need_full_assumed_size--;
--- 1523,1533 ----
       of procedure, once the procedure itself is resolved.  */
    need_full_assumed_size++;
  
!   if (expr->symtree && expr->symtree->n.sym)
!     p = expr->symtree->n.sym->attr.proc;
! 
!   if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
!       return FAILURE;
  
    /* Resume assumed_size checking. */
    need_full_assumed_size--;
*************** static try
*** 1848,1853 ****
--- 1907,1913 ----
  resolve_call (gfc_code * c)
  {
    try t;
+   procedure_type ptype = PROC_INTRINSIC;
  
    if (c->symtree && c->symtree->n.sym
  	&& c->symtree->n.sym->ts.type != BT_UNKNOWN)
*************** resolve_call (gfc_code * c)
*** 1894,1900 ****
       of procedure, once the procedure itself is resolved.  */
    need_full_assumed_size++;
  
!   if (resolve_actual_arglist (c->ext.actual) == FAILURE)
      return FAILURE;
  
    /* Resume assumed_size checking. */
--- 1954,1963 ----
       of procedure, once the procedure itself is resolved.  */
    need_full_assumed_size++;
  
!   if (c->symtree && c->symtree->n.sym)
!     ptype = c->symtree->n.sym->attr.proc;
! 
!   if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
      return FAILURE;
  
    /* Resume assumed_size checking. */
Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c	(revision 120260)
--- gcc/fortran/primary.c	(working copy)
*************** cleanup:
*** 1429,1434 ****
--- 1429,1508 ----
  }
  
  
+ /* Match an argument list function, such as %VAL.  */
+ 
+ static match
+ match_arg_list_function (gfc_actual_arglist *result)
+ {
+   char name[GFC_MAX_SYMBOL_LEN + 1];
+   locus g77_locus;
+   match m;
+ 
+   g77_locus = gfc_current_locus;
+ 
+   if (gfc_match_char ('%') != MATCH_YES)
+     {
+       m = MATCH_NO;
+       goto cleanup;
+     }
+ 
+   m = gfc_match ("%n (", name);
+   if (m != MATCH_YES)
+     goto cleanup;
+ 
+   if (name[0] != '\0')
+     {
+       switch (name[0])
+ 	{
+ 	case 'l':
+ 	  if (strncmp(name, "loc", 3) == 0)
+ 	    {
+ 	      result->name = "%LOC";
+ 	      break;
+ 	    }
+ 	case 'r':
+ 	  if (strncmp(name, "ref", 3) == 0)
+ 	    {
+ 	      result->name = "%REF";
+ 	      break;
+ 	    }
+ 	case 'v':
+ 	  if (strncmp(name, "val", 3) == 0)
+ 	    {
+ 	      result->name = "%VAL";
+ 	      break;
+ 	    }
+ 	default:
+ 	  m = MATCH_ERROR;
+ 	  goto cleanup;
+ 	}
+     }
+ 
+   if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
+ 		      "function at %C.") == FAILURE)
+     {
+       m = MATCH_ERROR;
+       goto cleanup;
+     }
+ 
+   m = match_actual_arg (&result->expr);
+   if (m != MATCH_YES)
+     goto cleanup;
+ 
+   if (gfc_match_char (')') != MATCH_YES)
+     {
+       m = MATCH_NO;
+       goto cleanup;
+     }
+ 
+   return MATCH_YES;
+ 
+ cleanup:
+   gfc_current_locus = g77_locus;
+   return m;
+ }
+ 
+ 
  /* Matches an actual argument list of a function or subroutine, from
     the opening parenthesis to the closing parenthesis.  The argument
     list is assumed to allow keyword arguments because we don't know if
*************** gfc_match_actual_arglist (int sub_flag, 
*** 1497,1509 ****
  	}
        else
  	{
! 	  /* See if we have the first keyword argument.  */
! 	  m = match_keyword_arg (tail, head);
! 	  if (m == MATCH_YES)
! 	    seen_keyword = 1;
  	  if (m == MATCH_ERROR)
  	    goto cleanup;
  
  	  if (m == MATCH_NO)
  	    {
  	      /* Try for a non-keyword argument.  */
--- 1571,1591 ----
  	}
        else
  	{
! 	  /* Try an argument list function, like %VAL.  */
! 	  m = match_arg_list_function (tail);
  	  if (m == MATCH_ERROR)
  	    goto cleanup;
  
+ 	  /* See if we have the first keyword argument.  */
+ 	  if (m == MATCH_NO)
+ 	    {
+ 	      m = match_keyword_arg (tail, head);
+ 	      if (m == MATCH_YES)
+ 		seen_keyword = 1;
+ 	      if (m == MATCH_ERROR)
+ 		goto cleanup;
+ 	    }
+ 
  	  if (m == MATCH_NO)
  	    {
  	      /* Try for a non-keyword argument.  */
*************** gfc_match_actual_arglist (int sub_flag, 
*** 1515,1520 ****
--- 1597,1603 ----
  	    }
  	}
  
+ 
      next:
        if (gfc_match_char (')') == MATCH_YES)
  	break;
Index: gcc/testsuite/gfortran.dg/c_by_val.c
===================================================================
*** gcc/testsuite/gfortran.dg/c_by_val.c	(revision 0)
--- gcc/testsuite/gfortran.dg/c_by_val.c	(revision 0)
***************
*** 0 ****
--- 1,41 ----
+ /*  Passing from fortran to C by value, using %VAL.  */
+ 
+ typedef struct { float r, i; } complex;
+ extern void f_to_f__ (float*, float, float*, float**);
+ extern void i_to_i__ (int*, int, int*, int**);
+ extern void c_to_c__ (complex*, complex, complex*, complex**);
+ extern void abort (void);
+ 
+ void
+ f_to_f__(float *retval, float a1, float *a2, float **a3)
+ {
+   if ( a1 != *a2 ) abort();
+   if ( a1 != **a3 ) abort();
+   a1 = 0.0;
+   *retval = *a2 * 2.0;
+   return;
+ }
+ 
+ void
+ i_to_i__(int *retval, int i1, int *i2, int **i3)
+ {
+   if ( i1 != *i2 ) abort();
+   if ( i1 != **i3 ) abort();
+   i1 = 0;
+   *retval = *i2 * 3;
+   return;
+ }
+ 
+ void
+ c_to_c__(complex *retval, complex c1, complex *c2, complex **c3)
+ {
+   if ( c1.r != c2->r ) abort();
+   if ( c1.i != c2->i ) abort();
+   if ( c1.r != (*c3)->r ) abort();
+   if ( c1.i != (*c3)->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/c_by_val_1.f
===================================================================
*** gcc/testsuite/gfortran.dg/c_by_val_1.f	(revision 0)
--- gcc/testsuite/gfortran.dg/c_by_val_1.f	(revision 0)
***************
*** 0 ****
--- 1,31 ----
+ C { dg-do run }
+ C { dg-additional-sources c_by_val.c }
+ C { dg-options "-ff2c -w -O0" }
+ 
+       program c_by_val_1
+       external   f_to_f, i_to_i, c_to_c
+       real       a, b, c
+       integer*4  i, j, k
+       complex    u, v, w, c_to_c
+ 
+       a = 42.0
+       b = 0.0
+       c = a
+       call  f_to_f (b, %VAL (a), %REF (c), %LOC (c))
+       if ((2.0 * a).ne.b) call abort ()
+ 
+       i = 99
+       j = 0
+       k = i
+       call i_to_i (j, %VAL (i), %REF (k), %LOC (k))
+       if ((3 * i).ne.j) call abort ()
+ 
+       u = (-1.0, 2.0)
+       v = (1.0, -2.0)
+       w = u
+       v = c_to_c (%VAL (u), %REF (w), %LOC (w))
+       if ((4.0 * u).ne.v) call abort ()
+ 
+       stop
+       end
+ 
Index: gcc/testsuite/gfortran.dg/c_by_val_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/c_by_val_2.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/c_by_val_2.f90	(revision 0)
***************
*** 0 ****
--- 1,29 ----
+ ! { dg-do compile }
+ ! { dg-options "-w" }
+ 
+ program c_by_val_2
+   external bar
+   real (4) :: bar, ar(2) = (/1.0,2.0/)
+   type     :: mytype
+     integer  :: i
+   end type mytype
+   type(mytype)  :: z
+   character(8)  :: c = "blooey"
+   print *, sin (%VAL(2.0))   ! { dg-error "not allowed in this context" }
+   print *, foo (%VAL(1.0))   ! { dg-error "not allowed in this context" }
+   call  foobar (%VAL(0.5))   ! { dg-error "not allowed in this context" }
+   print *, bar (%VAL(z))     ! { dg-error "not of numeric type" }
+   print *, bar (%VAL(c))     ! { dg-error "not of numeric type" }
+   print *, bar (%VAL(ar))    ! { dg-error "cannot be an array" }
+   print *, bar (%VAL(0.0))
+ contains
+   function foo (a)
+     real(4) :: a, foo
+     foo = cos (a)
+   end function foo
+   subroutine foobar (a)
+     real(4) :: a
+     print *, a
+   end subroutine foobar
+ end program c_by_val_2
+ 
Index: gcc/testsuite/gfortran.dg/c_by_val_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/c_by_val_3.f90	(revision 0)
--- gcc/testsuite/gfortran.dg/c_by_val_3.f90	(revision 0)
***************
*** 0 ****
--- 1,7 ----
+ ! { dg-do compile }
+ ! { dg-options "-std=f95" }
+ program c_by_val_3
+   external bar
+   real (4) :: bar
+   print *, bar (%VAL(0.0)) ! { dg-error "argument list function" }
+ end program c_by_val_3

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