* [Patch, Fortran] Calling type-bound procedures
@ 2008-08-28 10:20 Daniel Kraft
0 siblings, 0 replies; 9+ messages in thread
From: Daniel Kraft @ 2008-08-28 10:20 UTC (permalink / raw)
To: Fortran List, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 1100 bytes --]
Hi,
this is the cleaned-up version of my patch to allow for calling
type-bound procedures posted yesterday including a ChangeLog. I did
remove the REF_PROCEDURE ref-type as it in fact only complicated things
a lot, free'd some leaked memory and changed the test with recursive IO,
thanks Dominique! Otherwise no changes.
No regressions on GNU/Linux-x86_32.
I've left one XXX in where I'd like to hear your opinions as well as one
indentation fix, a "missing" initialization and a missing break from
contexts where I did some other changes as well in prior versions of the
patch; I can take them out if you want of course.
I plan to document the working of type-bound procedures and
EXPR_COMPCALL/EXEC_COMPCALL in gfc-internals.texi after this patch is
checked in and when I have some time to do so.
I think that my code should be more or less easily adaptable to handle
PPC calls as well, but of course I don't really know :)
What do you think about this?
Yours,
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
[-- Attachment #2: patch.changelog --]
[-- Type: text/plain, Size: 2664 bytes --]
2008-08-27 Daniel Kraft <d@domob.eu>
* gfortran.h (enum expr_t): New value `EXPR_COMPCALL'.
(gfc_get_typebound_proc): New macro.
(struct gfc_expr): New union-member `compcall' for EXPR_COMPCALL.
(enum gfc_exec_op): New value `EXEC_COMPCALL'.
(gfc_find_typebound_proc): New argument.
(gfc_copy_ref), (gfc_match_varspec): Made public.
* decl.c (match_procedure_in_type): Use gfc_get_typebound_proc.
* expr.c (free_expr0), (gfc_copy_expr): Handle EXPR_COMPCALL.
(gfc_copy_ref): Made public and use new name.
(simplify_const_ref): Use new name of gfc_copy_ref.
(simplify_parameter_variable): Ditto.
(gfc_simplify_expr): gcc_unreachable for EXPR_COMPCALL.
* match.c (match_typebound_call): New method.
(gfc_match_call): Allow for CALL's to typebound procedures.
* module.c (binding_passing), (binding_overriding): New variables.
(expr_types): Add EXPR_COMPCALL.
(mio_expr): gcc_unreachable for EXPR_COMPCALL.
(mio_typebound_proc), (mio_typebound_symtree): New methods.
(mio_f2k_derived): Handle type-bound procedures.
* primary.c (gfc_match_varspec): Made public and parse trailing
references to type-bound procedures; new argument `sub_flag'.
(gfc_match_rvalue): New name and argument of gfc_match_varspec.
(match_variable): Ditto.
* resolve.c (update_arglist_pass): New method.
(update_compcall_arglist), (resolve_typebound_static): New methods.
(resolve_typebound_call), (resolve_compcall): New methods.
(gfc_resolve_expr): Handle EXPR_COMPCALL.
(resolve_code): Handle EXEC_COMPCALL.
(resolve_fl_derived): New argument to gfc_find_typebound_proc.
(resolve_typebound_procedure): Ditto and removed not-implemented error.
* st.c (gfc_free_statement): Handle EXEC_COMPCALL.
* symbol.c (gfc_find_typebound_proc): New argument `noaccess' and
implement access-checking.
* trans-expr.c (gfc_apply_interface_mapping_to_expr): gcc_unreachable
on EXPR_COMPCALL.
* trans-intrinsic.c (gfc_conv_intrinsic_bound): Add missing break.
* trans-openmp.c (gfc_trans_omp_array_reduction): Add missing
intialization of ref->type.
2008-08-27 Daniel Kraft <d@domob.eu>
* gfortran.dg/typebound_call_1.f03: New test.
* gfortran.dg/typebound_call_2.f03: New test.
* gfortran.dg/typebound_call_3.f03: New test.
* gfortran.dg/typebound_call_4.f03: New test.
* gfortran.dg/typebound_call_5.f03: New test.
* gfortran.dg/typebound_call_6.f03: New test.
* gfortran.dg/typebound_proc_1.f08: Don't expect not-implemented error.
* gfortran.dg/typebound_proc_2.f90: Ditto.
* gfortran.dg/typebound_proc_5.f03: Ditto.
* gfortran.dg/typebound_proc_6.f03: Ditto.
* gfortran.dg/typebound_proc_7.f03: Ditto.
* gfortran.dg/typebound_proc_8.f03: Ditto.
[-- Attachment #3: patch.diff --]
[-- Type: text/plain, Size: 37385 bytes --]
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 139604)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -2011,6 +2011,10 @@ gfc_apply_interface_mapping_to_expr (gfc
case EXPR_STRUCTURE:
gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
break;
+
+ case EXPR_COMPCALL:
+ gcc_unreachable ();
+ break;
}
return;
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 139604)
+++ gcc/fortran/symbol.c (working copy)
@@ -4266,7 +4266,7 @@ gfc_get_derived_super_type (gfc_symbol*
through the super-types). */
gfc_symtree*
-gfc_find_typebound_proc (gfc_symbol* derived, const char* name)
+gfc_find_typebound_proc (gfc_symbol* derived, const char* name, bool noaccess)
{
gfc_symtree* res;
@@ -4274,7 +4274,19 @@ gfc_find_typebound_proc (gfc_symbol* der
gcc_assert (derived->f2k_derived);
res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
if (res)
- return res->typebound ? res : NULL;
+ {
+ if (!res->typebound)
+ return NULL;
+
+ if (!noaccess && derived->attr.use_assoc
+ && res->typebound->access == ACCESS_PRIVATE)
+ gfc_error_now ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
+ /* XXX: Should I replace the gfc_error_now above by a gfc_error? This
+ should be possible by some (not much) effort with returning an
+ optional gfc_try FAILURE here. */
+
+ return res;
+ }
/* Otherwise, recurse on parent type if derived is an extension. */
if (derived->attr.extension)
@@ -4282,7 +4294,7 @@ gfc_find_typebound_proc (gfc_symbol* der
gfc_symbol* super_type;
super_type = gfc_get_derived_super_type (derived);
gcc_assert (super_type);
- return gfc_find_typebound_proc (super_type, name);
+ return gfc_find_typebound_proc (super_type, name, noaccess);
}
/* Nothing found. */
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 139604)
+++ gcc/fortran/decl.c (working copy)
@@ -6888,7 +6888,7 @@ match_procedure_in_type (void)
}
/* Construct the data structure. */
- tb = XCNEW (gfc_typebound_proc);
+ tb = gfc_get_typebound_proc ();
tb->where = gfc_current_locus;
/* Match binding attributes. */
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c (revision 139604)
+++ 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 139604)
+++ 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;
@@ -1003,7 +1003,7 @@ typedef struct
/* Once resolved, we use the position of pass_arg in the formal arglist of
the binding-target procedure to identify it. The first argument has
- number 0 here, the second 1, and so on. */
+ number 1 here, the second 2, and so on. */
unsigned pass_arg_num;
unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise). */
@@ -1011,6 +1011,8 @@ typedef struct
}
gfc_typebound_proc;
+#define gfc_get_typebound_proc() XCNEW (gfc_typebound_proc)
+
/* Symbol nodes. These are important things. They are what the
standard refers to as "entities". The possibly multiple names that
@@ -1447,11 +1449,13 @@ gfc_intrinsic_sym;
EXPR_FUNCTION Function call, symbol points to function's name
EXPR_CONSTANT A scalar constant: Logical, String, Real, Int or Complex
EXPR_VARIABLE An Lvalue with a root symbol and possible reference list
- which expresses structure, array and substring refs.
+ which expresses structure, array and substring refs.
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>
@@ -1466,7 +1470,8 @@ typedef struct gfc_expr
int rank;
mpz_t *shape; /* Can be NULL if shape is unknown at compile time */
- /* Nonnull for functions and structure constructors */
+ /* Nonnull for functions and structure constructors, the base object for
+ component-calls. */
gfc_symtree *symtree;
gfc_ref *ref;
@@ -1526,6 +1531,13 @@ typedef struct gfc_expr
struct
{
+ gfc_actual_arglist* actual;
+ gfc_symtree* tbp;
+ }
+ compcall;
+
+ struct
+ {
int length;
gfc_char_t *string;
}
@@ -1770,8 +1782,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,
@@ -2261,7 +2273,7 @@ gfc_gsymbol *gfc_get_gsymbol (const char
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
-gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, const char*);
+gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, const char*, bool);
void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
@@ -2341,6 +2353,7 @@ gfc_expr *gfc_logical_expr (int, locus *
mpz_t *gfc_copy_shape (mpz_t *, int);
mpz_t *gfc_copy_shape_excluding (mpz_t *, int, gfc_expr *);
gfc_expr *gfc_copy_expr (gfc_expr *);
+gfc_ref* gfc_copy_ref (gfc_ref*);
gfc_try gfc_specification_expr (gfc_expr *);
@@ -2464,6 +2477,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, bool);
int gfc_check_digit (char, int);
/* trans.c */
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 139604)
+++ gcc/fortran/expr.c (working copy)
@@ -181,6 +181,10 @@ free_expr0 (gfc_expr *e)
gfc_free_actual_arglist (e->value.function.actual);
break;
+ case EXPR_COMPCALL:
+ gfc_free_actual_arglist (e->value.compcall.actual);
+ break;
+
case EXPR_VARIABLE:
break;
@@ -268,8 +272,8 @@ gfc_extract_int (gfc_expr *expr, int *re
/* Recursively copy a list of reference structures. */
-static gfc_ref *
-copy_ref (gfc_ref *src)
+gfc_ref *
+gfc_copy_ref (gfc_ref *src)
{
gfc_array_ref *ar;
gfc_ref *dest;
@@ -299,7 +303,7 @@ copy_ref (gfc_ref *src)
break;
}
- dest->next = copy_ref (src->next);
+ dest->next = gfc_copy_ref (src->next);
return dest;
}
@@ -502,6 +506,12 @@ 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);
+ q->value.compcall.tbp = p->value.compcall.tbp;
+ break;
+
case EXPR_STRUCTURE:
case EXPR_ARRAY:
q->value.constructor = gfc_copy_constructor (p->value.constructor);
@@ -514,7 +524,7 @@ gfc_copy_expr (gfc_expr *p)
q->shape = gfc_copy_shape (p->shape, p->rank);
- q->ref = copy_ref (p->ref);
+ q->ref = gfc_copy_ref (p->ref);
return q;
}
@@ -1443,7 +1453,7 @@ simplify_const_ref (gfc_expr *p)
cons = p->value.constructor;
for (; cons; cons = cons->next)
{
- cons->expr->ref = copy_ref (p->ref->next);
+ cons->expr->ref = gfc_copy_ref (p->ref->next);
simplify_const_ref (cons->expr);
}
}
@@ -1531,7 +1541,7 @@ simplify_parameter_variable (gfc_expr *p
/* Do not copy subobject refs for constant. */
if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
- e->ref = copy_ref (p->ref);
+ e->ref = gfc_copy_ref (p->ref);
t = gfc_simplify_expr (e, type);
/* Only use the simplification if it eliminated all subobject references. */
@@ -1670,6 +1680,10 @@ gfc_simplify_expr (gfc_expr *p, int type
return FAILURE;
break;
+
+ case EXPR_COMPCALL:
+ gcc_unreachable ();
+ break;
}
return SUCCESS;
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 139604)
+++ gcc/fortran/module.c (working copy)
@@ -1693,6 +1693,20 @@ static const mstring attr_bits[] =
minit (NULL, -1)
};
+/* For binding attributes. */
+static const mstring binding_passing[] =
+{
+ minit ("PASS", 0),
+ minit ("NOPASS", 1),
+ minit (NULL, -1)
+};
+static const mstring binding_overriding[] =
+{
+ minit ("OVERRIDABLE", 0),
+ minit ("NON_OVERRIDABLE", 1),
+ minit (NULL, -1)
+};
+
/* Specialization of mio_name. */
DECL_MIO_NAME (ab_attribute)
@@ -2750,6 +2764,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)
};
@@ -3013,6 +3028,10 @@ mio_expr (gfc_expr **ep)
case EXPR_NULL:
break;
+
+ case EXPR_COMPCALL:
+ gcc_unreachable ();
+ break;
}
mio_rparen ();
@@ -3169,6 +3188,54 @@ mio_namespace_ref (gfc_namespace **nsp)
/* Save/restore the f2k_derived namespace of a derived-type symbol. */
static void
+mio_typebound_proc (gfc_typebound_proc** proc)
+{
+ int flag;
+
+ if (iomode == IO_INPUT)
+ {
+ *proc = gfc_get_typebound_proc ();
+ (*proc)->where = gfc_current_locus;
+ }
+ gcc_assert (*proc);
+
+ mio_lparen ();
+ mio_symtree_ref (&(*proc)->target);
+
+ (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
+
+ (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
+ (*proc)->non_overridable = mio_name ((*proc)->non_overridable,
+ binding_overriding);
+
+ if (iomode == IO_INPUT)
+ (*proc)->pass_arg = NULL;
+
+ flag = (int) (*proc)->pass_arg_num;
+ mio_integer (&flag);
+ (*proc)->pass_arg_num = (unsigned) flag;
+
+ mio_rparen ();
+}
+
+static void
+mio_typebound_symtree (gfc_symtree* st)
+{
+ if (iomode == IO_OUTPUT && !st->typebound)
+ return;
+
+ if (iomode == IO_OUTPUT)
+ {
+ mio_lparen ();
+ mio_allocated_string (st->name);
+ }
+ /* For IO_INPUT, the above is done in mio_f2k_derived. */
+
+ mio_typebound_proc (&st->typebound);
+ mio_rparen ();
+}
+
+static void
mio_finalizer (gfc_finalizer **f)
{
if (iomode == IO_OUTPUT)
@@ -3211,6 +3278,27 @@ mio_f2k_derived (gfc_namespace *f2k)
}
}
mio_rparen ();
+
+ /* Handle type-bound procedures. */
+ mio_lparen ();
+ if (iomode == IO_OUTPUT)
+ gfc_traverse_symtree (f2k->sym_root, &mio_typebound_symtree);
+ else
+ {
+ while (peek_atom () == ATOM_LPAREN)
+ {
+ gfc_symtree* st;
+
+ mio_lparen ();
+
+ require_atom (ATOM_STRING);
+ gfc_get_sym_tree (atom_string, f2k, &st);
+ gfc_free (atom_string);
+
+ mio_typebound_symtree (st);
+ }
+ }
+ mio_rparen ();
}
static void
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 139604)
+++ gcc/fortran/resolve.c (working copy)
@@ -4281,6 +4281,141 @@ fixup_charlen (gfc_expr *e)
}
+/* Update an actual argument to include the passed-object for type-bound
+ procedures at the right position. */
+
+static gfc_actual_arglist*
+update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
+{
+ if (argpos == 1)
+ {
+ gfc_actual_arglist* result;
+
+ result = gfc_get_actual_arglist ();
+ result->expr = po;
+ result->next = lst;
+
+ return result;
+ }
+
+ gcc_assert (lst);
+ gcc_assert (argpos > 1);
+
+ lst->next = update_arglist_pass (lst->next, po, argpos - 1);
+ return lst;
+}
+
+
+/* Update the arglist of an EXPR_COMPCALL expression to include the
+ passed-object. */
+
+static gfc_try
+update_compcall_arglist (gfc_expr* e)
+{
+ gfc_expr* po;
+ gfc_typebound_proc* tbp;
+
+ tbp = e->value.compcall.tbp->typebound;
+
+ po = gfc_get_expr ();
+ po->expr_type = EXPR_VARIABLE;
+ po->symtree = e->symtree;
+ po->ref = gfc_copy_ref (e->ref);
+
+ if (gfc_resolve_expr (po) == FAILURE)
+ return FAILURE;
+ if (po->rank > 0)
+ {
+ gfc_error ("Passed-object at %L must be scalar", &e->where);
+ return FAILURE;
+ }
+
+ if (tbp->nopass)
+ {
+ gfc_free_expr (po);
+ return SUCCESS;
+ }
+
+ gcc_assert (tbp->pass_arg_num > 0);
+ e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
+ tbp->pass_arg_num);
+
+ return SUCCESS;
+}
+
+
+/* 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)
+{
+ gcc_assert (e->expr_type == EXPR_COMPCALL);
+
+ /* Update the actual arglist for PASS. */
+ if (update_compcall_arglist (e) == FAILURE)
+ return FAILURE;
+
+ *actual = e->value.compcall.actual;
+ *target = e->value.compcall.tbp->typebound->target;
+
+ gfc_free_ref_list (e->ref);
+ e->ref = NULL;
+ e->value.compcall.actual = NULL;
+
+ 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;
+
+ gcc_assert (!c->expr->ref && !c->expr->value.compcall.actual);
+ gfc_free_expr (c->expr);
+ c->expr = NULL;
+
+ 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;
+ 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 +4452,10 @@ gfc_resolve_expr (gfc_expr *e)
break;
+ case EXPR_COMPCALL:
+ t = resolve_compcall (e);
+ break;
+
case EXPR_SUBSTRING:
t = resolve_ref (e);
break;
@@ -4786,7 +4925,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_
pointer = 0;
break;
}
- }
+ }
}
if (allocatable == 0 && pointer == 0)
@@ -6201,7 +6340,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 +6448,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. */
@@ -7842,7 +7987,7 @@ resolve_typebound_procedure (gfc_symtree
and look for it. */
me_arg = NULL;
- stree->typebound->pass_arg_num = 0;
+ stree->typebound->pass_arg_num = 1;
for (i = proc->formal; i; i = i->next)
{
if (!strcmp (i->sym->name, stree->typebound->pass_arg))
@@ -7866,7 +8011,7 @@ resolve_typebound_procedure (gfc_symtree
{
/* Otherwise, take the first one; there should in fact be at least
one. */
- stree->typebound->pass_arg_num = 0;
+ stree->typebound->pass_arg_num = 1;
if (!proc->formal)
{
gfc_error ("Procedure '%s' with PASS at %L must have at"
@@ -7893,7 +8038,7 @@ resolve_typebound_procedure (gfc_symtree
if (super_type)
{
gfc_symtree* overridden;
- overridden = gfc_find_typebound_proc (super_type, stree->name);
+ overridden = gfc_find_typebound_proc (super_type, stree->name, true);
if (overridden && check_typebound_override (stree, overridden) == FAILURE)
goto error;
@@ -7918,15 +8063,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:
@@ -7984,7 +8120,7 @@ resolve_fl_derived (gfc_symbol *sym)
{
/* If this type is an extension, see if this component has the same name
as an inherited type-bound procedure. */
- if (super_type && gfc_find_typebound_proc (super_type, c->name))
+ if (super_type && gfc_find_typebound_proc (super_type, c->name, true))
{
gfc_error ("Component '%s' of '%s' at %L has the same name as an"
" inherited type-bound procedure",
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c (revision 139604)
+++ gcc/fortran/st.c (working copy)
@@ -108,6 +108,8 @@ gfc_free_statement (gfc_code *p)
case EXEC_ARITHMETIC_IF:
break;
+ case EXEC_COMPCALL:
+ gfc_free_expr (p->expr);
case EXEC_CALL:
case EXEC_ASSIGN_CALL:
gfc_free_actual_arglist (p->ext.actual);
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (revision 139604)
+++ gcc/fortran/match.c (working copy)
@@ -2509,6 +2509,48 @@ 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;
+ base->where = gfc_current_locus;
+
+ m = gfc_match_varspec (base, 0, true);
+ if (m == MATCH_NO)
+ gfc_error ("Expected component reference at %C");
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("Junk after CALL at %C");
+ 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 +2583,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_PROCEDURE && 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/primary.c
===================================================================
--- gcc/fortran/primary.c (revision 139604)
+++ 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 *
@@ -1699,15 +1699,17 @@ extend_ref (gfc_expr *primary, gfc_ref *
/* Match any additional specifications associated with the current
variable like member references or substrings. If equiv_flag is
set we only match stuff that is allowed inside an EQUIVALENCE
- statement. */
+ statement. sub_flag tells whether we expect a type-bound procedure found
+ to be a subroutine as part of CALL or a FUNCTION. */
-static match
-match_varspec (gfc_expr *primary, int equiv_flag)
+match
+gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_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 +1759,49 @@ match_varspec (gfc_expr *primary, int eq
if (m != MATCH_YES)
return MATCH_ERROR;
+ tbp = gfc_find_typebound_proc (sym, name, false);
+ if (tbp)
+ {
+ gfc_symbol* tbp_sym;
+
+ gcc_assert (!tail || !tail->next);
+ gcc_assert (primary->expr_type == EXPR_VARIABLE);
+
+ tbp_sym = tbp->typebound->target->n.sym;
+
+ primary->expr_type = EXPR_COMPCALL;
+ primary->value.compcall.tbp = tbp;
+ primary->ts = tbp_sym->ts;
+
+ m = gfc_match_actual_arglist (tbp_sym->attr.subroutine,
+ &primary->value.compcall.actual);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_NO)
+ {
+ if (sub_flag)
+ primary->value.compcall.actual = NULL;
+ else
+ {
+ gfc_error ("Expected argument list at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ if (sub_flag && !tbp_sym->attr.subroutine)
+ {
+ gfc_error ("'%s' at %C should be a SUBROUTINE", name);
+ return MATCH_ERROR;
+ }
+ if (!sub_flag && !tbp_sym->attr.function)
+ {
+ gfc_error ("'%s' at %C should be a FUNCTION", name);
+ return MATCH_ERROR;
+ }
+
+ break;
+ }
+
component = gfc_find_component (sym, name, false, false);
if (component == NULL)
return MATCH_ERROR;
@@ -2387,7 +2432,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, false);
break;
case FL_PARAMETER:
@@ -2404,7 +2449,7 @@ gfc_match_rvalue (gfc_expr **result)
}
e->symtree = symtree;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false);
if (sym->ts.is_c_interop || sym->ts.is_iso_c)
break;
@@ -2461,7 +2506,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, false);
break;
}
@@ -2488,7 +2533,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, false);
break;
}
@@ -2584,7 +2629,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, false);
break;
}
@@ -2607,9 +2652,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, false);
break;
}
@@ -2698,7 +2743,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, false);
if (m == MATCH_NO)
m = MATCH_YES;
@@ -2882,7 +2927,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, false);
if (m != MATCH_YES)
{
gfc_free_expr (expr);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (revision 139604)
+++ gcc/fortran/trans-intrinsic.c (working copy)
@@ -901,6 +901,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, g
case AR_FULL:
break;
}
+ break;
}
}
}
Index: gcc/testsuite/gfortran.dg/typebound_proc_8.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_8.f03 (revision 139604)
+++ 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,98 @@
+! { 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
+ PROCEDURE, NOPASS :: echo => echo_add
+ END TYPE add
+
+ TYPE mul
+ CONTAINS
+ PROCEDURE, NOPASS :: func => func_mul
+ PROCEDURE, NOPASS :: sub => sub_mul
+ PROCEDURE, NOPASS :: echo => echo_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
+
+ SUBROUTINE echo_add ()
+ IMPLICIT NONE
+ WRITE (*,*) "Hi from adder!"
+ END SUBROUTINE echo_add
+
+ INTEGER FUNCTION echo_mul ()
+ IMPLICIT NONE
+ echo_mul = 5
+ WRITE (*,*) "Hi from muler!"
+ END FUNCTION echo_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
+
+ ! Check procedures without arguments.
+ CALL adder%echo ()
+ x = muler%echo ()
+ CALL adder%echo
+ 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,55 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Check for recognition/errors with more complicated references and some
+! error-handling in general.
+
+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%proc () ! { dg-error "FUNCTION" }
+
+ ! Error.
+ CALL arr(2)%myobj%proc () x ! { dg-error "Junk after" }
+ WRITE (*,*) arr(1)%myobj%func ! { dg-error "Expected argument list" }
+ END SUBROUTINE test
+
+END MODULE m
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/typebound_call_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_5.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_call_5.f03 (revision 0)
@@ -0,0 +1,41 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Check for correct access-checking on type-bound procedures.
+
+MODULE m
+ IMPLICIT NONE
+
+ TYPE t
+ CONTAINS
+ PROCEDURE, NOPASS, PRIVATE :: priv => proc
+ PROCEDURE, NOPASS, PUBLIC :: publ => proc
+ END TYPE t
+
+CONTAINS
+
+ SUBROUTINE proc ()
+ END SUBROUTINE proc
+
+ ! This is inside the module.
+ SUBROUTINE test1 ()
+ IMPLICIT NONE
+ TYPE(t) :: obj
+
+ CALL obj%priv () ! { dg-bogus "PRIVATE" }
+ CALL obj%publ ()
+ END SUBROUTINE test1
+
+END MODULE m
+
+! This is outside the module.
+SUBROUTINE test2 ()
+ USE m
+ IMPLICIT NONE
+ TYPE(t) :: obj
+
+ CALL obj%priv () ! { dg-error "PRIVATE" }
+ CALL obj%publ ()
+END SUBROUTINE test2
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/typebound_call_6.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_6.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_call_6.f03 (revision 0)
@@ -0,0 +1,45 @@
+! { dg-do run }
+! { dg-output "Super(\n|\r\n|\r).*Sub" }
+
+! Type-bound procedures
+! Check for calling right overloaded procedure.
+
+MODULE m
+ IMPLICIT NONE
+
+ TYPE supert
+ CONTAINS
+ PROCEDURE, NOPASS :: proc => proc_super
+ END TYPE supert
+
+ TYPE, EXTENDS(supert) :: subt
+ CONTAINS
+ PROCEDURE, NOPASS :: proc => proc_sub
+ END TYPE subt
+
+CONTAINS
+
+ SUBROUTINE proc_super ()
+ IMPLICIT NONE
+ WRITE (*,*) "Super"
+ END SUBROUTINE proc_super
+
+ SUBROUTINE proc_sub ()
+ IMPLICIT NONE
+ WRITE (*,*) "Sub"
+ END SUBROUTINE proc_sub
+
+END MODULE m
+
+PROGRAM main
+ USE m
+ IMPLICIT NONE
+
+ TYPE(supert) :: super
+ TYPE(subt) :: sub
+
+ CALL super%proc
+ CALL sub%proc
+END PROGRAM main
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/typebound_proc_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_1.f08 (revision 139604)
+++ 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 139604)
+++ 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 139604)
+++ 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 139604)
+++ 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 139604)
+++ 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" }
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Calling type-bound procedures
2008-08-29 16:27 ` Tobias Burnus
@ 2008-08-29 19:21 ` Daniel Kraft
0 siblings, 0 replies; 9+ messages in thread
From: Daniel Kraft @ 2008-08-29 19:21 UTC (permalink / raw)
To: Tobias Burnus; +Cc: Fortran List, gcc-patches
Tobias Burnus wrote:
>> Other than this - OK for me.
>>
> Ditto from me. You can commit is (even today), the dump-parse-tree and
> documentation (and maybe GENERIC ;-) can be done later.
Committed as rev. 139724. I'll start working on the documentation stuff
tomorrow, hopefully :) GENERIC or PROCEDURE(interface) will be the next
things to follow that (PROCEDURE(interface) can't be implemented without
abstract types, IIRC? Or did I misunderstand this?)
> Can you update the GFortran#news, Fortran2003 and Fortran2003status wiki
> pages after the check in? (When GCC has entered stage3, I will post a
> patch for the official GCC 4.4 changelog, incorporating all unmentioned
> changes of the GFortran#news wiki page.)
I'll do so now.
Thanks,
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
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Calling type-bound procedures
2008-08-29 7:50 ` Paul Richard Thomas
2008-08-29 9:02 ` Daniel Kraft
@ 2008-08-29 16:27 ` Tobias Burnus
2008-08-29 19:21 ` Daniel Kraft
1 sibling, 1 reply; 9+ messages in thread
From: Tobias Burnus @ 2008-08-29 16:27 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: Daniel Kraft, Tobias Burnus, Fortran List, gcc-patches
Paul,
Paul Richard Thomas wrote:
>> TYPE(mytype) :: dummy_arg
>> one needs
>> CLASS(mytype):: dummy_arg
>>
>> Thinking about it, it makes sense: Unless the procedure is overwritten,
>> the type%inherited_proc() won't work. (I have not checked what happends
>> currently.)
>>
> I suggest that we continue to allow this temporarily and emit a
> warning. That way, all the hooks are there and we can correct it as
> soon as..
>
I agree - I came to a similar conclusion this morning during a meeting.
I was curious what happens if one calls an inherited TBP and the answer
the following error message:
<During initialization>
Error: Type mismatch in argument 'this' at (1); passed TYPE(t2) to TYPE(t)
I think that's OK. I believe the current warning is sufficient. My idea
is to disable the TYPE() support as soon as CLASS is supported, one
probably should state this in the release notes. (Or does anyone feel
like we should support it as vendor extension even after CLASS is
implemented?)
> It is now partially recreated. Give me a few days and I might be able
> to offer something useful that will at least allow this to work.
>
That would be great - hopefully, you will have a submittable patch
before Stage3 - the reviewing can then extend into the early days of Stage3.
> Other than this - OK for me.
>
Ditto from me. You can commit is (even today), the dump-parse-tree and
documentation (and maybe GENERIC ;-) can be done later.
Can you update the GFortran#news, Fortran2003 and Fortran2003status wiki
pages after the check in? (When GCC has entered stage3, I will post a
patch for the official GCC 4.4 changelog, incorporating all unmentioned
changes of the GFortran#news wiki page.)
Tobias
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Calling type-bound procedures
2008-08-29 9:32 ` Paul Richard Thomas
@ 2008-08-29 9:53 ` Daniel Kraft
0 siblings, 0 replies; 9+ messages in thread
From: Daniel Kraft @ 2008-08-29 9:53 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: Fortran List, gcc-patches, Tobias Burnus
Paul Richard Thomas wrote:
> Daniel,
>
>> Ok to commit if no new failures? After that I'll start the documentation
>> work for this pieces.
>
> Yes indeed, unless Tobias has any further thoughts.
No regressions. I'll check in tomorrow morning if there are no
objections and comments to change something until then.
Thanks for the review,
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
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Calling type-bound procedures
2008-08-29 9:02 ` Daniel Kraft
@ 2008-08-29 9:32 ` Paul Richard Thomas
2008-08-29 9:53 ` Daniel Kraft
0 siblings, 1 reply; 9+ messages in thread
From: Paul Richard Thomas @ 2008-08-29 9:32 UTC (permalink / raw)
To: Daniel Kraft; +Cc: Fortran List, gcc-patches
Daniel,
> Ok to commit if no new failures? After that I'll start the documentation
> work for this pieces.
Yes indeed, unless Tobias has any further thoughts.
Many thanks for the patch.
Cheers
Paul
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Calling type-bound procedures
2008-08-29 7:50 ` Paul Richard Thomas
@ 2008-08-29 9:02 ` Daniel Kraft
2008-08-29 9:32 ` Paul Richard Thomas
2008-08-29 16:27 ` Tobias Burnus
1 sibling, 1 reply; 9+ messages in thread
From: Daniel Kraft @ 2008-08-29 9:02 UTC (permalink / raw)
To: Paul Richard Thomas; +Cc: Fortran List, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 3020 bytes --]
Paul Richard Thomas wrote:
> First, please accept my congratulations for a truly magnificent bit of
> work! I know that Daniel has done most of the labour but, in my
> absence, Tobias has done an excellent job with the reviews, testing
> and standard control.
Hi Paul, welcome back!
>>> this is the cleaned-up version of my patch to allow for calling
>>> type-bound procedures posted yesterday including a ChangeLog.
>> As a small thing: I think one should update dump-parse-tree.c; I think
>> everyone tends to forget it and it is almost never used.
>
> Absolutely right! In fact, I use -fdump-parse-tree a lot and it
> certainly needs all sorts of f2k features to be added. One example is
> EXTENDS!
>
> I wonder if we will not need to change the format? I guess that the
> additional features will make the dump seriously incomprehensible:-)
See my other mail, but I want to look into this and try to get it
somewhat usable in a follow-up including documentation to
gfc-internals.texi. Is this ok for you?
BTW, I always found the format already incomprehensible... But I've
used it a few times myself for finalization work.
>> I like your patch. However - thanks to NAG f95 - I just realized that we
>> currently cannot implement PASS in a standard conforming matter. The
>> reason is:
>>
>> C453 The passed-object dummy argument shall be a scalar, nonpointer,
>> nonallocatable dummy data object with the same declared type as
>> the type being defined; all of its length type parameters
>> shall be assumed; it shall be polymorphic (5.1.1.2) if and only
>> if the type being defined is extensible.
>>
>> The problem with PASS for all type-bound procedures and for procedure-
>> pointer components in non-SEQUENCE, non-BIND(C) procedures is the
>> following: The type needs to by polymorphic, i.e. instead of
>>
>> TYPE(mytype) :: dummy_arg
>> one needs
>> CLASS(mytype):: dummy_arg
>>
>> Thinking about it, it makes sense: Unless the procedure is overwritten,
>> the type%inherited_proc() won't work. (I have not checked what happends
>> currently.)
>
> I suggest that we continue to allow this temporarily and emit a
> warning. That way, all the hooks are there and we can correct it as
> soon as......
Done.
>> Somehow type-bound procedures without PASS loose a lot of their
>> usefulness. Except for this point I think the patch is OK.
>
> I agree.
>
> + /* XXX: Should I replace the gfc_error_now above by a gfc_error? This
> + should be possible by some (not much) effort with returning an
> + optional gfc_try FAILURE here. */
>
> I think that is what you should do.
Done.
Attached is a new patch that addresses those two points as above,
otherwise no changes. Regression-testing running on GNU/Linux-x86-32.
Ok to commit if no new failures? After that I'll start the
documentation work for this pieces.
Thanks,
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
[-- Attachment #2: patch.changelog --]
[-- Type: text/plain, Size: 2663 bytes --]
2008-08-28 Daniel Kraft <d@domob.eu>
* gfortran.h (enum expr_t): New value `EXPR_COMPCALL'.
(gfc_get_typebound_proc): New macro.
(struct gfc_expr): New union-member `compcall' for EXPR_COMPCALL.
(enum gfc_exec_op): New value `EXEC_COMPCALL'.
(gfc_find_typebound_proc): New argument.
(gfc_copy_ref), (gfc_match_varspec): Made public.
* decl.c (match_procedure_in_type): Use gfc_get_typebound_proc.
* expr.c (free_expr0), (gfc_copy_expr): Handle EXPR_COMPCALL.
(gfc_copy_ref): Made public and use new name.
(simplify_const_ref): Use new name of gfc_copy_ref.
(simplify_parameter_variable): Ditto.
(gfc_simplify_expr): gcc_unreachable for EXPR_COMPCALL.
* match.c (match_typebound_call): New method.
(gfc_match_call): Allow for CALL's to typebound procedures.
* module.c (binding_passing), (binding_overriding): New variables.
(expr_types): Add EXPR_COMPCALL.
(mio_expr): gcc_unreachable for EXPR_COMPCALL.
(mio_typebound_proc), (mio_typebound_symtree): New methods.
(mio_f2k_derived): Handle type-bound procedures.
* primary.c (gfc_match_varspec): Made public and parse trailing
references to type-bound procedures; new argument `sub_flag'.
(gfc_match_rvalue): New name and argument of gfc_match_varspec.
(match_variable): Ditto.
* resolve.c (update_arglist_pass): New method.
(update_compcall_arglist), (resolve_typebound_static): New methods.
(resolve_typebound_call), (resolve_compcall): New methods.
(gfc_resolve_expr): Handle EXPR_COMPCALL.
(resolve_code): Handle EXEC_COMPCALL.
(resolve_fl_derived): New argument to gfc_find_typebound_proc.
(resolve_typebound_procedure): Ditto and removed not-implemented error.
* st.c (gfc_free_statement): Handle EXEC_COMPCALL.
* symbol.c (gfc_find_typebound_proc): New argument `noaccess' and
implement access-checking.
* trans-expr.c (gfc_apply_interface_mapping_to_expr): gcc_unreachable
on EXPR_COMPCALL.
* trans-intrinsic.c (gfc_conv_intrinsic_bound): Add missing break.
* trans-openmp.c (gfc_trans_omp_array_reduction): Add missing
intialization of ref->type.
2008-08-28 Daniel Kraft <d@domob.eu>
* gfortran.dg/typebound_call_1.f03: New test.
* gfortran.dg/typebound_call_2.f03: New test.
* gfortran.dg/typebound_call_3.f03: New test.
* gfortran.dg/typebound_call_4.f03: New test.
* gfortran.dg/typebound_call_5.f03: New test.
* gfortran.dg/typebound_call_6.f03: New test.
* gfortran.dg/typebound_proc_1.f08: Don't expect not-implemented error.
* gfortran.dg/typebound_proc_2.f90: Ditto.
* gfortran.dg/typebound_proc_5.f03: Ditto.
* gfortran.dg/typebound_proc_6.f03: Ditto.
* gfortran.dg/typebound_proc_7.f03: Ditto.
* gfortran.dg/typebound_proc_8.f03: Ditto.
[-- Attachment #3: patch.diff --]
[-- Type: text/plain, Size: 38996 bytes --]
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 139604)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -2011,6 +2011,10 @@ gfc_apply_interface_mapping_to_expr (gfc
case EXPR_STRUCTURE:
gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
break;
+
+ case EXPR_COMPCALL:
+ gcc_unreachable ();
+ break;
}
return;
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 139604)
+++ gcc/fortran/symbol.c (working copy)
@@ -4266,15 +4266,37 @@ gfc_get_derived_super_type (gfc_symbol*
through the super-types). */
gfc_symtree*
-gfc_find_typebound_proc (gfc_symbol* derived, const char* name)
+gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess)
{
gfc_symtree* res;
+ /* Set default to failure. */
+ if (t)
+ *t = FAILURE;
+
/* Try to find it in the current type's namespace. */
gcc_assert (derived->f2k_derived);
res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
if (res)
- return res->typebound ? res : NULL;
+ {
+ if (!res->typebound)
+ return NULL;
+
+ /* We found one. */
+ if (t)
+ *t = SUCCESS;
+
+ if (!noaccess && derived->attr.use_assoc
+ && res->typebound->access == ACCESS_PRIVATE)
+ {
+ gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
+ if (t)
+ *t = FAILURE;
+ }
+
+ return res;
+ }
/* Otherwise, recurse on parent type if derived is an extension. */
if (derived->attr.extension)
@@ -4282,7 +4304,7 @@ gfc_find_typebound_proc (gfc_symbol* der
gfc_symbol* super_type;
super_type = gfc_get_derived_super_type (derived);
gcc_assert (super_type);
- return gfc_find_typebound_proc (super_type, name);
+ return gfc_find_typebound_proc (super_type, t, name, noaccess);
}
/* Nothing found. */
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 139604)
+++ gcc/fortran/decl.c (working copy)
@@ -6888,7 +6888,7 @@ match_procedure_in_type (void)
}
/* Construct the data structure. */
- tb = XCNEW (gfc_typebound_proc);
+ tb = gfc_get_typebound_proc ();
tb->where = gfc_current_locus;
/* Match binding attributes. */
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c (revision 139604)
+++ 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 139604)
+++ 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;
@@ -1003,7 +1003,7 @@ typedef struct
/* Once resolved, we use the position of pass_arg in the formal arglist of
the binding-target procedure to identify it. The first argument has
- number 0 here, the second 1, and so on. */
+ number 1 here, the second 2, and so on. */
unsigned pass_arg_num;
unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise). */
@@ -1011,6 +1011,8 @@ typedef struct
}
gfc_typebound_proc;
+#define gfc_get_typebound_proc() XCNEW (gfc_typebound_proc)
+
/* Symbol nodes. These are important things. They are what the
standard refers to as "entities". The possibly multiple names that
@@ -1447,11 +1449,13 @@ gfc_intrinsic_sym;
EXPR_FUNCTION Function call, symbol points to function's name
EXPR_CONSTANT A scalar constant: Logical, String, Real, Int or Complex
EXPR_VARIABLE An Lvalue with a root symbol and possible reference list
- which expresses structure, array and substring refs.
+ which expresses structure, array and substring refs.
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>
@@ -1466,7 +1470,8 @@ typedef struct gfc_expr
int rank;
mpz_t *shape; /* Can be NULL if shape is unknown at compile time */
- /* Nonnull for functions and structure constructors */
+ /* Nonnull for functions and structure constructors, the base object for
+ component-calls. */
gfc_symtree *symtree;
gfc_ref *ref;
@@ -1526,6 +1531,13 @@ typedef struct gfc_expr
struct
{
+ gfc_actual_arglist* actual;
+ gfc_symtree* tbp;
+ }
+ compcall;
+
+ struct
+ {
int length;
gfc_char_t *string;
}
@@ -1770,8 +1782,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,
@@ -2261,7 +2273,7 @@ gfc_gsymbol *gfc_get_gsymbol (const char
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
-gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, const char*);
+gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool);
void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
@@ -2341,6 +2353,7 @@ gfc_expr *gfc_logical_expr (int, locus *
mpz_t *gfc_copy_shape (mpz_t *, int);
mpz_t *gfc_copy_shape_excluding (mpz_t *, int, gfc_expr *);
gfc_expr *gfc_copy_expr (gfc_expr *);
+gfc_ref* gfc_copy_ref (gfc_ref*);
gfc_try gfc_specification_expr (gfc_expr *);
@@ -2464,6 +2477,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, bool);
int gfc_check_digit (char, int);
/* trans.c */
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c (revision 139604)
+++ gcc/fortran/expr.c (working copy)
@@ -181,6 +181,10 @@ free_expr0 (gfc_expr *e)
gfc_free_actual_arglist (e->value.function.actual);
break;
+ case EXPR_COMPCALL:
+ gfc_free_actual_arglist (e->value.compcall.actual);
+ break;
+
case EXPR_VARIABLE:
break;
@@ -268,8 +272,8 @@ gfc_extract_int (gfc_expr *expr, int *re
/* Recursively copy a list of reference structures. */
-static gfc_ref *
-copy_ref (gfc_ref *src)
+gfc_ref *
+gfc_copy_ref (gfc_ref *src)
{
gfc_array_ref *ar;
gfc_ref *dest;
@@ -299,7 +303,7 @@ copy_ref (gfc_ref *src)
break;
}
- dest->next = copy_ref (src->next);
+ dest->next = gfc_copy_ref (src->next);
return dest;
}
@@ -502,6 +506,12 @@ 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);
+ q->value.compcall.tbp = p->value.compcall.tbp;
+ break;
+
case EXPR_STRUCTURE:
case EXPR_ARRAY:
q->value.constructor = gfc_copy_constructor (p->value.constructor);
@@ -514,7 +524,7 @@ gfc_copy_expr (gfc_expr *p)
q->shape = gfc_copy_shape (p->shape, p->rank);
- q->ref = copy_ref (p->ref);
+ q->ref = gfc_copy_ref (p->ref);
return q;
}
@@ -1443,7 +1453,7 @@ simplify_const_ref (gfc_expr *p)
cons = p->value.constructor;
for (; cons; cons = cons->next)
{
- cons->expr->ref = copy_ref (p->ref->next);
+ cons->expr->ref = gfc_copy_ref (p->ref->next);
simplify_const_ref (cons->expr);
}
}
@@ -1531,7 +1541,7 @@ simplify_parameter_variable (gfc_expr *p
/* Do not copy subobject refs for constant. */
if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
- e->ref = copy_ref (p->ref);
+ e->ref = gfc_copy_ref (p->ref);
t = gfc_simplify_expr (e, type);
/* Only use the simplification if it eliminated all subobject references. */
@@ -1670,6 +1680,10 @@ gfc_simplify_expr (gfc_expr *p, int type
return FAILURE;
break;
+
+ case EXPR_COMPCALL:
+ gcc_unreachable ();
+ break;
}
return SUCCESS;
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c (revision 139604)
+++ gcc/fortran/module.c (working copy)
@@ -1693,6 +1693,20 @@ static const mstring attr_bits[] =
minit (NULL, -1)
};
+/* For binding attributes. */
+static const mstring binding_passing[] =
+{
+ minit ("PASS", 0),
+ minit ("NOPASS", 1),
+ minit (NULL, -1)
+};
+static const mstring binding_overriding[] =
+{
+ minit ("OVERRIDABLE", 0),
+ minit ("NON_OVERRIDABLE", 1),
+ minit (NULL, -1)
+};
+
/* Specialization of mio_name. */
DECL_MIO_NAME (ab_attribute)
@@ -2750,6 +2764,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)
};
@@ -3013,6 +3028,10 @@ mio_expr (gfc_expr **ep)
case EXPR_NULL:
break;
+
+ case EXPR_COMPCALL:
+ gcc_unreachable ();
+ break;
}
mio_rparen ();
@@ -3169,6 +3188,54 @@ mio_namespace_ref (gfc_namespace **nsp)
/* Save/restore the f2k_derived namespace of a derived-type symbol. */
static void
+mio_typebound_proc (gfc_typebound_proc** proc)
+{
+ int flag;
+
+ if (iomode == IO_INPUT)
+ {
+ *proc = gfc_get_typebound_proc ();
+ (*proc)->where = gfc_current_locus;
+ }
+ gcc_assert (*proc);
+
+ mio_lparen ();
+ mio_symtree_ref (&(*proc)->target);
+
+ (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
+
+ (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
+ (*proc)->non_overridable = mio_name ((*proc)->non_overridable,
+ binding_overriding);
+
+ if (iomode == IO_INPUT)
+ (*proc)->pass_arg = NULL;
+
+ flag = (int) (*proc)->pass_arg_num;
+ mio_integer (&flag);
+ (*proc)->pass_arg_num = (unsigned) flag;
+
+ mio_rparen ();
+}
+
+static void
+mio_typebound_symtree (gfc_symtree* st)
+{
+ if (iomode == IO_OUTPUT && !st->typebound)
+ return;
+
+ if (iomode == IO_OUTPUT)
+ {
+ mio_lparen ();
+ mio_allocated_string (st->name);
+ }
+ /* For IO_INPUT, the above is done in mio_f2k_derived. */
+
+ mio_typebound_proc (&st->typebound);
+ mio_rparen ();
+}
+
+static void
mio_finalizer (gfc_finalizer **f)
{
if (iomode == IO_OUTPUT)
@@ -3211,6 +3278,27 @@ mio_f2k_derived (gfc_namespace *f2k)
}
}
mio_rparen ();
+
+ /* Handle type-bound procedures. */
+ mio_lparen ();
+ if (iomode == IO_OUTPUT)
+ gfc_traverse_symtree (f2k->sym_root, &mio_typebound_symtree);
+ else
+ {
+ while (peek_atom () == ATOM_LPAREN)
+ {
+ gfc_symtree* st;
+
+ mio_lparen ();
+
+ require_atom (ATOM_STRING);
+ gfc_get_sym_tree (atom_string, f2k, &st);
+ gfc_free (atom_string);
+
+ mio_typebound_symtree (st);
+ }
+ }
+ mio_rparen ();
}
static void
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 139604)
+++ gcc/fortran/resolve.c (working copy)
@@ -4281,6 +4281,141 @@ fixup_charlen (gfc_expr *e)
}
+/* Update an actual argument to include the passed-object for type-bound
+ procedures at the right position. */
+
+static gfc_actual_arglist*
+update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
+{
+ if (argpos == 1)
+ {
+ gfc_actual_arglist* result;
+
+ result = gfc_get_actual_arglist ();
+ result->expr = po;
+ result->next = lst;
+
+ return result;
+ }
+
+ gcc_assert (lst);
+ gcc_assert (argpos > 1);
+
+ lst->next = update_arglist_pass (lst->next, po, argpos - 1);
+ return lst;
+}
+
+
+/* Update the arglist of an EXPR_COMPCALL expression to include the
+ passed-object. */
+
+static gfc_try
+update_compcall_arglist (gfc_expr* e)
+{
+ gfc_expr* po;
+ gfc_typebound_proc* tbp;
+
+ tbp = e->value.compcall.tbp->typebound;
+
+ po = gfc_get_expr ();
+ po->expr_type = EXPR_VARIABLE;
+ po->symtree = e->symtree;
+ po->ref = gfc_copy_ref (e->ref);
+
+ if (gfc_resolve_expr (po) == FAILURE)
+ return FAILURE;
+ if (po->rank > 0)
+ {
+ gfc_error ("Passed-object at %L must be scalar", &e->where);
+ return FAILURE;
+ }
+
+ if (tbp->nopass)
+ {
+ gfc_free_expr (po);
+ return SUCCESS;
+ }
+
+ gcc_assert (tbp->pass_arg_num > 0);
+ e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po,
+ tbp->pass_arg_num);
+
+ return SUCCESS;
+}
+
+
+/* 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)
+{
+ gcc_assert (e->expr_type == EXPR_COMPCALL);
+
+ /* Update the actual arglist for PASS. */
+ if (update_compcall_arglist (e) == FAILURE)
+ return FAILURE;
+
+ *actual = e->value.compcall.actual;
+ *target = e->value.compcall.tbp->typebound->target;
+
+ gfc_free_ref_list (e->ref);
+ e->ref = NULL;
+ e->value.compcall.actual = NULL;
+
+ 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;
+
+ gcc_assert (!c->expr->ref && !c->expr->value.compcall.actual);
+ gfc_free_expr (c->expr);
+ c->expr = NULL;
+
+ 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;
+ 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 +4452,10 @@ gfc_resolve_expr (gfc_expr *e)
break;
+ case EXPR_COMPCALL:
+ t = resolve_compcall (e);
+ break;
+
case EXPR_SUBSTRING:
t = resolve_ref (e);
break;
@@ -4786,7 +4925,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_
pointer = 0;
break;
}
- }
+ }
}
if (allocatable == 0 && pointer == 0)
@@ -6201,7 +6340,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 +6448,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. */
@@ -7842,7 +7987,7 @@ resolve_typebound_procedure (gfc_symtree
and look for it. */
me_arg = NULL;
- stree->typebound->pass_arg_num = 0;
+ stree->typebound->pass_arg_num = 1;
for (i = proc->formal; i; i = i->next)
{
if (!strcmp (i->sym->name, stree->typebound->pass_arg))
@@ -7866,7 +8011,7 @@ resolve_typebound_procedure (gfc_symtree
{
/* Otherwise, take the first one; there should in fact be at least
one. */
- stree->typebound->pass_arg_num = 0;
+ stree->typebound->pass_arg_num = 1;
if (!proc->formal)
{
gfc_error ("Procedure '%s' with PASS at %L must have at"
@@ -7886,6 +8031,10 @@ resolve_typebound_procedure (gfc_symtree
me_arg->name, &where, resolve_bindings_derived->name);
goto error;
}
+
+ gfc_warning ("Polymorphic entities are not yet implemented,"
+ " non-polymorphic passed-object dummy argument of '%s'"
+ " at %L accepted", proc->name, &where);
}
/* If we are extending some type, check that we don't override a procedure
@@ -7893,7 +8042,8 @@ resolve_typebound_procedure (gfc_symtree
if (super_type)
{
gfc_symtree* overridden;
- overridden = gfc_find_typebound_proc (super_type, stree->name);
+ overridden = gfc_find_typebound_proc (super_type, NULL,
+ stree->name, true);
if (overridden && check_typebound_override (stree, overridden) == FAILURE)
goto error;
@@ -7918,15 +8068,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:
@@ -7984,7 +8125,8 @@ resolve_fl_derived (gfc_symbol *sym)
{
/* If this type is an extension, see if this component has the same name
as an inherited type-bound procedure. */
- if (super_type && gfc_find_typebound_proc (super_type, c->name))
+ if (super_type
+ && gfc_find_typebound_proc (super_type, NULL, c->name, true))
{
gfc_error ("Component '%s' of '%s' at %L has the same name as an"
" inherited type-bound procedure",
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c (revision 139604)
+++ gcc/fortran/st.c (working copy)
@@ -108,6 +108,8 @@ gfc_free_statement (gfc_code *p)
case EXEC_ARITHMETIC_IF:
break;
+ case EXEC_COMPCALL:
+ gfc_free_expr (p->expr);
case EXEC_CALL:
case EXEC_ASSIGN_CALL:
gfc_free_actual_arglist (p->ext.actual);
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (revision 139604)
+++ gcc/fortran/match.c (working copy)
@@ -2509,6 +2509,48 @@ 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;
+ base->where = gfc_current_locus;
+
+ m = gfc_match_varspec (base, 0, true);
+ if (m == MATCH_NO)
+ gfc_error ("Expected component reference at %C");
+ if (m != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_error ("Junk after CALL at %C");
+ 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 +2583,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_PROCEDURE && 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/primary.c
===================================================================
--- gcc/fortran/primary.c (revision 139604)
+++ 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 *
@@ -1699,15 +1699,17 @@ extend_ref (gfc_expr *primary, gfc_ref *
/* Match any additional specifications associated with the current
variable like member references or substrings. If equiv_flag is
set we only match stuff that is allowed inside an EQUIVALENCE
- statement. */
+ statement. sub_flag tells whether we expect a type-bound procedure found
+ to be a subroutine as part of CALL or a FUNCTION. */
-static match
-match_varspec (gfc_expr *primary, int equiv_flag)
+match
+gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_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;
@@ -1751,12 +1753,60 @@ match_varspec (gfc_expr *primary, int eq
for (;;)
{
+ gfc_try t;
+
m = gfc_match_name (name);
if (m == MATCH_NO)
gfc_error ("Expected structure component name at %C");
if (m != MATCH_YES)
return MATCH_ERROR;
+ tbp = gfc_find_typebound_proc (sym, &t, name, false);
+ if (tbp)
+ {
+ gfc_symbol* tbp_sym;
+
+ if (t == FAILURE)
+ return MATCH_ERROR;
+
+ gcc_assert (!tail || !tail->next);
+ gcc_assert (primary->expr_type == EXPR_VARIABLE);
+
+ tbp_sym = tbp->typebound->target->n.sym;
+
+ primary->expr_type = EXPR_COMPCALL;
+ primary->value.compcall.tbp = tbp;
+ primary->ts = tbp_sym->ts;
+
+ m = gfc_match_actual_arglist (tbp_sym->attr.subroutine,
+ &primary->value.compcall.actual);
+ if (m == MATCH_ERROR)
+ return MATCH_ERROR;
+ if (m == MATCH_NO)
+ {
+ if (sub_flag)
+ primary->value.compcall.actual = NULL;
+ else
+ {
+ gfc_error ("Expected argument list at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ if (sub_flag && !tbp_sym->attr.subroutine)
+ {
+ gfc_error ("'%s' at %C should be a SUBROUTINE", name);
+ return MATCH_ERROR;
+ }
+ if (!sub_flag && !tbp_sym->attr.function)
+ {
+ gfc_error ("'%s' at %C should be a FUNCTION", name);
+ return MATCH_ERROR;
+ }
+
+ break;
+ }
+
component = gfc_find_component (sym, name, false, false);
if (component == NULL)
return MATCH_ERROR;
@@ -2387,7 +2437,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, false);
break;
case FL_PARAMETER:
@@ -2404,7 +2454,7 @@ gfc_match_rvalue (gfc_expr **result)
}
e->symtree = symtree;
- m = match_varspec (e, 0);
+ m = gfc_match_varspec (e, 0, false);
if (sym->ts.is_c_interop || sym->ts.is_iso_c)
break;
@@ -2461,7 +2511,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, false);
break;
}
@@ -2488,7 +2538,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, false);
break;
}
@@ -2584,7 +2634,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, false);
break;
}
@@ -2607,9 +2657,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, false);
break;
}
@@ -2698,7 +2748,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, false);
if (m == MATCH_NO)
m = MATCH_YES;
@@ -2882,7 +2932,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, false);
if (m != MATCH_YES)
{
gfc_free_expr (expr);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (revision 139604)
+++ gcc/fortran/trans-intrinsic.c (working copy)
@@ -901,6 +901,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, g
case AR_FULL:
break;
}
+ break;
}
}
}
Index: gcc/testsuite/gfortran.dg/typebound_proc_8.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_8.f03 (revision 139604)
+++ 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,98 @@
+! { 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
+ PROCEDURE, NOPASS :: echo => echo_add
+ END TYPE add
+
+ TYPE mul
+ CONTAINS
+ PROCEDURE, NOPASS :: func => func_mul
+ PROCEDURE, NOPASS :: sub => sub_mul
+ PROCEDURE, NOPASS :: echo => echo_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
+
+ SUBROUTINE echo_add ()
+ IMPLICIT NONE
+ WRITE (*,*) "Hi from adder!"
+ END SUBROUTINE echo_add
+
+ INTEGER FUNCTION echo_mul ()
+ IMPLICIT NONE
+ echo_mul = 5
+ WRITE (*,*) "Hi from muler!"
+ END FUNCTION echo_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
+
+ ! Check procedures without arguments.
+ CALL adder%echo ()
+ x = muler%echo ()
+ CALL adder%echo
+ 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,93 @@
+! { dg-do run }
+
+! FIXME: Remove -w after polymorphic entities are supported.
+! { dg-options "-w" }
+
+! 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,51 @@
+! { dg-do run }
+
+! FIXME: Remove -w after polymorphic entities are supported.
+! { dg-options "-w" }
+
+! 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,58 @@
+! { dg-do compile }
+
+! FIXME: Remove -w after polymorphic entities are supported.
+! { dg-options "-w" }
+
+! Type-bound procedures
+! Check for recognition/errors with more complicated references and some
+! error-handling in general.
+
+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%proc () ! { dg-error "FUNCTION" }
+
+ ! Error.
+ CALL arr(2)%myobj%proc () x ! { dg-error "Junk after" }
+ WRITE (*,*) arr(1)%myobj%func ! { dg-error "Expected argument list" }
+ END SUBROUTINE test
+
+END MODULE m
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/typebound_call_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_5.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_call_5.f03 (revision 0)
@@ -0,0 +1,41 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Check for correct access-checking on type-bound procedures.
+
+MODULE m
+ IMPLICIT NONE
+
+ TYPE t
+ CONTAINS
+ PROCEDURE, NOPASS, PRIVATE :: priv => proc
+ PROCEDURE, NOPASS, PUBLIC :: publ => proc
+ END TYPE t
+
+CONTAINS
+
+ SUBROUTINE proc ()
+ END SUBROUTINE proc
+
+ ! This is inside the module.
+ SUBROUTINE test1 ()
+ IMPLICIT NONE
+ TYPE(t) :: obj
+
+ CALL obj%priv () ! { dg-bogus "PRIVATE" }
+ CALL obj%publ ()
+ END SUBROUTINE test1
+
+END MODULE m
+
+! This is outside the module.
+SUBROUTINE test2 ()
+ USE m
+ IMPLICIT NONE
+ TYPE(t) :: obj
+
+ CALL obj%priv () ! { dg-error "PRIVATE" }
+ CALL obj%publ ()
+END SUBROUTINE test2
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/typebound_call_6.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_call_6.f03 (revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_call_6.f03 (revision 0)
@@ -0,0 +1,45 @@
+! { dg-do run }
+! { dg-output "Super(\n|\r\n|\r).*Sub" }
+
+! Type-bound procedures
+! Check for calling right overloaded procedure.
+
+MODULE m
+ IMPLICIT NONE
+
+ TYPE supert
+ CONTAINS
+ PROCEDURE, NOPASS :: proc => proc_super
+ END TYPE supert
+
+ TYPE, EXTENDS(supert) :: subt
+ CONTAINS
+ PROCEDURE, NOPASS :: proc => proc_sub
+ END TYPE subt
+
+CONTAINS
+
+ SUBROUTINE proc_super ()
+ IMPLICIT NONE
+ WRITE (*,*) "Super"
+ END SUBROUTINE proc_super
+
+ SUBROUTINE proc_sub ()
+ IMPLICIT NONE
+ WRITE (*,*) "Sub"
+ END SUBROUTINE proc_sub
+
+END MODULE m
+
+PROGRAM main
+ USE m
+ IMPLICIT NONE
+
+ TYPE(supert) :: super
+ TYPE(subt) :: sub
+
+ CALL super%proc
+ CALL sub%proc
+END PROGRAM main
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/typebound_proc_1.f08
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_1.f08 (revision 139604)
+++ gcc/testsuite/gfortran.dg/typebound_proc_1.f08 (working copy)
@@ -1,5 +1,8 @@
! { dg-do compile }
+! FIXME: Remove -w after polymorphic entities are supported.
+! { dg-options "-w" }
+
! Type-bound procedures
! Test that the basic syntax for specific bindings is parsed and resolved.
@@ -22,7 +25,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 139604)
+++ 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 139604)
+++ gcc/testsuite/gfortran.dg/typebound_proc_5.f03 (working copy)
@@ -1,5 +1,8 @@
! { dg-do compile }
+! FIXME: Remove -w after polymorphic entities are supported.
+! { dg-options "-w" }
+
! Type-bound procedures
! Test for errors in specific bindings, during resolution.
@@ -117,5 +120,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 139604)
+++ gcc/testsuite/gfortran.dg/typebound_proc_6.f03 (working copy)
@@ -1,5 +1,8 @@
! { dg-do compile }
+! FIXME: Remove -w after polymorphic entities are supported.
+! { dg-options "-w" }
+
! Type-bound procedures
! Test for the check if overriding methods "match" the overridden ones by their
! characteristics.
@@ -178,5 +181,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 139604)
+++ 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" }
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Calling type-bound procedures
2008-08-28 21:32 Tobias Burnus
2008-08-29 6:10 ` Daniel Kraft
@ 2008-08-29 7:50 ` Paul Richard Thomas
2008-08-29 9:02 ` Daniel Kraft
2008-08-29 16:27 ` Tobias Burnus
1 sibling, 2 replies; 9+ messages in thread
From: Paul Richard Thomas @ 2008-08-29 7:50 UTC (permalink / raw)
To: Daniel Kraft, Tobias Burnus; +Cc: Fortran List, gcc-patches
Daniel and Tobias,
First, please accept my congratulations for a truly magnificent bit of
work! I know that Daniel has done most of the labour but, in my
absence, Tobias has done an excellent job with the reviews, testing
and standard control.
Secondly, my apologies for not coming back to you last Sunday, as
promised. The removal ate into the whole day and there was no time
left for gfortran. Anyway, I am in place now and back at work. I
will build up to the normal level of contributions over the next few
weeks.
On Wed, Aug 27, 2008 at 11:16 PM, Tobias Burnus
<tobias.burnus@physik.fu-berlin.de> wrote:
> Hi Daniel,
>
>> this is the cleaned-up version of my patch to allow for calling
>> type-bound procedures posted yesterday including a ChangeLog.
>
> As a small thing: I think one should update dump-parse-tree.c; I think
> everyone tends to forget it and it is almost never used.
Absolutely right! In fact, I use -fdump-parse-tree a lot and it
certainly needs all sorts of f2k features to be added. One example is
EXTENDS!
I wonder if we will not need to change the format? I guess that the
additional features will make the dump seriously incomprehensible:-)
>
> * * *
>
> I like your patch. However - thanks to NAG f95 - I just realized that we
> currently cannot implement PASS in a standard conforming matter. The
> reason is:
>
> C453 The passed-object dummy argument shall be a scalar, nonpointer,
> nonallocatable dummy data object with the same declared type as
> the type being defined; all of its length type parameters
> shall be assumed; it shall be polymorphic (5.1.1.2) if and only
> if the type being defined is extensible.
>
> The problem with PASS for all type-bound procedures and for procedure-
> pointer components in non-SEQUENCE, non-BIND(C) procedures is the
> following: The type needs to by polymorphic, i.e. instead of
>
> TYPE(mytype) :: dummy_arg
> one needs
> CLASS(mytype):: dummy_arg
>
> Thinking about it, it makes sense: Unless the procedure is overwritten,
> the type%inherited_proc() won't work. (I have not checked what happends
> currently.)
I suggest that we continue to allow this temporarily and emit a
warning. That way, all the hooks are there and we can correct it as
soon as......
>
> The big question is now how to handle this? For proc pointer comps with
> SEQUENCE and BIND(C) [assuming PASS is allowed for them, I have not
> checked] the current machinary can be used, but for an ordinary,
> extensible type? Shall we abort in this case with "Sorry, not
> implemented"? Too bad that Paul has not managed to recreate his CLASS
> patch :-(
It is now partially recreated. Give me a few days and I might be able
to offer something useful that will at least allow this to work.
>
> Somehow type-bound procedures without PASS loose a lot of their
> usefulness. Except for this point I think the patch is OK.
I agree.
+ /* XXX: Should I replace the gfc_error_now above by a gfc_error? This
+ should be possible by some (not much) effort with returning an
+ optional gfc_try FAILURE here. */
I think that is what you should do.
Other than this - OK for me.
Paul
--
The knack of flying is learning how to throw yourself at the ground and miss.
--Hitchhikers Guide to the Galaxy
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Calling type-bound procedures
2008-08-28 21:32 Tobias Burnus
@ 2008-08-29 6:10 ` Daniel Kraft
2008-08-29 7:50 ` Paul Richard Thomas
1 sibling, 0 replies; 9+ messages in thread
From: Daniel Kraft @ 2008-08-29 6:10 UTC (permalink / raw)
To: Tobias Burnus; +Cc: Fortran List, gcc-patches
Tobias Burnus wrote:
> Hi Daniel,
>
>> this is the cleaned-up version of my patch to allow for calling
>> type-bound procedures posted yesterday including a ChangeLog.
>
> As a small thing: I think one should update dump-parse-tree.c; I think
> everyone tends to forget it and it is almost never used.
I thought about this but if that's ok will include this in the
documentation-fix following up.
> I like your patch. However - thanks to NAG f95 - I just realized that we
> currently cannot implement PASS in a standard conforming matter. The
> reason is:
>
> C453 The passed-object dummy argument shall be a scalar, nonpointer,
> nonallocatable dummy data object with the same declared type as
> the type being defined; all of its length type parameters
> shall be assumed; it shall be polymorphic (5.1.1.2) if and only
> if the type being defined is extensible.
>
> The problem with PASS for all type-bound procedures and for procedure-
> pointer components in non-SEQUENCE, non-BIND(C) procedures is the
> following: The type needs to by polymorphic, i.e. instead of
>
> TYPE(mytype) :: dummy_arg
> one needs
> CLASS(mytype):: dummy_arg
>
> Thinking about it, it makes sense: Unless the procedure is overwritten,
> the type%inherited_proc() won't work. (I have not checked what happends
> currently.)
That's what I stumbled across and mentioned on IRC, too, after testing
with NAG :)
> The big question is now how to handle this? For proc pointer comps with
> SEQUENCE and BIND(C) [assuming PASS is allowed for them, I have not
> checked] the current machinary can be used, but for an ordinary,
> extensible type? Shall we abort in this case with "Sorry, not
> implemented"? Too bad that Paul has not managed to recreate his CLASS
> patch :-(
>
> Somehow type-bound procedures without PASS loose a lot of their
> usefulness. Except for this point I think the patch is OK.
From my point of view, the best solution would be to let it as it is
now and emit maybe a warning for type-bound procedures with PASS about
this problem; to fix it once polymorphic entities are available will of
course be easy, just change the check during resolution time for the
passed-object dummy argument. Or maybe do a GNU Fortran extension until
then, possibly together with the warning so people know their code will
break when this is fixed.
Alternatively, I think we could print not-implemented for each PASS and
leave the patch otherwise as it is to allow for this change easily at a
later point.
What's your opinion on this?
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
^ permalink raw reply [flat|nested] 9+ messages in thread
* Re: [Patch, Fortran] Calling type-bound procedures
@ 2008-08-28 21:32 Tobias Burnus
2008-08-29 6:10 ` Daniel Kraft
2008-08-29 7:50 ` Paul Richard Thomas
0 siblings, 2 replies; 9+ messages in thread
From: Tobias Burnus @ 2008-08-28 21:32 UTC (permalink / raw)
To: Daniel Kraft, Fortran List, gcc-patches
Hi Daniel,
> this is the cleaned-up version of my patch to allow for calling
> type-bound procedures posted yesterday including a ChangeLog.
As a small thing: I think one should update dump-parse-tree.c; I think
everyone tends to forget it and it is almost never used.
* * *
I like your patch. However - thanks to NAG f95 - I just realized that we
currently cannot implement PASS in a standard conforming matter. The
reason is:
C453 The passed-object dummy argument shall be a scalar, nonpointer,
nonallocatable dummy data object with the same declared type as
the type being defined; all of its length type parameters
shall be assumed; it shall be polymorphic (5.1.1.2) if and only
if the type being defined is extensible.
The problem with PASS for all type-bound procedures and for procedure-
pointer components in non-SEQUENCE, non-BIND(C) procedures is the
following: The type needs to by polymorphic, i.e. instead of
TYPE(mytype) :: dummy_arg
one needs
CLASS(mytype):: dummy_arg
Thinking about it, it makes sense: Unless the procedure is overwritten,
the type%inherited_proc() won't work. (I have not checked what happends
currently.)
The big question is now how to handle this? For proc pointer comps with
SEQUENCE and BIND(C) [assuming PASS is allowed for them, I have not
checked] the current machinary can be used, but for an ordinary,
extensible type? Shall we abort in this case with "Sorry, not
implemented"? Too bad that Paul has not managed to recreate his CLASS
patch :-(
Somehow type-bound procedures without PASS loose a lot of their
usefulness. Except for this point I think the patch is OK.
Tobias
^ permalink raw reply [flat|nested] 9+ messages in thread
end of thread, other threads:[~2008-08-28 18:06 UTC | newest]
Thread overview: 9+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2008-08-28 10:20 [Patch, Fortran] Calling type-bound procedures Daniel Kraft
2008-08-28 21:32 Tobias Burnus
2008-08-29 6:10 ` Daniel Kraft
2008-08-29 7:50 ` Paul Richard Thomas
2008-08-29 9:02 ` Daniel Kraft
2008-08-29 9:32 ` Paul Richard Thomas
2008-08-29 9:53 ` Daniel Kraft
2008-08-29 16:27 ` Tobias Burnus
2008-08-29 19:21 ` Daniel Kraft
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).