re PR fortran/37425 (Fortran 2003: GENERIC bindings as operators)

2009-08-27  Daniel Kraft  <d@domob.eu>

	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  <d@domob.eu>

	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

1 files changed, 74 insertions, 11 deletions

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index c791797..ec15d3f 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 ();
 }