public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-5675] [Ada] Improve support for casing on types with controlled parts
@ 2021-12-01 10:26 Pierre-Marie de Rodat
  0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-12-01 10:26 UTC (permalink / raw)
  To: gcc-cvs

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

commit r12-5675-gbb2fc099e28c6e0fc3f77598c514fa6ec72d846d
Author: Steve Baird <baird@adacore.com>
Date:   Fri Nov 5 15:22:05 2021 -0700

    [Ada] Improve support for casing on types with controlled parts
    
    gcc/ada/
    
            * sem_case.adb (Check_Bindings): Provide a second strategy for
            implementing bindings and choose which strategy to use for a
            given binding. The previous approach was to introduce a new
            object and assign the bound value to the object.  The new
            approach is to introduce a renaming of a dereference of an
            access value that references the appropriate subcomponent, so no
            copies are made.  The original strategy is still used if the
            type of the object is elementary.  When the renaming approach is
            used, the initialization of the access value is not generated
            until expansion. Until this missing initialization is added, the
            tree looks like a known-at-compile-time dereference of a null
            access value: Temp : Some_Access_Type; Obj : Designated_Type
            renames Temp.all; This leads to problems, so a bogus initial
            value is provided here and then later deleted during expansion.
            (Check_Composite_Case_Selector): Disallow a case selector
            expression that requires finalization. Note that it is ok if the
            selector's type requires finalization, as long as the expression
            itself doesn't have any "newly constructed" parts.
            * exp_ch5.adb (Pattern_Match): Detect the case where analysis of
            a general (i.e., composite selector type) case statement chose
            to implement a binding as a renaming rather than by making a
            copy. In that case, generate the assignments to initialize the
            access-valued object whose designated value is later renamed
            (and remove the bogus initial value for that object that was
            added during analysis).
            * sem_util.ads, sem_util.adb: Add new function
            Is_Newly_Constructed corresponding to RM 4.4 term.

Diff:
---
 gcc/ada/exp_ch5.adb  | 198 +++++++++++++++++++++++++++++--------------
 gcc/ada/sem_case.adb | 233 +++++++++++++++++++++++++++++++++++++++------------
 gcc/ada/sem_util.adb | 111 ++++++++++++++++++++++++
 gcc/ada/sem_util.ads |  19 +++++
 4 files changed, 444 insertions(+), 117 deletions(-)

diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 47c6b800eb0..42cffd5186a 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -3348,6 +3348,13 @@ package body Exp_Ch5 is
             Alt          : Node_Id;
             Suppress_Choice_Index_Update : Boolean := False) return Node_Id
          is
+            procedure Finish_Binding_Object_Declaration
+              (Component_Assoc : Node_Id; Subobject : Node_Id);
+            --  Finish the work that was started during analysis to
+            --  declare a binding object. If we are generating a copy,
+            --  then initialize it. If we are generating a renaming, then
+            --  initialize the access value designating the renamed object.
+
             function Update_Choice_Index return Node_Id is (
               Make_Assignment_Statement (Loc,
                 Name       =>
@@ -3368,6 +3375,130 @@ package body Exp_Ch5 is
             function Indexed_Element (Idx : Pos) return Node_Id;
             --  Returns the Nth (well, ok, the Idxth) element of Object
 
+            ---------------------------------------
+            -- Finish_Binding_Object_Declaration --
+            ---------------------------------------
+
+            procedure Finish_Binding_Object_Declaration
+              (Component_Assoc : Node_Id; Subobject : Node_Id)
+            is
+               Decl_Chars   : constant Name_Id :=
+                 Binding_Chars (Component_Assoc);
+
+               Block_Stmt   : constant Node_Id := First (Statements (Alt));
+               pragma Assert (Nkind (Block_Stmt) = N_Block_Statement);
+               pragma Assert (No (Next (Block_Stmt)));
+
+               Decl         : Node_Id := First (Declarations (Block_Stmt));
+               Def_Id       : Node_Id := Empty;
+
+               --  Declare_Copy indicates which of the two approaches
+               --  was chosen during analysis: declare (and initialize)
+               --  a new variable, or use access values to declare a renaming
+               --  of the appropriate subcomponent of the selector value.
+               Declare_Copy : constant Boolean :=
+                 Nkind (Decl) = N_Object_Declaration;
+
+               function Make_Conditional (Stmt : Node_Id) return Node_Id;
+               --  If there is only one choice for this alternative, then
+               --  simply return the argument. If there is more than one
+               --  choice, then wrap an if-statement around the argument
+               --  so that it is only executed if the current choice matches.
+
+               ----------------------
+               -- Make_Conditional --
+               ----------------------
+
+               function Make_Conditional (Stmt : Node_Id) return Node_Id
+               is
+                  Condition : Node_Id;
+               begin
+                  if Present (Choice_Index_Decl) then
+                     Condition :=
+                       Make_Op_Eq (Loc,
+                         New_Occurrence_Of
+                           (Defining_Identifier (Choice_Index_Decl), Loc),
+                         Make_Integer_Literal (Loc, Int (Choice_Index)));
+
+                     return Make_If_Statement (Loc,
+                              Condition       => Condition,
+                              Then_Statements => New_List (Stmt));
+                  else
+                     --  execute Stmt unconditionally
+                     return Stmt;
+                  end if;
+               end Make_Conditional;
+
+            begin
+               --  find the variable to be modified (and its declaration)
+               loop
+                  if Nkind (Decl) in N_Object_Declaration
+                    | N_Object_Renaming_Declaration
+                  then
+                     Def_Id := Defining_Identifier (Decl);
+                     exit when Chars (Def_Id) = Decl_Chars;
+                  end if;
+                  Next (Decl);
+                  pragma Assert (Present (Decl));
+               end loop;
+
+               --  For a binding object, we sometimes make a copy and
+               --  sometimes introduce  a renaming. That decision is made
+               --  elsewhere. The renaming case involves dereferencing an
+               --  access value because of the possibility of multiple
+               --  choices (with multiple binding definitions) for a single
+               --  alternative. In the copy case, we initialize the copy
+               --  here (conditionally if there are multiple choices); in the
+               --  renaming case, we initialize (again, maybe conditionally)
+               --  the access value.
+
+               if Declare_Copy then
+                  declare
+                     Assign_Value : constant Node_Id  :=
+                       Make_Assignment_Statement (Loc,
+                         Name       => New_Occurrence_Of (Def_Id, Loc),
+                         Expression => Subobject);
+
+                     HSS : constant Node_Id :=
+                       Handled_Statement_Sequence (Block_Stmt);
+                  begin
+                     Prepend (Make_Conditional (Assign_Value),
+                              Statements (HSS));
+                     Set_Analyzed (HSS, False);
+                  end;
+               else
+                  pragma Assert (Nkind (Name (Decl)) = N_Explicit_Dereference);
+
+                  declare
+                     Ptr_Obj  : constant Entity_Id :=
+                       Entity (Prefix (Name (Decl)));
+                     Ptr_Decl : constant Node_Id := Parent (Ptr_Obj);
+
+                     Assign_Reference : constant Node_Id :=
+                       Make_Assignment_Statement (Loc,
+                         Name       => New_Occurrence_Of (Ptr_Obj, Loc),
+                         Expression =>
+                           Make_Attribute_Reference (Loc,
+                             Prefix => Subobject,
+                             Attribute_Name => Name_Unrestricted_Access));
+                  begin
+                     Insert_After
+                       (After => Ptr_Decl,
+                        Node  => Make_Conditional (Assign_Reference));
+
+                     if Present (Expression (Ptr_Decl)) then
+                        --  Delete bogus initial value built during analysis.
+                        --  Look for "5432" in sem_case.adb.
+                        pragma Assert (Nkind (Expression (Ptr_Decl)) =
+                                       N_Unchecked_Type_Conversion);
+                        Set_Expression (Ptr_Decl, Empty);
+                     end if;
+                  end;
+               end if;
+
+               Set_Analyzed (Block_Stmt, False);
+            end Finish_Binding_Object_Declaration;
+
             ---------------------
             -- Indexed_Element --
             ---------------------
@@ -3519,70 +3650,9 @@ package body Exp_Ch5 is
 
                               if Binding_Chars (Component_Assoc) /= No_Name
                               then
-                                 declare
-                                    Decl_Chars : constant Name_Id :=
-                                      Binding_Chars (Component_Assoc);
-
-                                    Block_Stmt : constant Node_Id :=
-                                      First (Statements (Alt));
-                                    pragma Assert
-                                      (Nkind (Block_Stmt) = N_Block_Statement);
-                                    pragma Assert (No (Next (Block_Stmt)));
-                                    Decl : Node_Id
-                                      := First (Declarations (Block_Stmt));
-                                    Def_Id : Node_Id := Empty;
-
-                                    Assignment_Stmt : Node_Id;
-                                    Condition       : Node_Id;
-                                    Prepended_Stmt  : Node_Id;
-                                 begin
-                                    --  find the variable to be modified
-                                    while No (Def_Id) or else
-                                      Chars (Def_Id) /= Decl_Chars
-                                    loop
-                                       Def_Id := Defining_Identifier (Decl);
-                                       Next (Decl);
-                                    end loop;
-
-                                    Assignment_Stmt :=
-                                      Make_Assignment_Statement (Loc,
-                                        Name       => New_Occurrence_Of
-                                                        (Def_Id, Loc),
-                                        Expression => Subobject);
-
-                                    --  conditional if multiple choices
-
-                                    if Present (Choice_Index_Decl) then
-                                       Condition :=
-                                         Make_Op_Eq (Loc,
-                                           New_Occurrence_Of
-                                             (Defining_Identifier
-                                                (Choice_Index_Decl), Loc),
-                                          Make_Integer_Literal
-                                            (Loc, Int (Choice_Index)));
-
-                                       Prepended_Stmt :=
-                                         Make_If_Statement (Loc,
-                                           Condition       => Condition,
-                                           Then_Statements =>
-                                             New_List (Assignment_Stmt));
-                                    else
-                                       --  assignment is unconditional
-                                       Prepended_Stmt := Assignment_Stmt;
-                                    end if;
-
-                                    declare
-                                       HSS : constant Node_Id :=
-                                         Handled_Statement_Sequence
-                                           (Block_Stmt);
-                                    begin
-                                       Prepend (Prepended_Stmt,
-                                                Statements (HSS));
-
-                                       Set_Analyzed (Block_Stmt, False);
-                                       Set_Analyzed (HSS, False);
-                                    end;
-                                 end;
+                                 Finish_Binding_Object_Declaration
+                                   (Component_Assoc => Component_Assoc,
+                                    Subobject => Subobject);
                               end if;
 
                               Next (Choice);
diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
index 1bd267016d9..eb592c49f62 100644
--- a/gcc/ada/sem_case.adb
+++ b/gcc/ada/sem_case.adb
@@ -1991,6 +1991,154 @@ package body Sem_Case is
             procedure Check_Bindings
             is
                use Case_Bindings_Table;
+
+               function Binding_Subtype (Idx : Binding_Index;
+                                         Tab : Table_Type)
+                 return Entity_Id is
+                 (Etype (Nlists.First (Choices (Tab (Idx).Comp_Assoc))));
+
+               procedure Declare_Binding_Objects
+                  (Alt_Start             : Binding_Index;
+                   Alt                   : Node_Id;
+                   First_Choice_Bindings : Natural;
+                   Tab                   : Table_Type);
+               --  Declare the binding objects for a given alternative
+
+               ------------------------------
+               --  Declare_Binding_Objects --
+               ------------------------------
+
+               procedure Declare_Binding_Objects
+                  (Alt_Start             : Binding_Index;
+                   Alt                   : Node_Id;
+                   First_Choice_Bindings : Natural;
+                   Tab                   : Table_Type)
+               is
+                  Loc : constant Source_Ptr := Sloc (Alt);
+                  Declarations : constant List_Id := New_List;
+                  Decl         : Node_Id;
+                  Obj_Type     : Entity_Id;
+                  Def_Id       : Entity_Id;
+               begin
+                  for FC_Idx in Alt_Start ..
+                    Alt_Start + Binding_Index (First_Choice_Bindings - 1)
+                  loop
+                     Obj_Type := Binding_Subtype (FC_Idx, Tab);
+                     Def_Id := Make_Defining_Identifier
+                                 (Loc,
+                                  Binding_Chars (Tab (FC_Idx).Comp_Assoc));
+
+                     --  Either make a copy or rename the original. At a
+                     --  minimum, we do not want a copy if it would need
+                     --  finalization. Copies may also introduce problems
+                     --  if default init can have side effects (although we
+                     --  could suppress such default initialization).
+                     --  We have to make a copy in any cases where
+                     --  Unrestricted_Access doesn't work.
+                     --
+                     --  This is where the copy-or-rename decision is made.
+                     --  In many cases either way would work and so we have
+                     --  some flexibility here.
+
+                     if not Is_By_Copy_Type (Obj_Type) then
+                        --  Generate
+                        --     type Ref
+                        --       is access constant Obj_Type;
+                        --     Ptr : Ref := <some bogus value>;
+                        --     Obj : Obj_Type renames Ptr.all;
+                                       --
+                        --  Initialization of Ptr will be generated later
+                        --  during expansion.
+
+                        declare
+                           Ptr_Type : constant Entity_Id :=
+                             Make_Temporary (Loc, 'P');
+
+                           Ptr_Type_Def : constant Node_Id :=
+                             Make_Access_To_Object_Definition (Loc,
+                               All_Present => True,
+                               Subtype_Indication =>
+                                 New_Occurrence_Of (Obj_Type, Loc));
+
+                           Ptr_Type_Decl : constant Node_Id :=
+                             Make_Full_Type_Declaration (Loc,
+                               Ptr_Type,
+                               Type_Definition => Ptr_Type_Def);
+
+                           Ptr_Obj : constant Entity_Id :=
+                             Make_Temporary (Loc, 'T');
+
+                           --  We will generate initialization code for this
+                           --  object later (during expansion) but in the
+                           --  meantime we don't want the dereference that
+                           --  is generated a few lines below here to be
+                           --  transformed into a Raise_C_E. To prevent this,
+                           --  we provide a bogus initial value here; this
+                           --  initial value will be removed later during
+                           --  expansion.
+
+                           Ptr_Obj_Decl : constant Node_Id :=
+                             Make_Object_Declaration
+                               (Loc, Ptr_Obj,
+                                Object_Definition =>
+                                  New_Occurrence_Of (Ptr_Type, Loc),
+                                Expression =>
+                                  Unchecked_Convert_To
+                                    (Ptr_Type,
+                                     Make_Integer_Literal (Loc, 5432)));
+                        begin
+                           Mutate_Ekind (Ptr_Type, E_Access_Type);
+
+                           --  in effect, Storage_Size => 0
+                           Set_No_Pool_Assigned (Ptr_Type);
+
+                           Set_Is_Access_Constant (Ptr_Type);
+
+                           --  We could set Ptr_Type'Alignment here if that
+                           --  ever turns out to be needed for renaming a
+                           --  misaligned subcomponent.
+
+                           Mutate_Ekind (Ptr_Obj, E_Variable);
+                           Set_Etype (Ptr_Obj, Ptr_Type);
+
+                           Decl :=
+                             Make_Object_Renaming_Declaration
+                               (Loc, Def_Id,
+                                Subtype_Mark =>
+                                  New_Occurrence_Of (Obj_Type, Loc),
+                                Name =>
+                                  Make_Explicit_Dereference
+                                    (Loc, New_Occurrence_Of (Ptr_Obj, Loc)));
+
+                           Append_To (Declarations, Ptr_Type_Decl);
+                           Append_To (Declarations, Ptr_Obj_Decl);
+                        end;
+                     else
+                        Decl := Make_Object_Declaration
+                          (Sloc => Loc,
+                           Defining_Identifier => Def_Id,
+                           Object_Definition =>
+                              New_Occurrence_Of (Obj_Type, Loc));
+                     end if;
+                     Append_To (Declarations, Decl);
+                  end loop;
+
+                  declare
+                     Old_Statements : constant List_Id := Statements (Alt);
+                     New_Statements : constant List_Id := New_List;
+
+                     Block_Statement : constant Node_Id :=
+                       Make_Block_Statement (Sloc => Loc,
+                         Declarations => Declarations,
+                         Handled_Statement_Sequence =>
+                           Make_Handled_Sequence_Of_Statements
+                             (Loc, Old_Statements),
+                         Has_Created_Identifier => True);
+                  begin
+                     Append_To (New_Statements, Block_Statement);
+                     Set_Statements (Alt, New_Statements);
+                  end;
+               end Declare_Binding_Objects;
             begin
                if Last = 0 then
                   --  no bindings to check
@@ -2005,10 +2153,6 @@ package body Sem_Case is
                     return Boolean is (
                     Binding_Chars (Tab (Idx1).Comp_Assoc) =
                     Binding_Chars (Tab (Idx2).Comp_Assoc));
-
-                  function Binding_Subtype (Idx : Binding_Index)
-                    return Entity_Id is
-                    (Etype (Nlists.First (Choices (Tab (Idx).Comp_Assoc))));
                begin
                   --  Verify that elements with given choice or alt value
                   --  are contiguous, and that elements with equal
@@ -2172,8 +2316,8 @@ package body Sem_Case is
                                     loop
                                        if Same_Id (Idx2, FC_Idx) then
                                           if not Subtypes_Statically_Match
-                                            (Binding_Subtype (Idx2),
-                                             Binding_Subtype (FC_Idx))
+                                            (Binding_Subtype (Idx2, Tab),
+                                             Binding_Subtype (FC_Idx, Tab))
                                           then
                                              Error_Msg_N
                                                ("subtype of binding in "
@@ -2228,50 +2372,12 @@ package body Sem_Case is
                            --  the current alternative. Then analyze them.
 
                            if First_Choice_Bindings > 0 then
-                              declare
-                                 Loc : constant Source_Ptr := Sloc (Alt);
-                                 Declarations : constant List_Id := New_List;
-                                 Decl         : Node_Id;
-                              begin
-                                 for FC_Idx in
-                                   Alt_Start ..
-                                   Alt_Start +
-                                     Binding_Index (First_Choice_Bindings - 1)
-                                 loop
-                                    Decl := Make_Object_Declaration
-                                      (Sloc => Loc,
-                                       Defining_Identifier =>
-                                         Make_Defining_Identifier
-                                           (Loc,
-                                            Binding_Chars
-                                              (Tab (FC_Idx).Comp_Assoc)),
-                                        Object_Definition =>
-                                          New_Occurrence_Of
-                                            (Binding_Subtype (FC_Idx), Loc));
-
-                                    Append_To (Declarations, Decl);
-                                 end loop;
-
-                                 declare
-                                    Old_Statements : constant List_Id :=
-                                      Statements (Alt);
-                                    New_Statements : constant List_Id :=
-                                      New_List;
-
-                                    Block_Statement : constant Node_Id :=
-                                      Make_Block_Statement (Sloc => Loc,
-                                        Declarations => Declarations,
-                                        Handled_Statement_Sequence =>
-                                          Make_Handled_Sequence_Of_Statements
-                                            (Loc, Old_Statements),
-                                        Has_Created_Identifier => True);
-                                 begin
-                                    Append_To
-                                      (New_Statements, Block_Statement);
-
-                                    Set_Statements (Alt, New_Statements);
-                                 end;
-                              end;
+                              Declare_Binding_Objects
+                                (Alt_Start             => Alt_Start,
+                                 Alt                   => Alt,
+                                 First_Choice_Bindings =>
+                                   First_Choice_Bindings,
+                                 Tab                   => Tab);
                            end if;
                         end;
                      end if;
@@ -3361,11 +3467,32 @@ package body Sem_Case is
          begin
             if not Is_Composite_Type (Subtyp) then
                Error_Msg_N
-                 ("case selector type neither discrete nor composite", N);
+                 ("case selector type must be discrete or composite", N);
             elsif Is_Limited_Type (Subtyp) then
-               Error_Msg_N ("case selector type is limited", N);
+               Error_Msg_N ("case selector type must not be limited", N);
             elsif Is_Class_Wide_Type (Subtyp) then
-               Error_Msg_N ("case selector type is class-wide", N);
+               Error_Msg_N ("case selector type must not be class-wide", N);
+            elsif Needs_Finalization (Subtyp)
+              and then Is_Newly_Constructed
+                         (Expression (N), Context_Requires_NC => False)
+            then
+               --  We could allow this case as long as there are no bindings.
+               --
+               --  If there are bindings, then allowing this case will get
+               --  messy because the selector expression will be finalized
+               --  before the statements of the selected alternative are
+               --  executed (unless we add an INOX-specific change to the
+               --  accessibility rules to prevent this earlier-than-wanted
+               --  finalization, but adding new INOX-specific accessibility
+               --  complexity is probably not the direction we want to go).
+               --  This early selector finalization would be ok if we made
+               --  copies in this case (so that the bindings would not yield
+               --  a view of a finalized object), but then we'd have to deal
+               --  with finalizing those copies (which would necessarily
+               --  include defining their accessibility level). So it gets
+               --  messy either way.
+
+               Error_Msg_N ("case selector must not require finalization", N);
             end if;
          end Check_Composite_Case_Selector;
 
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 77302924e11..2f5070a9789 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -18426,6 +18426,117 @@ package body Sem_Util is
       end case;
    end Is_Name_Reference;
 
+   --------------------------
+   -- Is_Newly_Constructed --
+   --------------------------
+
+   function Is_Newly_Constructed
+     (Exp : Node_Id; Context_Requires_NC : Boolean) return Boolean
+   is
+      Original_Exp : constant Node_Id := Original_Node (Exp);
+
+      function Is_NC (Exp : Node_Id) return Boolean is
+        (Is_Newly_Constructed (Exp, Context_Requires_NC));
+
+      --  If the context requires that the expression shall be newly
+      --  constructed, then "True" is a good result in the sense that the
+      --  expression satisfies the requirements of the context (and "False"
+      --  is analogously a bad result). If the context requires that the
+      --  expression shall *not* be newly constructed, then things are
+      --  reversed: "False" is the good value and "True" is the bad value.
+
+      Good_Result : constant Boolean := Context_Requires_NC;
+      Bad_Result  : constant Boolean := not Good_Result;
+   begin
+      case Nkind (Original_Exp) is
+         when N_Aggregate
+            | N_Extension_Aggregate
+            | N_Function_Call
+            | N_Op
+         =>
+            return True;
+
+         when N_Identifier =>
+            return Present (Entity (Original_Exp))
+              and then Ekind (Entity (Original_Exp)) = E_Function;
+
+         when N_Qualified_Expression =>
+            return Is_NC (Expression (Original_Exp));
+
+         when N_Type_Conversion
+            | N_Unchecked_Type_Conversion
+         =>
+            if Is_View_Conversion (Original_Exp) then
+               return Is_NC (Expression (Original_Exp));
+            elsif not Comes_From_Source (Exp) then
+               if Exp /= Original_Exp then
+                  return Is_NC (Original_Exp);
+               else
+                  return Is_NC (Expression (Original_Exp));
+               end if;
+            else
+               return False;
+            end if;
+
+         when N_Explicit_Dereference
+            | N_Indexed_Component
+            | N_Selected_Component
+         =>
+            return Nkind (Exp) = N_Function_Call;
+
+         --  A use of 'Input is a function call, hence allowed. Normally the
+         --  attribute will be changed to a call, but the attribute by itself
+         --  can occur with -gnatc.
+
+         when N_Attribute_Reference =>
+            return Attribute_Name (Original_Exp) = Name_Input;
+
+         --  "return raise ..." is OK
+
+         when N_Raise_Expression =>
+            return Good_Result;
+
+         --  For a case expression, all dependent expressions must be legal
+
+         when N_Case_Expression =>
+            declare
+               Alt : Node_Id;
+
+            begin
+               Alt := First (Alternatives (Original_Exp));
+               while Present (Alt) loop
+                  if Is_NC (Expression (Alt)) = Bad_Result then
+                     return Bad_Result;
+                  end if;
+
+                  Next (Alt);
+               end loop;
+
+               return Good_Result;
+            end;
+
+         --  For an if expression, all dependent expressions must be legal
+
+         when N_If_Expression =>
+            declare
+               Then_Expr : constant Node_Id :=
+                             Next (First (Expressions (Original_Exp)));
+               Else_Expr : constant Node_Id := Next (Then_Expr);
+            begin
+               if (Is_NC (Then_Expr) = Bad_Result)
+                 or else (Is_NC (Else_Expr) = Bad_Result)
+               then
+                  return Bad_Result;
+               else
+                  return Good_Result;
+               end if;
+            end;
+
+         when others =>
+            return False;
+      end case;
+   end Is_Newly_Constructed;
+
    ------------------------------------
    -- Is_Non_Preelaborable_Construct --
    ------------------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index e251f1ad9fc..2878fce80ff 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1521,6 +1521,25 @@ package Sem_Util is
    --  integer for use in compile-time checking. Note: Level is restricted to
    --  be non-dynamic.
 
+   function Is_Newly_Constructed
+     (Exp : Node_Id; Context_Requires_NC : Boolean) return Boolean;
+   --  Indicates whether a given expression is "newly constructed" (RM 4.4).
+   --  Context_Requires_NC determines the result returned for cases like a
+   --  raise expression or a conditional expression where some-but-not-all
+   --  operative constituents are newly constructed. Thus, this is a
+   --  somewhat unusual predicate in that the result required in order to
+   --  satisfy whatever legality rule is being checked can influence the
+   --  result of the predicate. Context_Requires_NC might be True for
+   --  something like the "newly constructed" rule for a limited expression
+   --  of a return statement, and False for something like the
+   --  "newly constructed" rule pertaining to a limited object renaming in a
+   --  declare expression. Eventually, the code to implement every
+   --  RM legality rule requiring/prohibiting a "newly constructed" expression
+   --  should be implemented by calling this function; that's not done yet.
+   --  The function name doesn't quite match the RM definition of the term if
+   --  Context_Requires_NC = False; in that case, "Might_Be_Newly_Constructed"
+   --  might be a more accurate name.
+
    function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
      (Subp : Entity_Id) return Boolean;
    --  Return True if Subp is a primitive of an abstract type, where the


^ permalink raw reply	[flat|nested] only message in thread

only message in thread, other threads:[~2021-12-01 10:26 UTC | newest]

Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-12-01 10:26 [gcc r12-5675] [Ada] Improve support for casing on types with controlled parts Pierre-Marie de Rodat

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).