re PR fortran/23060 (%VAL, %REF and %DESCR constructs not implemented)

2006-12-31  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-31  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.

From-SVN: r120295

gcc/fortran/ChangeLog

+2006-12-31  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-28  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/30034

gcc/fortran/interface.c

@@ -1293,7 +1293,8 @@ compare_actual_formal (gfc_actual_arglist ** ap,
 
   for (a = actual; a; a = a->next, f = f->next)
     {
-      if (a->name != NULL)
+      /* 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++)

gcc/fortran/intrinsic.c

@@ -2864,7 +2864,11 @@ keywords:
 
       if (f == NULL)
 	{
-	  gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
+	  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;
 	}

gcc/fortran/primary.c

@@ -1429,6 +1429,80 @@ cleanup:
 }
 
 
+/* 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 old_locus;
+  match m;
+
+  old_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 = old_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
@@ -1497,13 +1571,21 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
 	}
       else
 	{
-	  /* See if we have the first keyword argument.  */
-	  m = match_keyword_arg (tail, head);
-	  if (m == MATCH_YES)
-	    seen_keyword = 1;
+	  /* 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.  */
@@ -1515,6 +1597,7 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
 	    }
 	}
 
+
     next:
       if (gfc_match_char (')') == MATCH_YES)
 	break;

gcc/fortran/resolve.c

@@ -844,7 +844,7 @@ resolve_assumed_size_actual (gfc_expr *e)
    references.  */
 
 static try
-resolve_actual_arglist (gfc_actual_arglist * arg)
+resolve_actual_arglist (gfc_actual_arglist * arg, procedure_type ptype)
 {
   gfc_symbol *sym;
   gfc_symtree *parent_st;
@@ -852,7 +852,6 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 
   for (; arg; arg = arg->next)
     {
-
       e = arg->expr;
       if (e == NULL)
         {
@@ -873,7 +872,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 	{
 	  if (gfc_resolve_expr (e) != SUCCESS)
 	    return FAILURE;
-	  continue;
+	  goto argument_list;
 	}
 
       /* See if the expression node should really be a variable
@@ -938,7 +937,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 		      && sym->ns->parent->proc_name == sym)))
 	    goto got_variable;
 
-	  continue;
+	  goto argument_list;
 	}
 
       /* See if the name is a module procedure in a parent unit.  */
@@ -962,7 +961,7 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 	  || sym->attr.intrinsic
 	  || sym->attr.external)
 	{
-	  continue;
+	  goto argument_list;
 	}
 
     got_variable:
@@ -976,6 +975,62 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 	  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;
@@ -1451,6 +1506,7 @@ resolve_function (gfc_expr * expr)
   const char *name;
   try t;
   int temp;
+  procedure_type p = PROC_INTRINSIC;
 
   sym = NULL;
   if (expr->symtree)
@@ -1467,8 +1523,11 @@ resolve_function (gfc_expr * expr)
      of procedure, once the procedure itself is resolved.  */
   need_full_assumed_size++;
 
-  if (resolve_actual_arglist (expr->value.function.actual) == FAILURE)
-    return FAILURE;
+  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--;
@@ -1848,6 +1907,7 @@ static try
 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)
@@ -1894,7 +1954,10 @@ resolve_call (gfc_code * c)
      of procedure, once the procedure itself is resolved.  */
   need_full_assumed_size++;
 
-  if (resolve_actual_arglist (c->ext.actual) == FAILURE)
+  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. */

gcc/fortran/trans-expr.c

@@ -1906,6 +1906,57 @@ is_aliased_array (gfc_expr * e)
   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 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_internal_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.  */
@@ -2024,6 +2075,10 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
 		{
 		  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);

gcc/testsuite/ChangeLog

+2006-12-31  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.
+
 2006-12-30  Thomas Koenig  <Thomas.Koenig@online.de>
 
 	PR libfortran/30321

gcc/testsuite/gfortran.dg/c_by_val.c

+/*  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;
+}

gcc/testsuite/gfortran.dg/c_by_val_1.f

+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
+

gcc/testsuite/gfortran.dg/c_by_val_2.f90

+! { 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
+

gcc/testsuite/gfortran.dg/c_by_val_3.f90

+! { 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