From 8d7cdc4d836ea90036693c81a76ed0bd0fd1867b Mon Sep 17 00:00:00 2001 From: pault Date: Sun, 31 Dec 2006 06:55:16 +0000 Subject: [PATCH] 2006-12-31 Paul Thomas 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 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@120295 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 18 ++++++ gcc/fortran/interface.c | 3 +- gcc/fortran/intrinsic.c | 6 +- gcc/fortran/primary.c | 91 +++++++++++++++++++++++++++-- gcc/fortran/resolve.c | 79 ++++++++++++++++++++++--- gcc/fortran/trans-expr.c | 55 +++++++++++++++++ gcc/testsuite/ChangeLog | 8 +++ gcc/testsuite/gfortran.dg/c_by_val.c | 41 +++++++++++++ gcc/testsuite/gfortran.dg/c_by_val_1.f | 31 ++++++++++ gcc/testsuite/gfortran.dg/c_by_val_2.f90 | 29 +++++++++ gcc/testsuite/gfortran.dg/c_by_val_3.f90 | 7 +++ gcc/testsuite/gfortran.dg/char_length_1.f90 | 0 12 files changed, 354 insertions(+), 14 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/c_by_val.c create mode 100644 gcc/testsuite/gfortran.dg/c_by_val_1.f create mode 100644 gcc/testsuite/gfortran.dg/c_by_val_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c_by_val_3.f90 create mode 100644 gcc/testsuite/gfortran.dg/char_length_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f1042bc..7aa22fe 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2006-12-31 Paul Thomas + + 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 PR fortran/30034 diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 67a2064..04618e7 100644 --- a/gcc/fortran/interface.c +++ b/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++) diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 2ed4291..5cdf80d 100644 --- a/gcc/fortran/intrinsic.c +++ b/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; } diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 66ac2f1..f67500c 100644 --- a/gcc/fortran/primary.c +++ b/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; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2c71ae4..1b46a10 100644 --- a/gcc/fortran/resolve.c +++ b/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. */ diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 6d46cd4..e534aff 100644 --- a/gcc/fortran/trans-expr.c +++ b/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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4874ec7..5ba52ba 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2006-12-31 Paul Thomas + + 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 PR libfortran/30321 diff --git a/gcc/testsuite/gfortran.dg/c_by_val.c b/gcc/testsuite/gfortran.dg/c_by_val.c new file mode 100644 index 0000000..daba6d2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_by_val.c @@ -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; +} diff --git a/gcc/testsuite/gfortran.dg/c_by_val_1.f b/gcc/testsuite/gfortran.dg/c_by_val_1.f new file mode 100644 index 0000000..133cc55 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_by_val_1.f @@ -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 + diff --git a/gcc/testsuite/gfortran.dg/c_by_val_2.f90 b/gcc/testsuite/gfortran.dg/c_by_val_2.f90 new file mode 100644 index 0000000..6aadd98 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_by_val_2.f90 @@ -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 + diff --git a/gcc/testsuite/gfortran.dg/c_by_val_3.f90 b/gcc/testsuite/gfortran.dg/c_by_val_3.f90 new file mode 100644 index 0000000..bf7aedf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/c_by_val_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/char_length_1.f90 b/gcc/testsuite/gfortran.dg/char_length_1.f90 new file mode 100644 index 0000000..e69de29 -- 2.7.4