This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Finalization revived


Hi all,

for coming up gfortran 4.5, I would like to get finalization finally in; attached is again my patch I submitted some time ago as "second part split off" updated to current trunk. This is the part that handles creation of finalization code and should already be fairly ready.

The issues of temporaries and such are not covered here as they are part of the "third" part to actually call this code herein; I think we could try to get this patch in as soon as possible and then work out the missing pieces for the temporaries and such. What do you think?

If that would be ok, I'd like to get review for this patch whenever someone has some time to spare :) It would be cool if we could start off with this fairly early in coming up stage 1.

Apart from finalization, my plans for 4.5 are continuation with OOP (DEFERRED bindings, type-bound OPERATORs and CLASS, that is), and maybe some help with the array-descriptor reshape and/or co-arrays, where ever I can help... And finally, I would still regard some experimental work on mfpr-powered aribtrary precision floating-point KINDs interesting :P

Any plans for a IRC meeting? How do you guys have time? Would 21:00/22:00 CET (20:00/21:00 UTC) be ok as last time?

Cheers,
Daniel

PS: I've not yet tried to compile the latest updated patch, but it "should" work; will try soon...

--
Done:  Arc-Bar-Cav-Rog-Sam-Val-Wiz
To go: Hea-Kni-Mon-Pri-Ran-Tou
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 141948)
+++ gcc/fortran/symbol.c	(working copy)
@@ -2305,6 +2305,26 @@ gfc_get_unique_symtree (gfc_namespace *n
 }
 
 
+/* Generate a local variable for use as temporary.  */
+
+gfc_symbol*
+gfc_get_temporary_variable (gfc_namespace* ns)
+{
+  static int id = 0;
+  char name[16]; /* "__tmpvar_XXXXXX\0" => 16 characters.  */
+  gfc_symbol* var;
+
+  /* XXX: Is this done correctly?  Need to set any more members?  */
+  /* XXX: Maybe use gfc_get_unique_symtree?  */
+  snprintf(name, sizeof (name), "__tmpvar_%d", id++);
+  gfc_get_symbol (name, ns, &var);
+  gfc_commit_symbols ();
+  gfc_set_sym_referenced (var);
+
+  return var;
+}
+
+
 /* Given a name find a user operator node, creating it if it doesn't
    exist.  These are much simpler than symbols because they can't be
    ambiguous with one another.  */
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 141948)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2312,6 +2312,7 @@ gfc_symtree *gfc_new_symtree (gfc_symtre
 gfc_symtree *gfc_find_symtree (gfc_symtree *, const char *);
 void gfc_delete_symtree (gfc_symtree **, const char *);
 gfc_symtree *gfc_get_unique_symtree (gfc_namespace *);
+gfc_symbol *gfc_get_temporary_variable (gfc_namespace *);
 gfc_user_op *gfc_get_uop (const char *);
 gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
 void gfc_free_symbol (gfc_symbol *);
@@ -2451,6 +2452,9 @@ bool gfc_traverse_expr (gfc_expr *, gfc_
 			bool (*)(gfc_expr *, gfc_symbol *, int*),
 			int);
 void gfc_expr_set_symbols_referenced (gfc_expr *);
+bool gfc_is_type_finalizable (const gfc_typespec*, bool);
+bool gfc_finalize_expr (gfc_expr*, bool, gfc_code*, locus);
+
 gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
 void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *);
 
@@ -2477,6 +2481,8 @@ gfc_try gfc_resolve_dim_arg (gfc_expr *)
 int gfc_is_formal_arg (void);
 void gfc_resolve_substring_charlen (gfc_expr *);
 match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
+void gfc_resolve_code (gfc_code *, gfc_namespace *);
+gfc_try gfc_resolve_call (gfc_code *);
 
 
 /* array.c */
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 141948)
+++ gcc/fortran/expr.c	(working copy)
@@ -3442,6 +3442,624 @@ gfc_expr_set_symbols_referenced (gfc_exp
 }
 
 
+/* Check if a given type is finalizable or if it has finalizable components.
+   ALLOCATABLE components are always "finalizable" in this context as they ought
+   to be auto-deallocated.  */
+
+bool
+gfc_is_type_finalizable (const gfc_typespec* ts, bool comp_only)
+{
+  gfc_component* comp;
+
+  /* Only derived types are finalizable.  */
+  if (ts->type != BT_DERIVED)
+    return false;
+
+  /* See if we have finalizable components.  */
+  for (comp = ts->derived->components; comp; comp = comp->next)
+    if (comp->attr.allocatable || (!comp->attr.pointer 
+			      && gfc_is_type_finalizable (&comp->ts, false)))
+      return true;
+
+  /* If components only is requested, return here.  */
+  if (comp_only)
+    return false;
+
+  /* Now the type is finalizable if and only if it has finalizer procedures.  */
+  return ts->derived->f2k_derived && ts->derived->f2k_derived->finalizers;
+}
+
+
+/* Helper function to generate a gfc_expr from another one and adding one more
+   reference to the ref-chain.  This reference itself is not filled, only a
+   pointer to it returned and the caller must ensure it is initialized
+   properly.  */
+/* XXX:  Make this a global, general purpose function?  */
+
+static gfc_expr*
+generate_reference_expr (gfc_expr* expr, gfc_ref** reftail, ref_type type)
+{
+  gfc_expr* ref_expr = gfc_copy_expr (expr);
+
+  /* Find the tail of the references-list.  */
+  if (!ref_expr->ref)
+    {
+      ref_expr->ref = *reftail = gfc_get_ref ();
+      (*reftail)->next = NULL;
+    }
+  else
+    {
+      for (*reftail = ref_expr->ref; (*reftail)->next;
+	   *reftail = (*reftail)->next)
+	{
+	  /* If we're looking for an array reference and have found one, return
+	     here.  */
+	  if (type == REF_ARRAY && (*reftail)->type == REF_ARRAY
+	      && (*reftail)->u.ar.type != AR_ELEMENT)
+	    break;
+	}
+
+      /* At most one array reference is allowed per reference chain, so if we
+	 already have one at the end, we can't just append a new one but have
+	 to adapt the existing one.  Otherwise, create a new node in the list
+	 of references.  */
+      if (type != REF_ARRAY || (*reftail)->type != REF_ARRAY)
+      {
+	(*reftail)->next = gfc_get_ref ();
+	*reftail = (*reftail)->next;
+	(*reftail)->next = NULL;
+
+	/* If we generated a new array reference, initialize type so we know
+	   it is new.  */
+	if (type == REF_ARRAY)
+	  (*reftail)->u.ar.type = AR_UNKNOWN;
+      }
+    }
+
+  /* Initialize with what is already known about the reference.  */
+  (*reftail)->type = type;
+
+  return ref_expr;
+}
+
+
+/* Helper-function to build an intrinsic-call expression given some arguments.
+   This is used in finalization both for the ALLOCATED and SIZE intrinsics.  */
+/* XXX: Is this already somewhere implemented?  Make it general-purpose method?
+   Something else?  */
+static gfc_expr* build_intrinsic_call (const char* name, ...)
+{
+  gfc_expr* result;
+  gfc_actual_arglist** args_out;
+  va_list args_in;
+
+  /* Build the basic function expression.  */
+  result = gfc_get_expr ();
+  result->expr_type = EXPR_FUNCTION;
+  result->ts.type = BT_UNKNOWN;
+  gfc_get_sym_tree (name, NULL, &result->symtree);
+  gfc_commit_symbols (); /* XXX: Need this here?  */
+  gfc_set_sym_referenced (result->symtree->n.sym);
+  result->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+  result->value.function.isym = gfc_find_function (name);
+  result->value.function.esym = NULL;
+
+  /* Walk the arguments and build the list of actual args.  */
+  va_start (args_in, name);
+  result->value.function.actual = NULL;
+  for (args_out = &result->value.function.actual; ;
+       args_out = &(*args_out)->next)
+    {
+      gfc_expr* cur_arg;
+
+      cur_arg = va_arg (args_in, gfc_expr*);
+      if (!cur_arg)
+      break;
+
+      gcc_assert (*args_out == NULL);
+      *args_out = gfc_get_actual_arglist ();
+      (*args_out)->expr = gfc_copy_expr (cur_arg);
+      (*args_out)->next = NULL;
+    }
+  gcc_assert (*args_out == NULL);
+  va_end (args_in);
+
+  return result;
+}
+
+
+/* Build DO-loops to scalarize the finalization of components of
+   arrays of derived types.  This function is used as a helper-function within
+   finalize_derived_components.  */
+
+/* XXX: Can/should we somehow re-use existing scalarization logic for this
+   one?  I don't really see a possibility, though.  */
+
+static bool finalize_derived_components (gfc_expr*, gfc_code*);
+
+static bool
+scalarize_derived_component_finalization (gfc_expr* expr, gfc_code* code,
+					  gfc_array_spec* as)
+{
+  gfc_code* code_head;
+  gfc_code* code_tail;
+  gfc_code* loop;
+  gfc_expr* aref_expr;
+  gfc_expr* orig_expr;
+  gfc_expr* vector_subscripts[GFC_MAX_DIMENSIONS];
+  gfc_ref* aref;
+  int dim;
+  int rank;
+  bool generated;
+
+  /* XXX: Do we need special care for as->type == AS_UNKNOWN or AS_ASSUMED_SIZE
+     or do we always know the rank and can call UBOUND/LBOUND to get the
+     boundaries?  */
+
+  /* Copy the expression and generate an array-reference as tail.  */
+  aref_expr = generate_reference_expr (expr, &aref, REF_ARRAY);
+  gcc_assert (aref->type == REF_ARRAY);
+
+  /* An already existing node should not be AR_ELEMENT as that would not need to
+     be finalized.  */
+  gcc_assert (aref->u.ar.type != AR_ELEMENT);
+
+  /* If we are adapting an existing AR_SECTION reference, get the original
+     expression without even that one so we can call LBOUND/UBOUND on it to get
+     the real boundaries.  Otherwise we can simply use the expression given as
+     argument for this purpose.  */
+  if (aref->u.ar.type == AR_SECTION)
+    {
+      gfc_ref* r;
+
+      orig_expr = gfc_copy_expr (expr);
+      gcc_assert (orig_expr->ref);
+      for (r = orig_expr->ref; r; r = r->next)
+	if (r->type == REF_ARRAY && r->u.ar.type == AR_SECTION)
+	  {
+	    for (dim = 0; dim != r->u.ar.dimen; ++dim)
+	    {
+	      gfc_free_expr (r->u.ar.start[dim]);
+	      gfc_free_expr (r->u.ar.end[dim]);
+	      gfc_free_expr (r->u.ar.stride[dim]);
+	      r->u.ar.start[dim] = NULL;
+	      r->u.ar.end[dim] = NULL;
+	      r->u.ar.stride[dim] = NULL;
+	    }
+	    r->u.ar.type = AR_FULL;
+	  }
+
+      orig_expr->shape = NULL;
+      gfc_resolve_expr (orig_expr);
+    }
+  else
+    orig_expr = expr;
+  rank = orig_expr->rank;
+
+  /* Build the introduction code.  If we adapt an existing AR_SECTION reference
+     that contains vector subscripts, create temporary variables holding the
+     subscript-vectors and initialize them here; otherwise create a NOP.  The
+     temporary variables are stored in the vector_subscripts array.  Only those
+     values used later will be initialized.  */
+  code_head = code_tail = gfc_get_code ();
+  code_head->op = EXEC_NOP;
+  code_head->next = NULL;
+  if (aref->u.ar.type == AR_SECTION)
+    for (dim = 0; dim != rank; ++dim)
+      if (aref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+      {
+	gfc_symbol* vector_temp;
+	gfc_expr* vect;
+	gfc_expr* arr_length;
+
+	vect = aref->u.ar.start[dim];
+
+	gcc_assert (vect->expr_type == EXPR_ARRAY);
+	gcc_assert (gfc_is_constant_expr (vect));
+	gcc_assert (vect->rank == 1);
+	gcc_assert (vect->shape);
+
+	/* Find the length of the subscript vector.  */
+	arr_length = gfc_int_expr (mpz_get_si (vect->shape[0]));
+	
+	/* Build integer array variable.  */
+	vector_temp = gfc_get_temporary_variable (gfc_current_ns);
+	vector_temp->ts.type = BT_INTEGER;
+	vector_temp->ts.kind = gfc_default_integer_kind;
+	vector_temp->attr.dimension = true;
+	vector_temp->as = gfc_get_array_spec ();
+	vector_temp->as->rank = 1;
+	vector_temp->as->type = AS_EXPLICIT;
+	vector_temp->as->lower[0] = gfc_int_expr (1);
+	vector_temp->as->upper[0] = arr_length;
+
+	/* Save it in vector_subscripts.  */
+	vector_subscripts[dim] = gfc_lval_expr_from_sym (vector_temp);
+
+	/* Build the assignment-statement to initialize this variable.  */
+	code_tail->next = gfc_get_code ();
+	code_tail = code_tail->next;
+	code_tail->next = NULL;
+	code_tail->op = EXEC_ASSIGN;
+	code_tail->expr = gfc_copy_expr (vector_subscripts[dim]);
+	code_tail->expr2 = gfc_copy_expr (vect);
+      }
+
+  /* Loop over the dimensions and build the nested loops.  */
+  loop = NULL;
+  for (dim = 0; dim != rank; ++dim)
+    {
+      gfc_symbol* itervar;
+      gfc_expr* bounds_expr;
+      int bounds_dim;
+
+      /* If adapting an existing AR_SECTION reference and the current dimension
+	 is already a single element one, nothing needs to be done.  */
+      if (aref->u.ar.type == AR_SECTION
+	  && aref->u.ar.dimen_type[dim] == DIMEN_ELEMENT)
+	continue;
+
+      /* Generate an INTEGER iteration-variable.  */
+      itervar = gfc_get_temporary_variable (gfc_current_ns);
+      itervar->ts.type = BT_INTEGER;
+      itervar->ts.kind = gfc_default_integer_kind;
+
+      /* Build a loop over the leading index.  */
+      /* TODO: These could be DO CONCURRENT loops once supported.  */
+
+      if (!loop)
+	{
+	  loop = gfc_get_code ();
+	  code_tail->next = loop;
+	  code_tail = loop;
+	}
+      else
+      {
+	loop->block->next = gfc_get_code ();
+	loop = loop->block->next;
+      }
+
+      loop->op = EXEC_DO;
+      loop->next = NULL;
+      loop->ext.iterator = gfc_get_iterator ();
+      loop->ext.iterator->var = gfc_lval_expr_from_sym (itervar);
+      loop->ext.iterator->start = loop->ext.iterator->end = NULL;
+      loop->ext.iterator->step = NULL;
+
+      /* If adapting an existing reference with DIMEN_RANGE, take the bounds
+	 from there.  */
+      if (aref->u.ar.type == AR_SECTION
+	  && aref->u.ar.dimen_type[dim] == DIMEN_RANGE)
+	{
+	  if (aref->u.ar.start[dim])
+	    loop->ext.iterator->start = gfc_copy_expr (aref->u.ar.start[dim]);
+	  if (aref->u.ar.end[dim])
+	    loop->ext.iterator->end = gfc_copy_expr (aref->u.ar.end[dim]);
+	  if (aref->u.ar.stride[dim])
+	    loop->ext.iterator->step = gfc_copy_expr (aref->u.ar.stride[dim]);
+	}
+
+      /* If we have DIMEN_VECTOR, use the vector subscript as expression to
+	 loop over for bounds-determination.  */
+      if (aref->u.ar.type == AR_SECTION
+	  && aref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+	{
+	  bounds_expr = vector_subscripts[dim];
+	  bounds_dim = 1;
+	}
+      else
+	{
+	  bounds_expr = orig_expr;
+	  bounds_dim = dim + 1;
+	}
+
+      /* Use default values if not yet set.  */
+      if (!loop->ext.iterator->start)
+	loop->ext.iterator->start =
+	  build_intrinsic_call ("lbound", bounds_expr,
+				gfc_int_expr (bounds_dim),
+				gfc_int_expr (gfc_default_integer_kind), NULL);
+      if (!loop->ext.iterator->end)
+	loop->ext.iterator->end =
+	  build_intrinsic_call ("ubound", bounds_expr,
+				gfc_int_expr (bounds_dim),
+				gfc_int_expr (gfc_default_integer_kind), NULL);
+      if (!loop->ext.iterator->step)
+	loop->ext.iterator->step = gfc_int_expr(1);
+
+      /* Generate the entry-point for the loop-body.  */
+      loop->block = gfc_get_code ();
+      loop->block->op = EXEC_DO;
+      loop->block->next = NULL;
+
+      /* Index with our itervar into the current dimension.  If we have a vector
+	 subscript to scalarize, index instead with itervar into the subscript
+	 vector and use that value as final index.  */
+      if (aref->u.ar.type == AR_SECTION
+	  && aref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+	{
+	  gfc_ref* tref;
+	  gfc_expr* index;
+
+	  index = generate_reference_expr (vector_subscripts[dim], &tref,
+					   REF_ARRAY);
+	  gcc_assert (tref->u.ar.type == AR_FULL);
+	  gcc_assert (tref->u.ar.dimen == 1);
+	  tref->u.ar.type = AR_ELEMENT;
+	  tref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+	  tref->u.ar.start[0] = gfc_lval_expr_from_sym (itervar);
+	  tref->u.ar.stride[0] = tref->u.ar.end[0] = NULL;
+
+	  gfc_resolve_expr (index);
+	  gcc_assert (index->rank == 0);
+
+	  /* This was copied above, we can free it now.  */
+	  gfc_free_expr (vector_subscripts[dim]);
+
+	  aref->u.ar.start[dim] = index;
+	}
+      else
+	aref->u.ar.start[dim] = gfc_lval_expr_from_sym (itervar);
+      aref->u.ar.dimen_type[dim] = DIMEN_ELEMENT;
+      aref->u.ar.stride[dim] = aref->u.ar.end[dim] = NULL;
+    }
+  gcc_assert (code_head && code_tail && loop);
+
+  /* Initialize the general members of the reference node, we don't need the old
+     values any longer from now on.  */
+  if (aref->u.ar.type != AR_SECTION)
+    aref->u.ar.as = as;
+  else
+    gcc_assert (aref->u.ar.as && aref->u.ar.as->rank == rank);
+  aref->u.ar.type = AR_ELEMENT;
+  aref->u.ar.offset = NULL;
+  aref->u.ar.dimen = rank;
+
+  /* Try to finalize the scalarized expression.  */
+  gfc_resolve_expr (aref_expr);
+  gcc_assert (aref_expr->rank == 0);
+  generated = finalize_derived_components (aref_expr, loop->block);
+
+  /* If nothing was generated, free everything done so far.  This can happen
+     even for types with finalizable components if no matching finalizer was
+     found there.  */
+  if (!generated)
+    {
+      gfc_free_statements (code_head);
+      return false;
+    }
+
+  /* Otherwise, put the code in the chain.  */
+  gfc_resolve_code (code_head, gfc_current_ns);
+  code_tail->next = code->next;
+  code->next = code_head;
+
+  return true;
+}
+
+
+/* Finalize the components of a derived type.  */
+
+static bool
+finalize_derived_components (gfc_expr* expr, gfc_code* code)
+{
+  gfc_component* comp;
+  gfc_array_spec* as;
+  int rank;
+  bool generated = false;
+
+  if (!gfc_is_type_finalizable (&expr->ts, true))
+    return false;
+
+  /* XXX: How to do component ref for non-variable expressions?  Might this even
+     ever be needed?  I don't think so.  */
+  gcc_assert (expr->expr_type == EXPR_VARIABLE);
+  gcc_assert (expr->symtree);
+
+  /* Find array-specification and rank.  */
+  as = expr->symtree->n.sym->as;
+  rank = expr->rank;
+  if (expr->ref)
+    {
+      gfc_ref* ref;
+      for (ref = expr->ref; ref; ref = ref->next)
+      if (ref->type == REF_COMPONENT)
+	as = ref->u.c.component->as;
+    }
+  gcc_assert (rank == 0 || as);
+
+  /* Scalarize finalization of components if the expression we're about to
+     finalize is an array of a derived type with finalizable components.  */
+  if (rank > 0)
+    {
+      gcc_assert (as);
+      return scalarize_derived_component_finalization (expr, code, as);
+    }
+
+  /* Finalize each finalizable, non-pointer component.  ALLOCATABLE components
+     are finalized, too, as they are auto-deallocated.  */
+  for (comp = expr->ts.derived->components; comp; comp = comp->next)
+    if (comp->attr.allocatable || (!comp->attr.pointer 
+			      && gfc_is_type_finalizable (&comp->ts, false)))
+      {
+	gfc_expr* cref_expr;
+	gfc_ref* reftail;
+
+	cref_expr = generate_reference_expr (expr, &reftail, REF_COMPONENT);
+	cref_expr->ts = comp->ts;
+
+	reftail->u.c.component = comp;
+	reftail->u.c.sym = expr->ts.derived;
+
+	if (comp->as)
+	  {
+	    cref_expr = generate_reference_expr (cref_expr, &reftail,
+						 REF_ARRAY);
+
+	      if (reftail->u.ar.type == AR_UNKNOWN)
+		{
+		  reftail->u.ar.type = AR_FULL;
+		  /* XXX: I'm generally unsure if all places where I do/do not
+		     copy things rather than referencing them directly are
+		     correct as they are done.  */
+		  reftail->u.ar.as = gfc_copy_array_spec (comp->as);
+		}
+	  }
+
+	cref_expr->rank = 0;
+	if (comp->as)
+	  cref_expr->rank = comp->as->rank;
+
+	gfc_resolve_expr (cref_expr);
+	gcc_assert ((!comp->as && cref_expr->rank == 0)
+		    || (comp->as && cref_expr->rank == comp->as->rank));
+
+	/* Finalize this expression.  */
+	if (gfc_finalize_expr (cref_expr, comp->attr.allocatable, code,
+			       comp->loc))
+	  generated = true;
+      }
+
+  return generated;
+}
+
+
+/* Generate code to finalize a given expression if it needs to be finalized.
+   The generated code is attached to the code-chain given.  This method is the
+   hook for finalization, implementing what the standard calls the "finalization
+   process" and is called from the various places where expressions need to be
+   finalized.
+   While ALLOCATABLE components are always auto-deallocated after the
+   finalization process, if dealloc_self is true, too, the entity itself will
+   be auto-deallocated after its finalization; this also wraps the whole
+   generated code inside a IF (ALLOCATED (expr)) condition.
+   True is returned if any code was generated.  */
+
+bool
+gfc_finalize_expr (gfc_expr* expr, bool dealloc_self, gfc_code* code,
+		   locus where)
+{
+  gfc_code* whole_code = NULL;
+  gfc_code* final_after = NULL;
+  gfc_finalizer* f;
+  gfc_symtree* proc;
+  int expr_rank;
+  bool generated = false;
+
+  gcc_assert (expr);
+
+  /* If this entity itself is autodeallocated, insert conditional around all
+     generated code to check if it is allocated at runtime.  */
+  if (dealloc_self)
+    {
+      /* Build an IF (ALLOCATED (expr)) statement wrapping the whole
+	 finalization-logic following.  */
+
+      whole_code = gfc_get_code ();
+      whole_code->op = EXEC_IF;
+      whole_code->expr = NULL;
+      whole_code->next = NULL;
+
+      whole_code->block = gfc_get_code ();
+      whole_code->block->op = EXEC_IF;
+      whole_code->block->expr = build_intrinsic_call ("allocated", expr, NULL);
+      whole_code->block->next = NULL;
+      final_after = whole_code->block;
+    }
+  else
+    {
+      /* Build a NOP instead of the IF to chain finalization code to.  */
+      whole_code = gfc_get_code ();
+      whole_code->op = EXEC_NOP;
+      whole_code->next = NULL;
+      final_after = whole_code;
+    }
+
+  /* If we are no derived type or don't have a finalizer ourself, skip this
+     self-finalization part.  */
+  if (expr->ts.type != BT_DERIVED || !expr->ts.derived->f2k_derived 
+      || !expr->ts.derived->f2k_derived->finalizers)
+    goto finish;
+
+  expr_rank = expr->rank; /* Easy for expressions.  */
+
+  /* Find a finalizer with the correct rank or an elemental
+     finalizer and call it.  */
+  /* TODO:  Also check for correct kind type parameters once those are
+     implemented in gfortran.  */
+  proc = NULL;
+  f = expr->ts.derived->f2k_derived->finalizers;
+  for (; f && !proc; f = f->next)
+    {
+      int proc_rank = 0;
+      gcc_assert (f->proc_tree);
+      gcc_assert (f->proc_tree->n.sym->formal);
+      if (f->proc_tree->n.sym->formal->sym->as)
+      proc_rank = f->proc_tree->n.sym->formal->sym->as->rank;
+
+      if (expr_rank == proc_rank)
+      proc = f->proc_tree;
+    }
+
+  f = expr->ts.derived->f2k_derived->finalizers;
+  for (; f && !proc; f = f->next)
+    {
+      if (f->proc_tree->n.sym->attr.elemental)
+      proc = f->proc_tree;
+    }
+
+  /* Warn if we didn't find a suitable finalizer but others are defined for this
+     type.  In this case, the standard mandates to simply call no procedure, but
+     this is probably something not intended by the user.  */
+  if (!proc)
+    {
+      gfc_warning ("No matching finalizer found for derived type '%s' and"
+		   " rank %d at %L", expr->ts.derived->name, expr_rank, &where);
+      goto finish;
+    }
+
+  /* Build the subroutine call.  */
+  gcc_assert (!final_after->next);
+  final_after->next = gfc_get_code ();
+  final_after = final_after->next;
+  final_after->loc = gfc_current_locus;
+  final_after->op = EXEC_CALL;
+  final_after->symtree = proc;
+  final_after->ext.actual = gfc_get_actual_arglist();
+  final_after->ext.actual->next = NULL;
+  final_after->ext.actual->expr = gfc_copy_expr (expr);
+  final_after->next = NULL;
+  generated = true;
+
+finish:
+
+  /* Finalize components, should be after our own finalizer call.  */
+  if (finalize_derived_components (expr, final_after))
+    generated = true;
+
+  /* TODO:  Here we could insert the auto-deallocation EXEC_DEALLOCATE statement
+     when moving auto-deallocation from trans to resolution.  */
+
+  /* If anything was generated, resolve our code and insert it into the
+     code-chain.  */
+  if (generated)
+    {
+      gfc_code* tail;
+
+      gfc_resolve_code (whole_code, gfc_current_ns);
+      
+      for (tail = whole_code; tail->next; )
+	tail = tail->next;
+      tail->next = code->next;
+      code->next = whole_code;
+    }
+  else if (whole_code)
+    gfc_free_statements (whole_code);
+
+  return generated;
+}
+
+
 /* Walk an expression tree and check each variable encountered for being typed.
    If strict is not set, a top-level variable is tolerated untyped in -std=gnu
    mode as is a basic arithmetic expression using those; this is for things in
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 141948)
+++ gcc/fortran/resolve.c	(working copy)
@@ -39,7 +39,7 @@ typedef enum seq_type
 seq_type;
 
 /* Stack to keep track of the nesting of blocks as we move through the
-   code.  See resolve_branch() and resolve_code().  */
+   code.  See resolve_branch() and gfc_resolve_code().  */
 
 typedef struct code_stack
 {
@@ -2853,8 +2853,8 @@ found:
    for functions, subroutines and functions are stored differently and this
    makes things awkward.  */
 
-static gfc_try
-resolve_call (gfc_code *c)
+gfc_try
+gfc_resolve_call (gfc_code *c)
 {
   gfc_try t;
   procedure_type ptype = PROC_INTRINSIC;
@@ -4174,7 +4174,7 @@ resolve_variable (gfc_expr *e)
   if (check_assumed_size_reference (sym, e))
     return FAILURE;
 
-  /* Deal with forward references to entries during resolve_code, to
+  /* Deal with forward references to entries during gfc_resolve_code, to
      satisfy, at least partially, 12.5.2.5.  */
   if (gfc_current_ns->entries
       && current_entry_id == sym->entry_id
@@ -4603,7 +4603,7 @@ resolve_typebound_call (gfc_code* c)
   gfc_free_expr (c->expr);
   c->expr = NULL;
 
-  return resolve_call (c);
+  return gfc_resolve_call (c);
 }
 
 
@@ -6082,10 +6082,10 @@ resolve_where (gfc_code *code, gfc_expr 
 
   
 	    case EXEC_ASSIGN_CALL:
-	      resolve_call (cnext);
+	      gfc_resolve_call (cnext);
 	      if (!cnext->resolved_sym->attr.elemental)
-		gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
-			  &cnext->ext.actual->expr->where);
+		gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at"
+			  " %L", &cnext->ext.actual->expr->where);
 	      break;
 
 	    /* WHERE or WHERE construct is part of a where-body-construct */
@@ -6169,10 +6169,10 @@ gfc_resolve_where_code_in_forall (gfc_co
   
 	    /* WHERE operator assignment statement */
 	    case EXEC_ASSIGN_CALL:
-	      resolve_call (cnext);
+	      gfc_resolve_call (cnext);
 	      if (!cnext->resolved_sym->attr.elemental)
-		gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L",
-			  &cnext->ext.actual->expr->where);
+		gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at"
+			  " %L", &cnext->ext.actual->expr->where);
 	      break;
 
 	    /* WHERE or WHERE construct is part of a where-body-construct */
@@ -6214,7 +6214,7 @@ gfc_resolve_forall_body (gfc_code *code,
 	  break;
 
 	case EXEC_ASSIGN_CALL:
-	  resolve_call (c);
+	  gfc_resolve_call (c);
 	  break;
 
 	/* Because the gfc_resolve_blocks() will handle the nested FORALL,
@@ -6344,8 +6344,6 @@ gfc_resolve_forall (gfc_code *code, gfc_
 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
    DO code nodes.  */
 
-static void resolve_code (gfc_code *, gfc_namespace *);
-
 void
 gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
 {
@@ -6408,7 +6406,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
 	  gfc_internal_error ("resolve_block(): Bad block type");
 	}
 
-      resolve_code (b->next, ns);
+      gfc_resolve_code (b->next, ns);
     }
 }
 
@@ -6557,8 +6555,8 @@ resolve_ordinary_assign (gfc_code *code,
 /* Given a block of code, recursively resolve everything pointed to by this
    code block.  */
 
-static void
-resolve_code (gfc_code *code, gfc_namespace *ns)
+void
+gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
 {
   int omp_workshare_save;
   int forall_save;
@@ -6721,7 +6719,7 @@ resolve_code (gfc_code *code, gfc_namesp
 
 	case EXEC_CALL:
 	call:
-	  resolve_call (code);
+	  gfc_resolve_call (code);
 	  break;
 
 	case EXEC_COMPCALL:
@@ -6745,7 +6743,8 @@ resolve_code (gfc_code *code, gfc_namesp
 
 	case EXEC_DO_WHILE:
 	  if (code->expr == NULL)
-	    gfc_internal_error ("resolve_code(): No expression on DO WHILE");
+	    gfc_internal_error ("gfc_resolve_code():  No expression on"
+				" DO WHILE");
 	  if (t == SUCCESS
 	      && (code->expr->rank != 0
 		  || code->expr->ts.type != BT_LOGICAL))
@@ -6861,7 +6860,7 @@ resolve_code (gfc_code *code, gfc_namesp
 	  break;
 
 	default:
-	  gfc_internal_error ("resolve_code(): Bad statement code");
+	  gfc_internal_error ("gfc_resolve_code(): Bad statement code");
 	}
     }
 
@@ -10273,7 +10272,7 @@ gfc_resolve_uops (gfc_symtree *symtree)
    assign types to all intermediate expressions, make sure that all
    assignments are to compatible types and figure out which names
    refer to which functions or subroutines.  It doesn't check code
-   block, which is handled by resolve_code.  */
+   block, which is handled by gfc_resolve_code.  */
 
 static void
 resolve_types (gfc_namespace *ns)
@@ -10357,7 +10356,7 @@ resolve_types (gfc_namespace *ns)
 }
 
 
-/* Call resolve_code recursively.  */
+/* Call gfc_resolve_code recursively.  */
 
 static void
 resolve_codes (gfc_namespace *ns)
@@ -10373,7 +10372,7 @@ resolve_codes (gfc_namespace *ns)
   current_entry_id = -1;
 
   bitmap_obstack_initialize (&labels_obstack);
-  resolve_code (ns->code, ns);
+  gfc_resolve_code (ns->code, ns);
   bitmap_obstack_release (&labels_obstack);
 }
 

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]