This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: Type-bound procedure and procedure pointer component calls
- From: Daniel Kraft <d at domob dot eu>
- To: Fortran List <fortran at gcc dot gnu dot org>, Janus Weil <jaydub66 at googlemail dot com>
- Date: Tue, 26 Aug 2008 12:03:21 +0200
- Subject: Re: Type-bound procedure and procedure pointer component calls
- References: <48B19E34.7050709@domob.eu> <48B3241A.8080506@domob.eu>
Hi again,
here's the promised experimental patch implementing the approach
sketched below. It handles basic calls to NOPASS type-bound procedures
(the typebound_call_1.f03 test included in the patch).
Apart from this, is it of course quite rough; no module IO, no
passed-object handling and nearly no error checking for calls, no
dynamic dispatch (of course)... But I hope you get the idea of how the
general design could be.
Janus, what do you think in respect to PPCs? I think it should be
"rather" easy to extend the current patch to support those:
Extend gfc_match_varspec and the gfc_ref structure to match them and
store their data and then hook either into the resolving methods to
handle your implementation or make the static-resolving conditional and
handle EXEC_COMPCALL/EXPR_COMPCALL in the PPC case during trans somehow.
What do you think?
Daniel
Daniel Kraft wrote:
I've started playing around with calling type-bound procedures, and
here's another, more conservative approach that could do well (maybe the
gfc_callee idea is somewhat "cleaner" but this one will be much easier
to integrate into the existing code):
Add a new ref-type REF_PROC or extend REF_COMPONENT with an attribute to
hold an actual arglist; then in match_varspec, if a component symbol is
found that is in the type-bound procedures namespace, parse an arglist
following it and build such a REF_PROC:
WRITE (*,*) val(1)%tbp_function (42)
will become
EXPR_VARIABLE(val) -> REF_ARRAY(1) -> REF_PROC(arglist(42), gfc_typebound*)
During resolution, we can transform such an expression easily into an
ordinary function call; the passed-object will be given by the
expression itself with the last reference removed, and the other things
needed for the call (the binding-target procedure and the arglist) are
in the REF_PROC.
For CALL's, we could add a new field
gfc_expr* tbp;
to gfc_code. If not NULL it will hold such a reference-expression as
above encapsulating the TBP-call. Once again, during resolution this
will be transformed into an ordinary CALL of a SUBROUTINE.
I think this approach should at least work basically for parsing PPC
calls also if REF_PROC is extended as needed. From resolution onwards
of course PPC's must be handled others than TBP's that can be
transformed into ordinary calls.
What do you think, Janus? And other comments also welcome, of course :)
I'll try to get some basic version of this working and submit a patch
for more details.
Cheers,
Daniel
--
Done: Arc-Bar-Cav-Sam-Val-Wiz, Dwa-Elf-Gno-Hum-Orc, Law-Neu-Cha, Fem-Mal
To go: Hea-Kni-Mon-Pri-Ran-Rog-Tou
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 139571)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -1785,6 +1785,8 @@ gfc_apply_interface_mapping_to_ref (gfc_
gfc_apply_interface_mapping_to_expr (mapping, ref->u.ar.offset);
break;
+ case REF_PROCEDURE:
+ /* XXX: gfc_internal_error instead? */
case REF_COMPONENT:
break;
@@ -2007,6 +2009,10 @@ gfc_apply_interface_mapping_to_expr (gfc
}
break;
+ case EXPR_COMPCALL:
+ for (actual = expr->value.compcall.actual; actual; actual = actual->next)
+ gfc_apply_interface_mapping_to_expr (mapping, actual->expr);
+
case EXPR_ARRAY:
case EXPR_STRUCTURE:
gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c (revision 139571)
+++ gcc/fortran/trans-openmp.c (working copy)
@@ -498,6 +498,7 @@ gfc_trans_omp_array_reduction (tree c, g
e1->symtree = symtree1;
e1->ts = sym->ts;
e1->ref = ref = gfc_get_ref ();
+ ref->type = REF_ARRAY;
ref->u.ar.where = where;
ref->u.ar.as = sym->as;
ref->u.ar.type = AR_FULL;
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 139571)
+++ gcc/fortran/gfortran.h (working copy)
@@ -151,7 +151,7 @@ bt;
/* Expression node types. */
typedef enum
{ EXPR_OP = 1, EXPR_FUNCTION, EXPR_CONSTANT, EXPR_VARIABLE,
- EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL
+ EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL, EXPR_COMPCALL
}
expr_t;
@@ -1306,7 +1306,7 @@ gfc_array_ref;
before the component component. */
typedef enum
- { REF_ARRAY, REF_COMPONENT, REF_SUBSTRING }
+ { REF_ARRAY, REF_COMPONENT, REF_SUBSTRING, REF_PROCEDURE }
ref_type;
typedef struct gfc_ref
@@ -1331,6 +1331,12 @@ typedef struct gfc_ref
}
ss;
+ struct
+ {
+ gfc_symtree* tbp;
+ }
+ p;
+
}
u;
@@ -1451,7 +1457,9 @@ gfc_intrinsic_sym;
EXPR_NULL The NULL pointer value (which also has a basic type).
EXPR_SUBSTRING A substring of a constant string
EXPR_STRUCTURE A structure constructor
- EXPR_ARRAY An array constructor. */
+ EXPR_ARRAY An array constructor.
+ EXPR_COMPCALL Function (or subroutine) call of a procedure pointer
+ component or type-bound procedure. */
#include <gmp.h>
#include <mpfr.h>
@@ -1526,6 +1534,12 @@ typedef struct gfc_expr
struct
{
+ gfc_actual_arglist* actual;
+ }
+ compcall;
+
+ struct
+ {
int length;
gfc_char_t *string;
}
@@ -1770,8 +1784,8 @@ gfc_forall_iterator;
typedef enum
{
EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN,
- EXEC_GOTO, EXEC_CALL, EXEC_ASSIGN_CALL, EXEC_RETURN, EXEC_ENTRY,
- EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
+ EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
+ EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
EXEC_ALLOCATE, EXEC_DEALLOCATE,
@@ -2464,6 +2478,7 @@ bool gfc_check_access (gfc_access, gfc_a
symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
symbol_attribute gfc_expr_attr (gfc_expr *);
match gfc_match_rvalue (gfc_expr **);
+match gfc_match_varspec (gfc_expr*, int);
int gfc_check_digit (char, int);
/* trans.c */
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 139571)
+++ gcc/fortran/expr.c (working copy)
@@ -119,6 +119,7 @@ gfc_free_ref_list (gfc_ref *p)
break;
case REF_COMPONENT:
+ case REF_PROCEDURE:
break;
}
@@ -297,6 +298,10 @@ copy_ref (gfc_ref *src)
dest->u.ss.start = gfc_copy_expr (src->u.ss.start);
dest->u.ss.end = gfc_copy_expr (src->u.ss.end);
break;
+
+ case REF_PROCEDURE:
+ dest->u.p.tbp = src->u.p.tbp;
+ break;
}
dest->next = copy_ref (src->next);
@@ -502,6 +507,11 @@ gfc_copy_expr (gfc_expr *p)
gfc_copy_actual_arglist (p->value.function.actual);
break;
+ case EXPR_COMPCALL:
+ q->value.compcall.actual =
+ gfc_copy_actual_arglist (p->value.compcall.actual);
+ break;
+
case EXPR_STRUCTURE:
case EXPR_ARRAY:
q->value.constructor = gfc_copy_constructor (p->value.constructor);
@@ -1470,6 +1480,10 @@ simplify_const_ref (gfc_expr *p)
gfc_free_ref_list (p->ref);
p->ref = NULL;
break;
+
+ /* XXX. */
+ case REF_PROCEDURE:
+ break;
}
}
@@ -1587,6 +1601,12 @@ gfc_simplify_expr (gfc_expr *p, int type
break;
+ case EXPR_COMPCALL:
+ for (ap = p->value.compcall.actual; ap; ap = ap->next)
+ if (gfc_simplify_expr (ap->expr, type) == FAILURE)
+ return FAILURE;
+ break;
+
case EXPR_SUBSTRING:
if (simplify_ref_chain (p->ref, type) == FAILURE)
return FAILURE;
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 139571)
+++ gcc/fortran/module.c (working copy)
@@ -2554,6 +2554,7 @@ static const mstring ref_types[] = {
minit ("ARRAY", REF_ARRAY),
minit ("COMPONENT", REF_COMPONENT),
minit ("SUBSTRING", REF_SUBSTRING),
+ minit ("PROCEDURE", REF_PROCEDURE),
minit (NULL, -1)
};
@@ -2584,6 +2585,10 @@ mio_ref (gfc_ref **rp)
mio_expr (&r->u.ss.end);
mio_charlen (&r->u.ss.length);
break;
+
+ case REF_PROCEDURE:
+ /* XXX: mio gfc_typebound. */
+ break;
}
mio_rparen ();
@@ -2750,6 +2755,7 @@ static const mstring expr_types[] = {
minit ("STRUCTURE", EXPR_STRUCTURE),
minit ("ARRAY", EXPR_ARRAY),
minit ("NULL", EXPR_NULL),
+ minit ("COMPCALL", EXPR_COMPCALL),
minit (NULL, -1)
};
@@ -2956,6 +2962,11 @@ mio_expr (gfc_expr **ep)
break;
+ case EXPR_COMPCALL:
+ mio_symtree_ref (&e->symtree);
+ mio_actual_arglist (&e->value.compcall.actual);
+ break;
+
case EXPR_VARIABLE:
mio_symtree_ref (&e->symtree);
mio_ref_list (&e->ref);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 139571)
+++ gcc/fortran/resolve.c (working copy)
@@ -3633,6 +3633,7 @@ find_array_spec (gfc_expr *e)
break;
+ case REF_PROCEDURE:
case REF_SUBSTRING:
break;
}
@@ -3858,6 +3859,7 @@ resolve_ref (gfc_expr *expr)
return FAILURE;
break;
+ case REF_PROCEDURE:
case REF_COMPONENT:
break;
@@ -3918,6 +3920,10 @@ resolve_ref (gfc_expr *expr)
case REF_SUBSTRING:
break;
+
+ case REF_PROCEDURE:
+ /* XXX: Check that passed-object is scalar. */
+ break;
}
if (((ref->type == REF_COMPONENT && n_components > 1)
@@ -4281,6 +4287,77 @@ fixup_charlen (gfc_expr *e)
}
+/* Resolve a call to a type-bound procedure, either function or subroutine,
+ statically from the data in an EXPR_COMPCALL expression. The adapted
+ arglist and the target-procedure symtree are returned. */
+
+static gfc_try
+resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
+ gfc_actual_arglist** actual)
+{
+ gfc_ref* r;
+
+ gcc_assert (e->expr_type == EXPR_COMPCALL);
+
+ for (r = e->ref; r && r->type != REF_PROCEDURE; )
+ r = r->next;
+ gcc_assert (r && r->type == REF_PROCEDURE && !r->next);
+
+ /* XXX: Handle PASS. */
+ *actual = e->value.compcall.actual;
+ *target = r->u.p.tbp->typebound->target;
+
+ return SUCCESS;
+}
+
+
+/* Resolve a call to a type-bound subroutine. */
+
+static gfc_try
+resolve_typebound_call (gfc_code* c)
+{
+ gfc_actual_arglist* newactual;
+ gfc_symtree* target;
+
+ /* Transform into an ordinary EXEC_CALL for now. */
+
+ if (resolve_typebound_static (c->expr, &target, &newactual) == FAILURE)
+ return FAILURE;
+
+ c->ext.actual = newactual;
+ c->symtree = target;
+ c->op = EXEC_CALL;
+
+ return resolve_call (c);
+}
+
+
+/* Resolve a component-call expression. */
+
+static gfc_try
+resolve_compcall (gfc_expr* e)
+{
+ gfc_actual_arglist* newactual;
+ gfc_symtree* target;
+
+ /* For now, we simply transform it into a EXPR_FUNCTION call with the same
+ arglist to the TBP's binding target. */
+
+ if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
+ return FAILURE;
+
+ e->value.function.actual = newactual;
+ e->symtree = target;
+
+ /* XXX: Free it. */
+ e->ref = NULL;
+
+ e->expr_type = EXPR_FUNCTION;
+
+ return gfc_resolve_expr (e);
+}
+
+
/* Resolve an expression. That is, make sure that types of operands agree
with their operators, intrinsic operators are converted to function calls
for overloaded types and unresolved function references are resolved. */
@@ -4317,6 +4394,10 @@ gfc_resolve_expr (gfc_expr *e)
break;
+ case EXPR_COMPCALL:
+ t = resolve_compcall (e);
+ break;
+
case EXPR_SUBSTRING:
t = resolve_ref (e);
break;
@@ -4636,6 +4717,10 @@ resolve_deallocate_expr (gfc_expr *e)
case REF_SUBSTRING:
allocatable = 0;
break;
+
+ case REF_PROCEDURE:
+ gfc_internal_error ("resolve_deallocate_expr(): REF_PROCEDURE");
+ break;
}
}
@@ -4785,6 +4870,10 @@ resolve_allocate_expr (gfc_expr *e, gfc_
allocatable = 0;
pointer = 0;
break;
+
+ case REF_PROCEDURE:
+ gfc_internal_error ("resolve_allocate_expr(): REF_PROCEDURE");
+ break;
}
}
}
@@ -6201,7 +6290,9 @@ resolve_code (gfc_code *code, gfc_namesp
omp_workshare_flag = omp_workshare_save;
}
- t = gfc_resolve_expr (code->expr);
+ t = SUCCESS;
+ if (code->op != EXEC_COMPCALL)
+ t = gfc_resolve_expr (code->expr);
forall_flag = forall_save;
if (gfc_resolve_expr (code->expr2) == FAILURE)
@@ -6307,6 +6398,10 @@ resolve_code (gfc_code *code, gfc_namesp
resolve_call (code);
break;
+ case EXEC_COMPCALL:
+ resolve_typebound_call (code);
+ break;
+
case EXEC_SELECT:
/* Select is complicated. Also, a SELECT construct could be
a transformed computed GOTO. */
@@ -7918,15 +8013,6 @@ resolve_typebound_procedure (gfc_symtree
goto error;
}
- /* FIXME: Remove once typebound-procedures are fully implemented. */
- {
- /* Output the error only once so we can do reasonable testing. */
- static bool tbp_error = false;
- if (!tbp_error)
- gfc_error ("Type-bound procedures are not yet implemented at %L", &where);
- tbp_error = true;
- }
-
return;
error:
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (revision 139571)
+++ gcc/fortran/match.c (working copy)
@@ -2509,6 +2509,41 @@ done:
}
+/* Match the call of a type-bound procedure, if CALL%var has already been
+ matched and var found to be a derived-type variable. */
+
+static match
+match_typebound_call (gfc_symtree* varst)
+{
+ gfc_symbol* var;
+ gfc_expr* base;
+ match m;
+
+ var = varst->n.sym;
+
+ base = gfc_get_expr ();
+ base->expr_type = EXPR_VARIABLE;
+ base->symtree = varst;
+
+ m = gfc_match_varspec (base, 0);
+ if (m == MATCH_NO)
+ gfc_error ("Expected component reference at %C");
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (base->expr_type != EXPR_COMPCALL)
+ {
+ gfc_error ("Expected type-bound procedure reference at %C");
+ return MATCH_ERROR;
+ }
+
+ new_st.op = EXEC_COMPCALL;
+ new_st.expr = base;
+
+ return MATCH_YES;
+}
+
+
/* Match a CALL statement. The tricky part here are possible
alternate return specifiers. We handle these by having all
"subroutines" actually return an integer via a register that gives
@@ -2541,6 +2576,11 @@ gfc_match_call (void)
sym = st->n.sym;
+ /* If this is a variable of derived-type, it probably starts a type-bound
+ procedure call. */
+ if (sym->attr.flavor == FL_VARIABLE && sym->ts.type == BT_DERIVED)
+ return match_typebound_call (st);
+
/* If it does not seem to be callable... */
if (!sym->attr.generic
&& !sym->attr.subroutine)
Index: gcc/fortran/dependency.c
===================================================================
--- gcc/fortran/dependency.c (revision 139571)
+++ gcc/fortran/dependency.c (working copy)
@@ -414,6 +414,7 @@ gfc_ref_needs_temporary_p (gfc_ref *ref)
types), not in characters. */
return subarray_p;
+ case REF_PROCEDURE:
case REF_COMPONENT:
break;
}
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c (revision 139571)
+++ gcc/fortran/primary.c (working copy)
@@ -1676,7 +1676,7 @@ cleanup:
}
-/* Used by match_varspec() to extend the reference list by one
+/* Used by gfc_match_varspec() to extend the reference list by one
element. */
static gfc_ref *
@@ -1701,13 +1701,14 @@ extend_ref (gfc_expr *primary, gfc_ref *
set we only match stuff that is allowed inside an EQUIVALENCE
statement. */
-static match
-match_varspec (gfc_expr *primary, int equiv_flag)
+match
+gfc_match_varspec (gfc_expr *primary, int equiv_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_ref *substring, *tail;
gfc_component *component;
gfc_symbol *sym = primary->symtree->n.sym;
+ gfc_symtree *tbp;
match m;
bool unknown;
@@ -1757,6 +1758,30 @@ match_varspec (gfc_expr *primary, int eq
if (m != MATCH_YES)
return MATCH_ERROR;
+ tbp = gfc_find_typebound_proc (sym, name);
+ if (tbp)
+ {
+ gfc_symbol* tbp_sym;
+
+ tail = extend_ref (primary, tail);
+ tail->type = REF_PROCEDURE;
+ tail->u.p.tbp = tbp;
+ gcc_assert (!tail->next);
+
+ /* XXX: Set primary's typespec. */
+ gcc_assert (primary->expr_type == EXPR_VARIABLE);
+ primary->expr_type = EXPR_COMPCALL;
+
+ tbp_sym = tbp->typebound->target->n.sym;
+ m = gfc_match_actual_arglist (tbp_sym->attr.subroutine,
+ &primary->value.compcall.actual);
+ if (m == MATCH_NO)
+ gfc_error ("Expected actual argument list at %C");
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+ break;
+ }
+
component = gfc_find_component (sym, name, false, false);
if (component == NULL)
return MATCH_ERROR;
@@ -1919,6 +1944,10 @@ gfc_variable_attr (gfc_expr *expr, gfc_t
case REF_SUBSTRING:
allocatable = pointer = 0;
break;
+
+ case REF_PROCEDURE:
+ gfc_internal_error ("gfc_variable_attr(): REF_PROCEDURE on variable");
+ break;
}
attr.dimension = dimension;
@@ -2387,7 +2416,7 @@ gfc_match_rvalue (gfc_expr **result)
e->expr_type = EXPR_VARIABLE;
e->symtree = symtree;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0);
break;
case FL_PARAMETER:
@@ -2404,7 +2433,7 @@ gfc_match_rvalue (gfc_expr **result)
}
e->symtree = symtree;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0);
if (sym->ts.is_c_interop || sym->ts.is_iso_c)
break;
@@ -2461,7 +2490,7 @@ gfc_match_rvalue (gfc_expr **result)
e = gfc_get_expr ();
e->expr_type = EXPR_VARIABLE;
e->symtree = symtree;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0);
break;
}
@@ -2488,7 +2517,7 @@ gfc_match_rvalue (gfc_expr **result)
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0);
break;
}
@@ -2584,7 +2613,7 @@ gfc_match_rvalue (gfc_expr **result)
e = gfc_get_expr ();
e->symtree = symtree;
e->expr_type = EXPR_VARIABLE;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0);
break;
}
@@ -2607,9 +2636,9 @@ gfc_match_rvalue (gfc_expr **result)
break;
}
- /*FIXME:??? match_varspec does set this for us: */
+ /*FIXME:??? gfc_match_varspec does set this for us: */
e->ts = sym->ts;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0);
break;
}
@@ -2698,7 +2727,7 @@ gfc_match_rvalue (gfc_expr **result)
/* If our new function returns a character, array or structure
type, it might have subsequent references. */
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0);
if (m == MATCH_NO)
m = MATCH_YES;
@@ -2882,7 +2911,7 @@ match_variable (gfc_expr **result, int e
expr->where = where;
/* Now see if we have to do more. */
- m = match_varspec (expr, equiv_flag);
+ m = gfc_match_varspec (expr, equiv_flag);
if (m != MATCH_YES)
{
gfc_free_expr (expr);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (revision 139571)
+++ gcc/fortran/trans-intrinsic.c (working copy)
@@ -901,7 +901,12 @@ gfc_conv_intrinsic_bound (gfc_se * se, g
case AR_FULL:
break;
}
+ break;
}
+
+ case REF_PROCEDURE:
+ gfc_internal_error ("gfc_conv_intrinsic_bound(): REF_PROCEDURE");
+ break;
}
}
}
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 139571)
+++ gcc/fortran/simplify.c (working copy)
@@ -2289,6 +2289,7 @@ simplify_bound (gfc_expr *array, gfc_exp
as = ref->u.c.component->as;
continue;
+ case REF_PROCEDURE:
case REF_SUBSTRING:
continue;
}
Index: gcc/testsuite/gfortran.dg/typebound_proc_8.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_8.f03 (revision 139571)
+++ gcc/testsuite/gfortran.dg/typebound_proc_8.f03 (working copy)
@@ -35,5 +35,3 @@ CONTAINS
END MODULE testmod
! { dg-final { cleanup-modules "testmod" } }
-! FIXME: Remove not-yet-implemented error when implemented.
-! { dg-excess-errors "not yet implemented" }
Index: gcc/testsuite/gfortran.dg/typebound_call_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_1.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_call_1.f03 (revision 0)
@@ -0,0 +1,80 @@
+! { dg-do run }
+
+! Type-bound procedures
+! Check basic calls to NOPASS type-bound procedures.
+
+MODULE m
+ IMPLICIT NONE
+
+ TYPE add
+ CONTAINS
+ PROCEDURE, NOPASS :: func => func_add
+ PROCEDURE, NOPASS :: sub => sub_add
+ END TYPE add
+
+ TYPE mul
+ CONTAINS
+ PROCEDURE, NOPASS :: func => func_mul
+ PROCEDURE, NOPASS :: sub => sub_mul
+ END TYPE mul
+
+CONTAINS
+
+ INTEGER FUNCTION func_add (a, b)
+ IMPLICIT NONE
+ INTEGER :: a, b
+ func_add = a + b
+ END FUNCTION func_add
+
+ INTEGER FUNCTION func_mul (a, b)
+ IMPLICIT NONE
+ INTEGER :: a, b
+ func_mul = a * b
+ END FUNCTION func_mul
+
+ SUBROUTINE sub_add (a, b, c)
+ IMPLICIT NONE
+ INTEGER, INTENT(IN) :: a, b
+ INTEGER, INTENT(OUT) :: c
+ c = a + b
+ END SUBROUTINE sub_add
+
+ SUBROUTINE sub_mul (a, b, c)
+ IMPLICIT NONE
+ INTEGER, INTENT(IN) :: a, b
+ INTEGER, INTENT(OUT) :: c
+ c = a * b
+ END SUBROUTINE sub_mul
+
+ ! Do the testing here, in the same module as the type is.
+ SUBROUTINE test ()
+ IMPLICIT NONE
+
+ TYPE(add) :: adder
+ TYPE(mul) :: muler
+
+ INTEGER :: x
+
+ IF (adder%func (2, 3) /= 5 .OR. muler%func (2, 3) /= 6) THEN
+ CALL abort ()
+ END IF
+
+ CALL adder%sub (2, 3, x)
+ IF (x /= 5) THEN
+ CALL abort ()
+ END IF
+
+ CALL muler%sub (2, 3, x)
+ IF (x /= 6) THEN
+ CALL abort ()
+ END IF
+ END SUBROUTINE test
+
+END MODULE m
+
+PROGRAM main
+ USE m, ONLY: test
+ CALL test ()
+END PROGRAM main
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/typebound_call_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_2.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_call_2.f03 (revision 0)
@@ -0,0 +1,90 @@
+! { dg-do run }
+
+! Type-bound procedures
+! Check calls with passed-objects.
+
+MODULE m
+ IMPLICIT NONE
+
+ TYPE add
+ INTEGER :: wrong
+ INTEGER :: val
+ CONTAINS
+ PROCEDURE, PASS :: func => func_add
+ PROCEDURE, PASS(me) :: sub => sub_add
+ END TYPE add
+
+ TYPE trueOrFalse
+ LOGICAL :: val
+ CONTAINS
+ PROCEDURE, PASS :: swap
+ END TYPE trueOrFalse
+
+CONTAINS
+
+ INTEGER FUNCTION func_add (me, x)
+ IMPLICIT NONE
+ TYPE(add) :: me
+ INTEGER :: x
+ func_add = me%val + x
+ END FUNCTION func_add
+
+ SUBROUTINE sub_add (res, me, x)
+ IMPLICIT NONE
+ INTEGER, INTENT(OUT) :: res
+ TYPE(add), INTENT(IN) :: me
+ INTEGER, INTENT(IN) :: x
+ res = me%val + x
+ END SUBROUTINE sub_add
+
+ SUBROUTINE swap (me1, me2)
+ IMPLICIT NONE
+ TYPE(trueOrFalse), INTENT(INOUT) :: me1, me2
+
+ IF (.NOT. me1%val .OR. me2%val) THEN
+ CALL abort ()
+ END IF
+
+ me1%val = .FALSE.
+ me2%val = .TRUE.
+ END SUBROUTINE swap
+
+ ! Do the testing here, in the same module as the type is.
+ SUBROUTINE test ()
+ IMPLICIT NONE
+
+ TYPE(add) :: adder
+ TYPE(trueOrFalse) :: t, f
+
+ INTEGER :: x
+
+ adder%wrong = 0
+ adder%val = 42
+ IF (adder%func (8) /= 50) THEN
+ CALL abort ()
+ END IF
+
+ CALL adder%sub (x, 8)
+ IF (x /= 50) THEN
+ CALL abort ()
+ END IF
+
+ t%val = .TRUE.
+ f%val = .FALSE.
+
+ CALL t%swap (f)
+ CALL f%swap (t)
+
+ IF (.NOT. t%val .OR. f%val) THEN
+ CALL abort ()
+ END IF
+ END SUBROUTINE test
+
+END MODULE m
+
+PROGRAM main
+ USE m, ONLY: test
+ CALL test ()
+END PROGRAM main
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/typebound_call_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_3.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_call_3.f03 (revision 0)
@@ -0,0 +1,48 @@
+! { dg-do run }
+
+! Type-bound procedures
+! Check that calls work across module-boundaries.
+
+MODULE m
+ IMPLICIT NONE
+
+ TYPE trueOrFalse
+ LOGICAL :: val
+ CONTAINS
+ PROCEDURE, PASS :: swap
+ END TYPE trueOrFalse
+
+CONTAINS
+
+ SUBROUTINE swap (me1, me2)
+ IMPLICIT NONE
+ TYPE(trueOrFalse), INTENT(INOUT) :: me1, me2
+
+ IF (.NOT. me1%val .OR. me2%val) THEN
+ CALL abort ()
+ END IF
+
+ me1%val = .FALSE.
+ me2%val = .TRUE.
+ END SUBROUTINE swap
+
+END MODULE m
+
+PROGRAM main
+ USE m, ONLY: trueOrFalse
+ IMPLICIT NONE
+
+ TYPE(trueOrFalse) :: t, f
+
+ t%val = .TRUE.
+ f%val = .FALSE.
+
+ CALL t%swap (f)
+ CALL f%swap (t)
+
+ IF (.NOT. t%val .OR. f%val) THEN
+ CALL abort ()
+ END IF
+END PROGRAM main
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/typebound_call_4.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_4.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_call_4.f03 (revision 0)
@@ -0,0 +1,50 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Check for recognition/errors with more complicated references.
+
+MODULE m
+ IMPLICIT NONE
+
+ TYPE t
+ CONTAINS
+ PROCEDURE, PASS :: proc
+ PROCEDURE, NOPASS :: func
+ END TYPE t
+
+ TYPE compt
+ TYPE(t) :: myobj
+ END TYPE compt
+
+CONTAINS
+
+ SUBROUTINE proc (me)
+ IMPLICIT NONE
+ TYPE(t), INTENT(INOUT) :: me
+ END SUBROUTINE proc
+
+ INTEGER FUNCTION func ()
+ IMPLICIT NONE
+ func = 1812
+ END FUNCTION func
+
+ SUBROUTINE test ()
+ IMPLICIT NONE
+ TYPE(compt) :: arr(2)
+
+ ! These two are OK.
+ CALL arr(1)%myobj%proc ()
+ WRITE (*,*) arr(2)%myobj%func ()
+
+ ! Base-object must be scalar.
+ CALL arr(:)%myobj%proc () ! { dg-error "scalar" }
+ WRITE (*,*) arr(:)%myobj%func () ! { dg-error "scalar" }
+
+ ! Can't CALL a function or take the result of a SUBROUTINE.
+ CALL arr(1)%myobj%func () ! { dg-error "SUBROUTINE" }
+ WRITE (*,*) arr(2)%myobj%sub () ! { dg-error "FUNCTION" }
+ END SUBROUTINE test
+
+END MODULE m
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/typebound_proc_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_1.f08 (revision 139571)
+++ gcc/testsuite/gfortran.dg/typebound_proc_1.f08 (working copy)
@@ -22,7 +22,7 @@ MODULE testmod
! Might be empty
CONTAINS
PROCEDURE proc1
- PROCEDURE, PASS(me) :: p2 => proc2 ! { dg-error "not yet implemented" }
+ PROCEDURE, PASS(me) :: p2 => proc2
END TYPE t1
TYPE t2
Index: gcc/testsuite/gfortran.dg/typebound_proc_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_2.f90 (revision 139571)
+++ gcc/testsuite/gfortran.dg/typebound_proc_2.f90 (working copy)
@@ -31,5 +31,4 @@ CONTAINS
END MODULE testmod
! { dg-final { cleanup-modules "testmod" } }
-! FIXME: Remove not-yet-implemented error when implemented.
-! { dg-excess-errors "no IMPLICIT type|not yet implemented" }
+! { dg-excess-errors "no IMPLICIT type" }
Index: gcc/testsuite/gfortran.dg/typebound_proc_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_5.f03 (revision 139571)
+++ gcc/testsuite/gfortran.dg/typebound_proc_5.f03 (working copy)
@@ -117,5 +117,3 @@ CONTAINS
END PROGRAM main
! { dg-final { cleanup-modules "othermod testmod" } }
-! FIXME: Remove not-yet-implemented error when implemented.
-! { dg-excess-errors "not yet implemented" }
Index: gcc/testsuite/gfortran.dg/typebound_proc_6.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_6.f03 (revision 139571)
+++ gcc/testsuite/gfortran.dg/typebound_proc_6.f03 (working copy)
@@ -178,5 +178,3 @@ CONTAINS
END MODULE testmod
! { dg-final { cleanup-modules "testmod" } }
-! FIXME: Remove not-yet-implemented error when implemented.
-! { dg-excess-errors "not yet implemented" }
Index: gcc/testsuite/gfortran.dg/typebound_proc_7.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_7.f03 (revision 139571)
+++ gcc/testsuite/gfortran.dg/typebound_proc_7.f03 (working copy)
@@ -30,5 +30,3 @@ CONTAINS
END MODULE testmod
! { dg-final { cleanup-modules "testmod" } }
-! FIXME: Remove not-yet-implemented error when implemented.
-! { dg-excess-errors "not yet implemented" }