From 0d95edd38ff9580c1b1a1a74bf3e0b27a123ad3e Mon Sep 17 00:00:00 2001 From: Viljar Indus Date: Tue, 23 Sep 2025 12:40:26 +0300 Subject: [PATCH] ada: Catch Constraint_Errors on non-scalar streaming attributes The specs for the streaming methods should use the first subtype of the prefix attribute for the Item argument if the prefix has a non-scalar type instead of the underlying type. This will catch size errors for is smaller size are used for the Item argument that has a constrained derived type. Additionally remove additional casts applied for the Input attribute that convert the result to the prefix type. This cast is only necessary for converting the result if the Input attribute is used on a classwide type. gcc/ada/ChangeLog: * exp_attr.adb (Expand_N_Attribute_Reference): Use the First_Subtype when creating the procedure for stream attributes. (Get_Array_Stream_Item_Type): New method for calculating the type for the Item argument for streaming methods. --- gcc/ada/exp_attr.adb | 41 ++++++++++++++++++++++++++++++++--------- 1 file changed, 32 insertions(+), 9 deletions(-) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index a0a550ddbd7..a2b891b3307 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1906,6 +1906,9 @@ package body Exp_Attr is function Get_Integer_Type (Typ : Entity_Id) return Entity_Id; -- Return a small integer type appropriate for the enumeration type + function Get_Array_Stream_Item_Type (Typ : Entity_Id) return Entity_Id; + -- For non-scalar types return the first subtype of Typ. + procedure Rewrite_Attribute_Proc_Call (Pname : Entity_Id); -- Rewrites an attribute for Read, Write, Output, or Put_Image with a -- call to the appropriate TSS procedure. Pname is the entity for the @@ -2066,6 +2069,19 @@ package body Exp_Attr is return Small_Integer_Type_For (Siz, Uns => Is_Unsigned_Type (Typ)); end Get_Integer_Type; + -------------------------------- + -- Get_Array_Stream_Item_Type -- + -------------------------------- + + function Get_Array_Stream_Item_Type (Typ : Entity_Id) return Entity_Id is + First_Sub_Typ : constant Entity_Id := First_Subtype (Typ); + begin + if Is_Private_Type (First_Sub_Typ) then + return Typ; + end if; + return First_Sub_Typ; + end Get_Array_Stream_Item_Type; + --------------------------------- -- Rewrite_Attribute_Proc_Call -- --------------------------------- @@ -4482,6 +4498,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); + I_Type : Entity_Id := P_Type; Strm : constant Node_Id := First (Exprs); Fname : Entity_Id; Decl : Node_Id; @@ -4633,8 +4650,9 @@ package body Exp_Attr is new Build_And_Insert_Type_Attr_Subp (Build_Array_Input_Function); begin + I_Type := Get_Array_Stream_Item_Type (U_Type); Build_And_Insert_Array_Input_Func - (Typ => Full_Base (U_Type), + (Typ => I_Type, Decl => Decl, Subp => Fname, Attr_Ref => N); @@ -4784,8 +4802,13 @@ package body Exp_Attr is Relocate_Node (Strm))); Set_Controlling_Argument (Call, Cntrl); - Rewrite (N, Unchecked_Convert_To (P_Type, Call)); - Analyze_And_Resolve (N, P_Type); + if Is_Private_Type (P_Type) or else Is_Class_Wide_Type (P_Type) then + Rewrite (N, Unchecked_Convert_To (P_Type, Call)); + Analyze_And_Resolve (N, P_Type); + else + Rewrite (N, Call); + Analyze_And_Resolve (N, I_Type); + end if; if Nkind (Parent (N)) = N_Object_Declaration then Freeze_Stream_Subprogram (Fname); @@ -5818,7 +5841,7 @@ package body Exp_Attr is (Build_Array_Output_Procedure); begin Build_And_Insert_Array_Output_Proc - (Typ => Full_Base (U_Type), + (Typ => Get_Array_Stream_Item_Type (U_Type), Decl => Decl, Subp => Pname, Attr_Ref => N); @@ -6295,10 +6318,10 @@ package body Exp_Attr is begin Build_And_Insert_Array_Put_Image_Proc - (Typ => U_Type, + (Typ => Get_Array_Stream_Item_Type (U_Type), Decl => Decl, - Subp => Pname, - Attr_Ref => N); + Subp => Pname, + Attr_Ref => N); end; Cached_Attribute_Ops.Put_Image_Map.Set (U_Type, Pname); @@ -6746,7 +6769,7 @@ package body Exp_Attr is (Build_Array_Read_Procedure); begin Build_And_Insert_Array_Read_Proc - (Typ => Full_Base (U_Type), + (Typ => Get_Array_Stream_Item_Type (U_Type), Decl => Decl, Subp => Pname, Attr_Ref => N); @@ -8461,7 +8484,7 @@ package body Exp_Attr is (Build_Array_Write_Procedure); begin Build_And_Insert_Array_Write_Proc - (Typ => Full_Base (U_Type), + (Typ => Get_Array_Stream_Item_Type (U_Type), Decl => Decl, Subp => Pname, Attr_Ref => N); -- 2.47.3