diff options
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 198 | ||||
| -rw-r--r-- | gcc/ada/sem_case.adb | 233 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 111 | ||||
| -rw-r--r-- | 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 47c6b80..42cffd5 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 1bd2670..eb592c4 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 7730292..2f5070a 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 e251f1a..2878fce 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 |