This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, fortran] PR23060 - %VAL, %LOC and %REF
- From: Paul Thomas <paulthomas2 at wanadoo dot fr>
- To: Fortran List <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Fri, 29 Dec 2006 18:19:59 +0100
- Subject: [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