[gcc(refs/users/mikael/heads/refactor_descriptor_v03)] Renseignement token par gfc_set_descriptor_from_scalar.

[Mikael Morin]

https://gcc.gnu.org/g:e935f964d8dfa7a9db3242f1e0e3ea4dce6b213b

commit e935f964d8dfa7a9db3242f1e0e3ea4dce6b213b
Author: Mikael Morin <mikael@gcc.gnu.org>
Date:   Wed Feb 5 15:12:25 2025 +0100

    Renseignement token par gfc_set_descriptor_from_scalar.

Diff:
---
 gcc/fortran/trans-array.cc | 27 ++++++++++++++++++++-------
 gcc/fortran/trans-array.h  |  2 +-
 gcc/fortran/trans-expr.cc  | 15 +++++++++++----
 3 files changed, 32 insertions(+), 12 deletions(-)

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index b9b79e832dd2..77e1e1abea4f 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -684,6 +684,7 @@ public:
   virtual bool set_span () const { return false; }
   virtual bool set_token () const { return true; }
   virtual tree get_data_value () const { return NULL_TREE; }
+  virtual tree get_caf_token () const { return null_pointer_node; }
   virtual bt get_type_type (const gfc_typespec &) const { return BT_UNKNOWN; }
   virtual tree get_length (gfc_typespec *ts) const { return get_size_info (*ts); }
 };
@@ -753,22 +754,24 @@ private:
   bool initialisation;
   gfc_typespec *ts;
   tree value;
+  tree caf_token;
   bool use_tree_type_;
   bool clear_token;
   tree get_elt_type () const;
 
 public:
   scalar_value(gfc_typespec &arg_ts, tree arg_value)
-    : initialisation(true), ts(&arg_ts), value(arg_value), use_tree_type_ (false), clear_token(true) { }
-  scalar_value(tree arg_value)
-    : initialisation(true), ts(nullptr), value(arg_value), use_tree_type_ (true), clear_token(false) { }
+    : initialisation(true), ts(&arg_ts), value(arg_value), caf_token (NULL_TREE),  use_tree_type_ (false), clear_token(true) { }
+  scalar_value(tree arg_value, tree arg_caf_token)
+    : initialisation(true), ts(nullptr), value(arg_value), caf_token (arg_caf_token), use_tree_type_ (true), clear_token(false) { }
   virtual bool is_initialization () const { return initialisation; }
   virtual bool initialize_data () const { return true; }
   virtual tree get_data_value () const;
   virtual gfc_typespec *get_type () const { return ts; }
   virtual bool set_span () const { return true; }
   virtual bool use_tree_type () const { return use_tree_type_; }
-  virtual bool set_token () const { return clear_token; }
+  virtual bool set_token () const { return clear_token || caf_token != NULL_TREE; }
+  virtual tree get_caf_token () const;
   virtual bt get_type_type (const gfc_typespec &) const;
   virtual tree get_length (gfc_typespec *ts) const;
 };
@@ -840,6 +843,16 @@ scalar_value::get_length (gfc_typespec * type_info) const
   return size;
 }
 
+tree
+scalar_value::get_caf_token () const
+{
+  if (set_token ()
+      && caf_token != NULL_TREE)
+    return caf_token;
+  else
+    return modify_info::get_caf_token ();
+}
+
 
 static tree
 build_dtype (gfc_typespec *ts, int rank, const symbol_attribute &,
@@ -935,7 +948,7 @@ get_descriptor_init (tree type, gfc_typespec *ts, int rank,
       tree token_field = gfc_advance_chain (fields,
 					    CAF_TOKEN_FIELD - (!dim_present));
       tree token_value = fold_convert (TREE_TYPE (token_field),
-				       null_pointer_node);
+				       init.get_caf_token ());
       CONSTRUCTOR_APPEND_ELT (v, token_field, token_value);
     }
 
@@ -1432,11 +1445,11 @@ gfc_set_scalar_descriptor (stmtblock_t *block, tree descriptor,
 
 void
 gfc_set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
-				symbol_attribute *attr)
+				symbol_attribute *attr, tree caf_token)
 {
   init_struct (block, desc,
 	       get_descriptor_init (TREE_TYPE (desc), nullptr, 0, attr,
-				    scalar_value (scalar)));
+				    scalar_value (scalar, caf_token)));
 }
 
 
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 97cf7f8cb41f..2dad79aa9993 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -149,7 +149,7 @@ void gfc_set_descriptor_with_shape (stmtblock_t *, tree, tree,
 				    gfc_expr *, locus *);
 tree gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr);
 void gfc_set_descriptor_from_scalar (stmtblock_t *, tree, tree,
-				     symbol_attribute *);
+				     symbol_attribute *, tree = NULL_TREE);
 void gfc_copy_sequence_descriptor (stmtblock_t &, tree, tree, bool);
 void gfc_set_gfc_from_cfi (stmtblock_t *, stmtblock_t *, tree, tree, tree,
 			   gfc_symbol *, bool, bool, bool);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 8bf985dcac58..2373f267169f 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -883,14 +883,20 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
   /* Now set the data field.  */
   ctree = gfc_class_data_get (var);
 
+  tree caf_token;
   if (flag_coarray == GFC_FCOARRAY_LIB && CLASS_DATA (fsym)->attr.codimension)
     {
-      tree token;
       tmp = gfc_get_tree_for_caf_expr (e);
       if (POINTER_TYPE_P (TREE_TYPE (tmp)))
 	tmp = build_fold_indirect_ref (tmp);
-      gfc_get_caf_token_offset (parmse, &token, nullptr, tmp, NULL_TREE, e);
-      gfc_add_modify (&parmse->pre, gfc_conv_descriptor_token (ctree), token);
+      gfc_get_caf_token_offset (parmse, &caf_token, nullptr, tmp, NULL_TREE, e);
+      /* gfc_set_descriptor_from scalar already updates the token,
+         don't do it twice.  */
+      if ((parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
+	  || (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
+	  || e->rank != 0
+	  || fsym->ts.u.derived->components->as == nullptr)
+	gfc_add_modify (&parmse->pre, gfc_conv_descriptor_token (ctree), caf_token);
     }
 
   if (optional)
@@ -966,7 +972,8 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym,
 						  null_pointer_node));
 		}
 	      symbol_attribute attr = gfc_expr_attr (e);
-	      gfc_set_descriptor_from_scalar (&parmse->pre, ctree, tmp, &attr);
+	      gfc_set_descriptor_from_scalar (&parmse->pre, ctree, tmp, &attr,
+					      caf_token);
 	    }
           else
 	    {