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]

[Patch, Fortran] Derived-type finalization, second part split off


Hi Paul,

here's a second split-off from the finalization patch after check-in and remerging the last part; it is roughly everything (remainin after the last part) except resolve.c changes.

This is somehow the "main part" and includes the logic behind gfc_finalize_expr, that is, everything except for the integration and actual *calling* of finalization. This means that this patch for itself does neither introduce new features nor any risk of breaking something (I think).

Maybe we could also include the basic finalization when a symbol goes out of scope here to get the code actually tested already when this is checked-in and somewhat working (but for this we would have to remove the not-yet-implemented message though finalization would be implemented at best "partially" then). What do you think? From my point of view, both ways are equally good solutions.

I believe this part of the patch is already quite "stable" and finished, nothing of the "open issues" affects it; the only point I ask you to think about is that by checking in this one, we make our lives harder if we find out that finalization can't possibly be done in the front-end and we have to move it to trans; but I believe it is highly unlikely that this should happen, and hope we can resolve the last issues in a way as I proposed in http://gcc.gnu.org/ml/fortran/2008-08/msg00026.html.

As usual, some XXX comments left in... What do you think about this patch, ok to commit or should I add some parts of reslve.c as described above? If I know your decision on how we should handle this part, I'll of course add a ChangeLog entry.

Regression-tested on x86-32-GNU/Linux with no failures of course, but as I said above I can't imagine how this patch should break something at the moment.

Cheers,
Daniel

PS: From today evening, I'll be off until coming Friday, possibly late at night; I'm doing a mountain-trip near the Großglockner (well, what do Austrians do in the summer when there's no snow to ski?). So take your time :)

--
Done:     Arc-Bar-Sam-Val-Wiz, Dwa-Elf-Gno-Hum-Orc, Law-Neu-Cha, Fem-Mal
Underway: Cav-Dwa-Law-Fem
To go:    Cav-Hea-Kni-Mon-Pri-Ran-Rog-Tou
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 138898)
+++ gcc/fortran/symbol.c	(working copy)
@@ -2311,6 +2311,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 138898)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2203,6 +2203,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 *);
@@ -2336,6 +2337,9 @@ bool gfc_traverse_expr (gfc_expr *, gfc_
 			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);
+
 /* st.c */
 extern gfc_code new_st;
 
@@ -2359,6 +2363,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 138898)
+++ gcc/fortran/expr.c	(working copy)
@@ -3266,3 +3266,620 @@ gfc_expr_set_symbols_referenced (gfc_exp
 {
   gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
 }
+
+
+/* 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->allocatable || (!comp->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->allocatable || (!comp->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->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;
+}
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 138898)
+++ 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
 {
@@ -2772,8 +2772,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;
@@ -4069,7 +4069,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
@@ -5710,10 +5710,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 */
@@ -5795,10 +5795,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 */
@@ -5840,7 +5840,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,
@@ -5929,8 +5929,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)
 {
@@ -5993,7 +5991,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);
     }
 }
 
@@ -6142,8 +6140,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;
@@ -6304,7 +6302,7 @@ resolve_code (gfc_code *code, gfc_namesp
 
 	case EXEC_CALL:
 	call:
-	  resolve_call (code);
+	  gfc_resolve_call (code);
 	  break;
 
 	case EXEC_SELECT:
@@ -6324,7 +6322,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))
@@ -6440,7 +6439,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");
 	}
     }
 
@@ -9251,7 +9250,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)
@@ -9320,7 +9319,7 @@ resolve_types (gfc_namespace *ns)
 }
 
 
-/* Call resolve_code recursively.  */
+/* Call gfc_resolve_code recursively.  */
 
 static void
 resolve_codes (gfc_namespace *ns)
@@ -9336,7 +9335,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]