[gcc r12-10396] gfortran: Allow ref'ing PDT's len() in parameter-initializer.

[Harald Anlauf <anlauf@gcc.gnu.org>]

https://gcc.gnu.org/g:8ad460ca8824f7e29e38a63f9cb4a9a3b96d506f

commit r12-10396-g8ad460ca8824f7e29e38a63f9cb4a9a3b96d506f
Author: Andre Vehreschild <vehre@gcc.gnu.org>
Date:   Wed Jul 12 12:51:30 2023 +0200

    gfortran: Allow ref'ing PDT's len() in parameter-initializer.
    
    Fix declaring a parameter initialized using a pdt_len reference
    not simplifying the reference to a constant.
    
    2023-07-12  Andre Vehreschild  <vehre@gcc.gnu.org>
    
    gcc/fortran/ChangeLog:
    
            PR fortran/102003
            * expr.cc (find_inquiry_ref): Replace len of pdt_string by
            constant.
            (simplify_ref_chain): Ensure input to find_inquiry_ref is
            NULL.
            (gfc_match_init_expr): Prevent PDT analysis for function calls.
            (gfc_pdt_find_component_copy_initializer): Get the initializer
            value for given component.
            * gfortran.h (gfc_pdt_find_component_copy_initializer): New
            function.
            * simplify.cc (gfc_simplify_len): Replace len() of PDT with pdt
            component ref or constant.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/pdt_33.f03: New test.
    
    (cherry picked from commit f9182da3213aa57c16dd0b52862126de4a259f6a)

Diff:
---
 gcc/fortran/expr.cc                  | 31 ++++++++++++++++++--
 gcc/fortran/gfortran.h               |  1 +
 gcc/fortran/simplify.cc              | 57 ++++++++++++++++++++++++++++--------
 gcc/testsuite/gfortran.dg/pdt_33.f03 | 21 +++++++++++++
 4 files changed, 94 insertions(+), 16 deletions(-)

diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index c04403a2b89..5640d215925 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -1850,6 +1850,13 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
 	  else if (tmp->expr_type == EXPR_CONSTANT)
 	    *newp = gfc_get_int_expr (gfc_default_integer_kind,
 				      NULL, tmp->value.character.length);
+	  else if (gfc_init_expr_flag
+		   && tmp->ts.u.cl->length->symtree->n.sym->attr.pdt_len)
+	    *newp = gfc_pdt_find_component_copy_initializer (tmp->symtree->n
+							     .sym,
+							     tmp->ts.u.cl
+							     ->length->symtree
+							     ->n.sym->name);
 	  else
 	    goto cleanup;
 
@@ -1890,7 +1897,9 @@ find_inquiry_ref (gfc_expr *p, gfc_expr **newp)
 		    mpc_imagref (tmp->value.complex), GFC_RND_MODE);
 	  break;
 	}
-      tmp = gfc_copy_expr (*newp);
+      // TODO: Fix leaking expr tmp, when simplify is done twice.
+      if (inquiry->next)
+	gfc_replace_expr (tmp, *newp);
     }
 
   if (!(*newp))
@@ -2055,7 +2064,7 @@ static bool
 simplify_ref_chain (gfc_ref *ref, int type, gfc_expr **p)
 {
   int n;
-  gfc_expr *newp;
+  gfc_expr *newp = NULL;
 
   for (; ref; ref = ref->next)
     {
@@ -3217,7 +3226,7 @@ gfc_match_init_expr (gfc_expr **result)
       return m;
     }
 
-  if (gfc_derived_parameter_expr (expr))
+  if (expr->expr_type != EXPR_FUNCTION && gfc_derived_parameter_expr (expr))
     {
       *result = expr;
       gfc_init_expr_flag = false;
@@ -6530,3 +6539,19 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
 
   return true;
 }
+
+gfc_expr*
+gfc_pdt_find_component_copy_initializer (gfc_symbol *sym, const char *name)
+{
+  /* The actual length of a pdt is in its components.  In the
+     initializer of the current ref is only the default value.
+     Therefore traverse the chain of components and pick the correct
+     one's initializer expressions.  */
+  for (gfc_component *comp = sym->ts.u.derived->components; comp != NULL;
+       comp = comp->next)
+    {
+      if (!strcmp (comp->name, name))
+	return gfc_copy_expr (comp->initializer);
+    }
+  return NULL;
+}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 98c0cd39503..0b0a8fe7118 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3667,6 +3667,7 @@ gfc_expr* gfc_find_stat_co (gfc_expr *);
 gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*,
 				    locus, unsigned, ...);
 bool gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*);
+gfc_expr* gfc_pdt_find_component_copy_initializer (gfc_symbol *, const char *);
 
 
 /* st.cc */
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 83b4e7d3493..a10f79c4a93 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4525,19 +4525,50 @@ gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
       return range_check (result, "LEN");
     }
   else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
-	   && e->symtree->n.sym
-	   && e->symtree->n.sym->ts.type != BT_DERIVED
-	   && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
-	   && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED
-	   && e->symtree->n.sym->assoc->target->symtree->n.sym
-	   && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym))
-
-    /* The expression in assoc->target points to a ref to the _data component
-       of the unlimited polymorphic entity.  To get the _len component the last
-       _data ref needs to be stripped and a ref to the _len component added.  */
-    return gfc_get_len_component (e->symtree->n.sym->assoc->target, k);
-  else
-    return NULL;
+	   && e->symtree->n.sym)
+    {
+      if (e->symtree->n.sym->ts.type != BT_DERIVED
+	  && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
+	  && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED
+	  && e->symtree->n.sym->assoc->target->symtree->n.sym
+	  && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym))
+	/* The expression in assoc->target points to a ref to the _data
+	   component of the unlimited polymorphic entity.  To get the _len
+	   component the last _data ref needs to be stripped and a ref to the
+	   _len component added.  */
+	return gfc_get_len_component (e->symtree->n.sym->assoc->target, k);
+      else if (e->symtree->n.sym->ts.type == BT_DERIVED
+	       && e->ref && e->ref->type == REF_COMPONENT
+	       && e->ref->u.c.component->attr.pdt_string
+	       && e->ref->u.c.component->ts.type == BT_CHARACTER
+	       && e->ref->u.c.component->ts.u.cl->length)
+	{
+	  if (gfc_init_expr_flag)
+	    {
+	      gfc_expr* tmp;
+	      tmp = gfc_pdt_find_component_copy_initializer (e->symtree->n.sym,
+							     e->ref->u.c
+							     .component->ts.u.cl
+							     ->length->symtree
+							     ->name);
+	      if (tmp)
+		return tmp;
+	    }
+	  else
+	    {
+	      gfc_expr *len_expr = gfc_copy_expr (e);
+	      gfc_free_ref_list (len_expr->ref);
+	      len_expr->ref = NULL;
+	      gfc_find_component (len_expr->symtree->n.sym->ts.u.derived, e->ref
+				  ->u.c.component->ts.u.cl->length->symtree
+				  ->name,
+				  false, true, &len_expr->ref);
+	      len_expr->ts = len_expr->ref->u.c.component->ts;
+	      return len_expr;
+	    }
+	}
+    }
+  return NULL;
 }
 
 
diff --git a/gcc/testsuite/gfortran.dg/pdt_33.f03 b/gcc/testsuite/gfortran.dg/pdt_33.f03
new file mode 100644
index 00000000000..3b2fe72431d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_33.f03
@@ -0,0 +1,21 @@
+! { dg-do run }
+!
+! Test the fix for PR102003, where len parameters where not returned as constants.
+!
+! Contributed by Harald Anlauf  <anlauf@gcc.gnu.org>
+!
+program pr102003
+  type pdt(n)
+     integer, len     :: n = 8
+     character(len=n) :: c
+  end type pdt
+  type(pdt(42)) :: p
+  integer, parameter :: m = len (p% c)
+  integer, parameter :: lm = p% c% len
+
+  if (m /= 42) stop 1
+  if (len (p% c) /= 42) stop 2
+  if (lm /= 42) stop 3
+  if (p% c% len /= 42) stop 4
+end
+