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

["Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>]

Daniel,

I'm struggling to make any contribution right now.  I do not even have
access to a working tree.  I'll do the best I can over the next 24
hours.

Cheers

Paul

On Sat, Aug 16, 2008 at 12:11 PM, Daniel Kraft <d@domob.eu> wrote:
> Here's the one with patch attached...
>
>> Daniel Kraft wrote:
>>>
>>> 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);
>  }
>
>
>



-- 
The knack of flying is learning how to throw yourself at the ground and miss.
 --Hitchhikers Guide to the Galaxy