diff options
Diffstat (limited to 'gcc/ada/exp_attr.adb')
| -rw-r--r-- | gcc/ada/exp_attr.adb | 404 |
1 files changed, 262 insertions, 142 deletions
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 4f9f16c..810248d 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1915,6 +1915,15 @@ package body Exp_Attr is -- call to the appropriate TSS procedure. Pname is the entity for the -- procedure to call. + procedure Read_Controlling_Tag + (P_Type : Entity_Id; Cntrl : out Node_Id); + -- Read the external tag from the stream and use it to construct the + -- controlling operand for a dispatching call. + + procedure Write_Controlling_Tag (P_Type : Entity_Id); + -- Write the external tag of the given attribute prefix type to + -- the stream. Also perform the accompanying accessibility check. + ------------------------------------- -- Build_And_Insert_Type_Attr_Subp -- ------------------------------------- @@ -2175,6 +2184,153 @@ package body Exp_Attr is Analyze (N); end Rewrite_Attribute_Proc_Call; + -------------------------- + -- Read_Controlling_Tag -- + -------------------------- + + procedure Read_Controlling_Tag + (P_Type : Entity_Id; Cntrl : out Node_Id) + is + Strm : constant Node_Id := First (Exprs); + Expr : Node_Id; -- call to Descendant_Tag + Get_Tag : Node_Id; -- expression to read the 'Tag + + begin + -- Read the internal tag (RM 13.13.2(34)) and use it to + -- initialize a dummy tag value. We used to unconditionally + -- generate: + -- + -- Descendant_Tag (String'Input (Strm), P_Type); + -- + -- which turns into a call to String_Input_Blk_IO. However, + -- if the input is malformed, that could try to read an + -- enormous String, causing chaos. So instead we call + -- String_Input_Tag, which does the same thing as + -- String_Input_Blk_IO, except that if the String is + -- absurdly long, it raises an exception. + -- + -- However, if the No_Stream_Optimizations restriction + -- is active, we disable this unnecessary attempt at + -- robustness; we really need to read the string + -- character-by-character. + -- + -- This value is used only to provide a controlling + -- argument for the eventual _Input call. Descendant_Tag is + -- called rather than Internal_Tag to ensure that we have a + -- tag for a type that is descended from the prefix type and + -- declared at the same accessibility level (the exception + -- Tag_Error will be raised otherwise). The level check is + -- required for Ada 2005 because tagged types can be + -- extended in nested scopes (AI-344). + + -- Note: we used to generate an explicit declaration of a + -- constant Ada.Tags.Tag object, and use an occurrence of + -- this constant in Cntrl, but this caused a secondary stack + -- leak. + + if Restriction_Active (No_Stream_Optimizations) then + Get_Tag := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_String, Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Relocate_Node (Duplicate_Subexpr (Strm)))); + else + Get_Tag := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_String_Input_Tag), Loc), + Parameter_Associations => New_List ( + Relocate_Node (Duplicate_Subexpr (Strm)))); + end if; + + Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), + Parameter_Associations => New_List ( + Get_Tag, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (P_Type, Loc), + Attribute_Name => Name_Tag))); + + Set_Etype (Expr, RTE (RE_Tag)); + + -- Construct a controlling operand for a dispatching call. + + Cntrl := Unchecked_Convert_To (P_Type, Expr); + Set_Etype (Cntrl, P_Type); + Set_Parent (Cntrl, N); + end Read_Controlling_Tag; + + ---------------------------- + -- Write_Controlling_Tag -- + ---------------------------- + + procedure Write_Controlling_Tag (P_Type : Entity_Id) is + Strm : constant Node_Id := First (Exprs); + Item : constant Node_Id := Next (Strm); + begin + -- Ada 2005 (AI-344): Check that the accessibility level + -- of the type of the output object is not deeper than + -- that of the attribute's prefix type. + + -- if Get_Access_Level (Item'Tag) + -- /= Get_Access_Level (P_Type'Tag) + -- then + -- raise Tag_Error; + -- end if; + + -- String'Output (Strm, External_Tag (Item'Tag)); + + -- We cannot figure out a practical way to implement this + -- accessibility check on virtual machines, so we omit it. + + if Ada_Version >= Ada_2005 + and then Tagged_Type_Expansion + then + Insert_Action (N, + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Build_Get_Access_Level (Loc, + Make_Attribute_Reference (Loc, + Prefix => + Relocate_Node ( + Duplicate_Subexpr (Item, + Name_Req => True)), + Attribute_Name => Name_Tag)), + + Right_Opnd => + Make_Integer_Literal (Loc, + Type_Access_Level (P_Type))), + + Then_Statements => + New_List (Make_Raise_Statement (Loc, + New_Occurrence_Of ( + RTE (RE_Tag_Error), Loc))))); + end if; + + Insert_Action (N, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_String, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Relocate_Node (Duplicate_Subexpr (Strm)), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_External_Tag), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Relocate_Node + (Duplicate_Subexpr (Item, Name_Req => True)), + Attribute_Name => Name_Tag)))))); + end Write_Controlling_Tag; + Typ : constant Entity_Id := Etype (N); Btyp : constant Entity_Id := Base_Type (Typ); Ptyp : constant Entity_Id := Etype (Pref); @@ -4487,94 +4643,57 @@ package body Exp_Attr is elsif Is_Class_Wide_Type (P_Type) then - -- No need to do anything else compiling under restriction - -- No_Dispatching_Calls. During the semantic analysis we - -- already notified such violation. + if Is_Mutably_Tagged_Type (P_Type) then - if Restriction_Active (No_Dispatching_Calls) then - return; - end if; + -- In mutably tagged case, rewrite + -- T'Class'Input (Strm) + -- as (roughly) + -- declare + -- Result : T'Class; + -- T'Class'Read (Strm, Result); + -- begin + -- Result; + -- end; - declare - Rtyp : constant Entity_Id := Root_Type (P_Type); + declare + Result_Temp : constant Entity_Id := + Make_Temporary (Loc, 'I'); - Expr : Node_Id; -- call to Descendant_Tag - Get_Tag : Node_Id; -- expression to read the 'Tag + -- Gets default initialization + Result_Temp_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Temp, + Object_Definition => + New_Occurrence_Of (P_Type, Loc)); - begin - -- Read the internal tag (RM 13.13.2(34)) and use it to - -- initialize a dummy tag value. We used to unconditionally - -- generate: - -- - -- Descendant_Tag (String'Input (Strm), P_Type); - -- - -- which turns into a call to String_Input_Blk_IO. However, - -- if the input is malformed, that could try to read an - -- enormous String, causing chaos. So instead we call - -- String_Input_Tag, which does the same thing as - -- String_Input_Blk_IO, except that if the String is - -- absurdly long, it raises an exception. - -- - -- However, if the No_Stream_Optimizations restriction - -- is active, we disable this unnecessary attempt at - -- robustness; we really need to read the string - -- character-by-character. - -- - -- This value is used only to provide a controlling - -- argument for the eventual _Input call. Descendant_Tag is - -- called rather than Internal_Tag to ensure that we have a - -- tag for a type that is descended from the prefix type and - -- declared at the same accessibility level (the exception - -- Tag_Error will be raised otherwise). The level check is - -- required for Ada 2005 because tagged types can be - -- extended in nested scopes (AI-344). - - -- Note: we used to generate an explicit declaration of a - -- constant Ada.Tags.Tag object, and use an occurrence of - -- this constant in Cntrl, but this caused a secondary stack - -- leak. - - if Restriction_Active (No_Stream_Optimizations) then - Get_Tag := - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Standard_String, Loc), - Attribute_Name => Name_Input, - Expressions => New_List ( - Relocate_Node (Duplicate_Subexpr (Strm)))); - else - Get_Tag := - Make_Function_Call (Loc, - Name => - New_Occurrence_Of - (RTE (RE_String_Input_Tag), Loc), - Parameter_Associations => New_List ( - Relocate_Node (Duplicate_Subexpr (Strm)))); - end if; + function Result_Temp_Name return Node_Id is + (New_Occurrence_Of (Result_Temp, Loc)); - Expr := - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc), - Parameter_Associations => New_List ( - Get_Tag, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (P_Type, Loc), - Attribute_Name => Name_Tag))); + Actions : constant List_Id := New_List ( + Result_Temp_Decl, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (P_Type, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Relocate_Node (Strm), Result_Temp_Name))); + begin + Rewrite (N, Make_Expression_With_Actions (Loc, + Actions, Result_Temp_Name)); + Analyze_And_Resolve (N, P_Type); + return; + end; + end if; - Set_Etype (Expr, RTE (RE_Tag)); + -- No need to do anything else compiling under restriction + -- No_Dispatching_Calls. During the semantic analysis we + -- already notified such violation. - -- Now we need to get the entity for the call, and construct - -- a function call node, where we preset a reference to Dnn - -- as the controlling argument (doing an unchecked convert - -- to the class-wide tagged type to make it look like a real - -- tagged object). + if Restriction_Active (No_Dispatching_Calls) then + return; + end if; - Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input); - Cntrl := Unchecked_Convert_To (P_Type, Expr); - Set_Etype (Cntrl, P_Type); - Set_Parent (Cntrl, N); - end; + Read_Controlling_Tag (P_Type, Cntrl); + Fname := Find_Prim_Op (Root_Type (P_Type), TSS_Stream_Input); -- For tagged types, use the primitive Input function @@ -5957,6 +6076,14 @@ package body Exp_Attr is Attr_Ref => N); end; + -- In the mutably tagged case, T'Class'Output calls T'Class'Write; + -- T'Write will take care of writing out the external tag. + + elsif Is_Mutably_Tagged_Type (P_Type) then + Set_Attribute_Name (N, Name_Write); + Analyze (N); + return; + -- Class-wide case, first output external tag, then dispatch -- to the appropriate primitive Output function (RM 13.13.2(31)). @@ -5970,68 +6097,7 @@ package body Exp_Attr is return; end if; - Tag_Write : declare - Strm : constant Node_Id := First (Exprs); - Item : constant Node_Id := Next (Strm); - - begin - -- Ada 2005 (AI-344): Check that the accessibility level - -- of the type of the output object is not deeper than - -- that of the attribute's prefix type. - - -- if Get_Access_Level (Item'Tag) - -- /= Get_Access_Level (P_Type'Tag) - -- then - -- raise Tag_Error; - -- end if; - - -- String'Output (Strm, External_Tag (Item'Tag)); - - -- We cannot figure out a practical way to implement this - -- accessibility check on virtual machines, so we omit it. - - if Ada_Version >= Ada_2005 - and then Tagged_Type_Expansion - then - Insert_Action (N, - Make_Implicit_If_Statement (N, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => - Build_Get_Access_Level (Loc, - Make_Attribute_Reference (Loc, - Prefix => - Relocate_Node ( - Duplicate_Subexpr (Item, - Name_Req => True)), - Attribute_Name => Name_Tag)), - - Right_Opnd => - Make_Integer_Literal (Loc, - Type_Access_Level (P_Type))), - - Then_Statements => - New_List (Make_Raise_Statement (Loc, - New_Occurrence_Of ( - RTE (RE_Tag_Error), Loc))))); - end if; - - Insert_Action (N, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Standard_String, Loc), - Attribute_Name => Name_Output, - Expressions => New_List ( - Relocate_Node (Duplicate_Subexpr (Strm)), - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_External_Tag), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - Relocate_Node - (Duplicate_Subexpr (Item, Name_Req => True)), - Attribute_Name => Name_Tag)))))); - end Tag_Write; + Write_Controlling_Tag (P_Type); Pname := Find_Prim_Op (U_Type, TSS_Stream_Output); @@ -6793,6 +6859,7 @@ package body Exp_Attr is P_Type : constant Entity_Id := Entity (Pref); B_Type : constant Entity_Id := Base_Type (P_Type); U_Type : constant Entity_Id := Underlying_Type (P_Type); + Cntrl : Node_Id := Empty; -- nonempty only if P_Type mutably tagged Pname : Entity_Id; Decl : Node_Id; Prag : Node_Id; @@ -6941,6 +7008,11 @@ package body Exp_Attr is -- this will dispatch in the class-wide case which is what we want elsif Is_Tagged_Type (U_Type) then + + if Is_Mutably_Tagged_Type (U_Type) then + Read_Controlling_Tag (P_Type, Cntrl); + end if; + Pname := Find_Prim_Op (U_Type, TSS_Stream_Read); -- All other record type cases, including protected records. The @@ -7001,6 +7073,46 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); + if Present (Cntrl) then + pragma Assert (Is_Mutably_Tagged_Type (U_Type)); + pragma Assert (Nkind (N) = N_Procedure_Call_Statement); + + -- Assign the Tag value that was read from the stream + -- to the tag of the out-mode actual parameter so that + -- we dispatch correctly. This isn't quite right. + -- We should assign a complete object (not just + -- the tag), but that would require a dispatching call to + -- perform default initialization of the source object and + -- dispatching default init calls are currently not supported. + + declare + function Select_Tag (Prefix : Node_Id) return Node_Id is + (Make_Selected_Component (Loc, + Prefix => Prefix, + Selector_Name => + New_Occurrence_Of (First_Tag_Component + (Etype (Prefix)), Loc))); + + Controlling_Actual : constant Node_Id := + Next (First (Parameter_Associations (N))); + + pragma Assert (Is_Controlling_Actual (Controlling_Actual)); + + Assign_Tag : Node_Id; + begin + Remove_Side_Effects (Controlling_Actual, Name_Req => True); + + Assign_Tag := + Make_Assignment_Statement (Loc, + Name => + Select_Tag (New_Copy_Tree (Controlling_Actual)), + Expression => Select_Tag (Cntrl)); + + Insert_Before (Before => N, Node => Assign_Tag); + Analyze (Assign_Tag); + end; + end if; + if not Is_Tagged_Type (P_Type) then Cached_Attribute_Ops.Read_Map.Set (U_Type, Pname); end if; @@ -8611,6 +8723,14 @@ package body Exp_Attr is -- this will dispatch in the class-wide case which is what we want elsif Is_Tagged_Type (U_Type) then + + -- If T'Class is mutably tagged, then the external tag + -- is written out by T'Class'Write, not by T'Class'Output. + + if Is_Mutably_Tagged_Type (U_Type) then + Write_Controlling_Tag (P_Type); + end if; + Pname := Find_Prim_Op (U_Type, TSS_Stream_Write); -- All other record type cases, including protected records. |