From 4a44a72d23f7f6e76329ed29f144b7c6eac4feba Mon Sep 17 00:00:00 2001 From: Daniel Kraft Date: Thu, 27 Aug 2009 13:42:56 +0200 Subject: re PR fortran/37425 (Fortran 2003: GENERIC bindings as operators) 2009-08-27 Daniel Kraft PR fortran/37425 * gfortran.h (gfc_expr): Optionally store base-object in compcall value and add a new flag to distinguish assign-calls generated. (gfc_find_typebound_proc): Add locus argument. (gfc_find_typebound_user_op), (gfc_find_typebound_intrinsic_op): Ditto. (gfc_extend_expr): Return if failure was by a real error. * interface.c (matching_typebound_op): New routine. (build_compcall_for_operator): New routine. (gfc_extend_expr): Handle type-bound operators, some clean-up and return if failure was by a real error or just by not finding an appropriate operator definition. (gfc_extend_assign): Handle type-bound assignments. * module.c (MOD_VERSION): Incremented. (mio_intrinsic_op): New routine. (mio_full_typebound_tree): New routine to make typebound-procedures IO code reusable for type-bound user operators. (mio_f2k_derived): IO of type-bound operators. * primary.c (gfc_match_varspec): Initialize new fields in gfc_expr and pass locus to gfc_find_typebound_proc. * resolve.c (resolve_operator): Only output error about no matching interface if gfc_extend_expr did not already fail with an error. (extract_compcall_passed_object): Use specified base-object if present. (update_compcall_arglist): Handle ignore_pass field. (resolve_ordinary_assign): Update to handle extended code for type-bound assignments, too. (resolve_code): Handle EXEC_ASSIGN_CALL statement code. (resolve_tb_generic_targets): Pass locus to gfc_find_typebound_proc. (resolve_typebound_generic), (resolve_typebound_procedure): Ditto. (resolve_typebound_intrinsic_op), (resolve_typebound_user_op): Ditto. (ensure_not_abstract_walker), (resolve_fl_derived): Ditto. (resolve_typebound_procedures): Remove not-implemented error. (resolve_typebound_call): Handle assign-call flag. * symbol.c (find_typebound_proc_uop): New argument to pass locus for error message about PRIVATE, verify that a found procedure is not marked as erraneous. (gfc_find_typebound_intrinsic_op): Ditto. (gfc_find_typebound_proc), (gfc_find_typebound_user_op): New locus arg. 2009-08-27 Daniel Kraft PR fortran/37425 * gfortran.dg/impure_assignment_1.f90: Change expected error message. * gfortran.dg/typebound_operator_1.f03: Remove check for not-implemented error and fix problem with recursive assignment. * gfortran.dg/typebound_operator_2.f03: No not-implemented check. * gfortran.dg/typebound_operator_3.f03: New test. * gfortran.dg/typebound_operator_4.f03: New test. From-SVN: r151140 --- gcc/fortran/module.c | 85 +++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 74 insertions(+), 11 deletions(-) (limited to 'gcc/fortran/module.c') diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index c791797d7dd..ec15d3f8000 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -77,7 +77,7 @@ along with GCC; see the file COPYING3. If not see /* Don't put any single quote (') in MOD_VERSION, if yout want it to be recognized. */ -#define MOD_VERSION "2" +#define MOD_VERSION "3" /* Structure that describes a position within a module file. */ @@ -1461,6 +1461,25 @@ mio_integer (int *ip) } +/* Read or write a gfc_intrinsic_op value. */ + +static void +mio_intrinsic_op (gfc_intrinsic_op* op) +{ + /* FIXME: Would be nicer to do this via the operators symbolic name. */ + if (iomode == IO_OUTPUT) + { + int converted = (int) *op; + write_atom (ATOM_INTEGER, &converted); + } + else + { + require_atom (ATOM_INTEGER); + *op = (gfc_intrinsic_op) atom_int; + } +} + + /* Read or write a character pointer that points to a string on the heap. */ static const char * @@ -3324,6 +3343,7 @@ mio_typebound_proc (gfc_typebound_proc** proc) mio_rparen (); } +/* Walker-callback function for this purpose. */ static void mio_typebound_symtree (gfc_symtree* st) { @@ -3341,6 +3361,33 @@ mio_typebound_symtree (gfc_symtree* st) mio_rparen (); } +/* IO a full symtree (in all depth). */ +static void +mio_full_typebound_tree (gfc_symtree** root) +{ + mio_lparen (); + + if (iomode == IO_OUTPUT) + gfc_traverse_symtree (*root, &mio_typebound_symtree); + else + { + while (peek_atom () == ATOM_LPAREN) + { + gfc_symtree* st; + + mio_lparen (); + + require_atom (ATOM_STRING); + st = gfc_get_tbp_symtree (root, atom_string); + gfc_free (atom_string); + + mio_typebound_symtree (st); + } + } + + mio_rparen (); +} + static void mio_finalizer (gfc_finalizer **f) { @@ -3388,24 +3435,40 @@ mio_f2k_derived (gfc_namespace *f2k) mio_rparen (); /* Handle type-bound procedures. */ + mio_full_typebound_tree (&f2k->tb_sym_root); + + /* Type-bound user operators. */ + mio_full_typebound_tree (&f2k->tb_uop_root); + + /* Type-bound intrinsic operators. */ mio_lparen (); if (iomode == IO_OUTPUT) - gfc_traverse_symtree (f2k->tb_sym_root, &mio_typebound_symtree); - else { - while (peek_atom () == ATOM_LPAREN) + int op; + for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op) { - gfc_symtree* st; - - mio_lparen (); + gfc_intrinsic_op realop; - require_atom (ATOM_STRING); - st = gfc_get_tbp_symtree (&f2k->tb_sym_root, atom_string); - gfc_free (atom_string); + if (op == INTRINSIC_USER || !f2k->tb_op[op]) + continue; - mio_typebound_symtree (st); + mio_lparen (); + realop = (gfc_intrinsic_op) op; + mio_intrinsic_op (&realop); + mio_typebound_proc (&f2k->tb_op[op]); + mio_rparen (); } } + else + while (peek_atom () != ATOM_RPAREN) + { + gfc_intrinsic_op op; + + mio_lparen (); + mio_intrinsic_op (&op); + mio_typebound_proc (&f2k->tb_op[op]); + mio_rparen (); + } mio_rparen (); } -- cgit v1.2.1