diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/aspects.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 260 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 37 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 15 |
6 files changed, 202 insertions, 129 deletions
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 658a859..6559cda 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -441,7 +441,7 @@ package Aspects is Aspect_SPARK_Mode => Optional_Name, Aspect_Stable_Properties => Expression, Aspect_Static_Predicate => Expression, - Aspect_Storage_Model_Type => Expression, + Aspect_Storage_Model_Type => Optional_Expression, Aspect_Storage_Pool => Name, Aspect_Storage_Size => Expression, Aspect_Stream_Size => Expression, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 8557e4b..3286bf6 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6406,16 +6406,7 @@ package body Exp_Util is begin if Has_Storage_Model_Type_Aspect (Typ) then - declare - SMT_Op : constant Entity_Id := - Get_Storage_Model_Type_Entity (Typ, Nam); - begin - if not Present (SMT_Op) then - raise Program_Error; - else - return SMT_Op; - end if; - end; + return Get_Storage_Model_Type_Entity (Typ, Nam); -- Otherwise we assume that Typ is a descendant of Root_Storage_Pool diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 1b7be3a..d854672 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -623,8 +623,10 @@ package Exp_Util is -- specifies aspect Storage_Model_Type, returns the Entity_Id of the -- subprogram associated with Nam, which must either be a primitive op of -- the type in the case of a storage pool, or the operation corresponding - -- to Nam as specified in the aspect Storage_Model_Type. It is an error if - -- no operation corresponding to the given name is found. + -- to Nam as specified in the aspect Storage_Model_Type. In the case of + -- aspect Storage_Model_Type, returns Empty when no operation is found, + -- indicating that the operation is defaulted in the aspect (can occur in + -- the case where the storage-model address type is System.Address). function Find_Hook_Context (N : Node_Id) return Node_Id; -- Determine a suitable node on which to attach actions related to N that diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 7ea04a6..9c3ae6f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -23,59 +23,60 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; -with Atree; use Atree; -with Checks; use Checks; -with Contracts; use Contracts; -with Debug; use Debug; -with Einfo; use Einfo; -with Einfo.Entities; use Einfo.Entities; -with Einfo.Utils; use Einfo.Utils; -with Elists; use Elists; -with Errout; use Errout; -with Exp_Ch3; use Exp_Ch3; -with Exp_Disp; use Exp_Disp; -with Exp_Tss; use Exp_Tss; -with Exp_Util; use Exp_Util; -with Freeze; use Freeze; -with Ghost; use Ghost; -with Lib; use Lib; -with Lib.Xref; use Lib.Xref; -with Namet; use Namet; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Opt; use Opt; -with Par_SCO; use Par_SCO; -with Restrict; use Restrict; -with Rident; use Rident; -with Rtsfind; use Rtsfind; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Case; use Sem_Case; -with Sem_Cat; use Sem_Cat; -with Sem_Ch3; use Sem_Ch3; -with Sem_Ch6; use Sem_Ch6; -with Sem_Ch7; use Sem_Ch7; -with Sem_Ch8; use Sem_Ch8; -with Sem_Dim; use Sem_Dim; -with Sem_Eval; use Sem_Eval; -with Sem_Prag; use Sem_Prag; -with Sem_Res; use Sem_Res; -with Sem_Type; use Sem_Type; -with Sem_Util; use Sem_Util; -with Sem_Warn; use Sem_Warn; -with Sinfo; use Sinfo; -with Sinfo.Nodes; use Sinfo.Nodes; -with Sinfo.Utils; use Sinfo.Utils; -with Sinput; use Sinput; -with Snames; use Snames; -with Stand; use Stand; +with Aspects; use Aspects; +with Atree; use Atree; +with Checks; use Checks; +with Contracts; use Contracts; +with Debug; use Debug; +with Einfo; use Einfo; +with Einfo.Entities; use Einfo.Entities; +with Einfo.Utils; use Einfo.Utils; +with Elists; use Elists; +with Errout; use Errout; +with Exp_Ch3; use Exp_Ch3; +with Exp_Disp; use Exp_Disp; +with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Ghost; use Ghost; +with Lib; use Lib; +with Lib.Xref; use Lib.Xref; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Opt; use Opt; +with Par_SCO; use Par_SCO; +with Restrict; use Restrict; +with Rident; use Rident; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; +with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch7; use Sem_Ch7; +with Sem_Ch8; use Sem_Ch8; +with Sem_Dim; use Sem_Dim; +with Sem_Eval; use Sem_Eval; +with Sem_Prag; use Sem_Prag; +with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; +with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; +with Sinfo; use Sinfo; +with Sinfo.Nodes; use Sinfo.Nodes; +with Sinfo.Utils; use Sinfo.Utils; +with Sinput; use Sinput; +with Snames; use Snames; +with Stand; use Stand; +with System.Case_Util; use System.Case_Util; with Table; -with Targparm; use Targparm; -with Ttypes; use Ttypes; -with Tbuild; use Tbuild; -with Urealp; use Urealp; -with Warnsw; use Warnsw; +with Targparm; use Targparm; +with Ttypes; use Ttypes; +with Tbuild; use Tbuild; +with Urealp; use Urealp; +with Warnsw; use Warnsw; with GNAT.Heap_Sort_G; @@ -11356,6 +11357,16 @@ package body Sem_Ch13 is return; when Aspect_Storage_Model_Type => + + -- The aggregate argument of Storage_Model_Type is optional, and + -- when not present the aspect defaults to the native storage + -- model (where the address type is System.Address, and other + -- arguments default to corresponding native storage operations). + + if No (Expression (ASN)) then + return; + end if; + T := Entity (ASN); declare @@ -16559,12 +16570,14 @@ package body Sem_Ch13 is return; + -- If Addr_Type is not present as the first association, then we default + -- it to System.Address. + elsif not Present (Addr_Type) then - Error_Msg_N ("argument association for Address_Type missing; " - & "must be specified as first aspect argument", N); - return; + Addr_Type := RTE (RE_Address); + end if; - elsif Nam = Name_Null_Address then + if Nam = Name_Null_Address then if not Is_Entity_Name (N) or else not Is_Constant_Object (Entity (N)) or else @@ -17335,9 +17348,10 @@ package body Sem_Ch13 is procedure Validate_Storage_Model_Type_Aspect (Typ : Entity_Id; ASN : Node_Id) is - Assoc : Node_Id; - Choice : Entity_Id; - Expr : Node_Id; + Assoc : Node_Id; + Choice : Entity_Id; + Choice_Name : Name_Id; + Expr : Node_Id; Address_Type_Id : Entity_Id := Empty; Null_Address_Id : Entity_Id := Empty; @@ -17347,7 +17361,47 @@ package body Sem_Ch13 is Copy_To_Id : Entity_Id := Empty; Storage_Size_Id : Entity_Id := Empty; + procedure Check_And_Resolve_Storage_Model_Type_Argument + (Expr : Node_Id; + Typ : Entity_Id; + Argument_Id : in out Entity_Id; + Nam : Name_Id); + -- Checks that the subaspect for Nam has not already been specified for + -- Typ's Storage_Model_Type aspect (i.e., checks Argument_Id = Empty), + -- resolves Expr, and sets Argument_Id to the entity resolved for Expr. + + procedure Check_And_Resolve_Storage_Model_Type_Argument + (Expr : Node_Id; + Typ : Entity_Id; + Argument_Id : in out Entity_Id; + Nam : Name_Id) + is + Name_String : constant String := To_Mixed (Get_Name_String (Nam)); + + begin + if Present (Argument_Id) then + Error_Msg_String (1 .. Name_String'Length) := Name_String; + Error_Msg_Strlen := Name_String'Length; + + Error_Msg_N ("~ already specified", Expr); + end if; + + Resolve_Storage_Model_Type_Argument (Expr, Typ, Address_Type_Id, Nam); + Argument_Id := Entity (Expr); + end Check_And_Resolve_Storage_Model_Type_Argument; + + -- Start of processing for Validate_Storage_Model_Type_Aspect + begin + -- The aggregate argument of Storage_Model_Type is optional, and when + -- not present the aspect defaults to the native storage model (where + -- the address type is System.Address, and other arguments default to + -- the corresponding native storage operations). + + if No (Expression (ASN)) then + return; + end if; + -- Each expression must resolve to an entity of the right kind or proper -- profile. @@ -17358,65 +17412,67 @@ package body Sem_Ch13 is Choice := First (Choices (Assoc)); + Choice_Name := Chars (Choice); + if Nkind (Choice) /= N_Identifier or else Present (Next (Choice)) then Error_Msg_N ("illegal name in association", Choice); - elsif Chars (Choice) = Name_Address_Type then + elsif Choice_Name = Name_Address_Type then if Assoc /= First (Component_Associations (Expression (ASN))) then Error_Msg_N ("Address_Type must be first association", Choice); end if; - Resolve_Storage_Model_Type_Argument + Check_And_Resolve_Storage_Model_Type_Argument (Expr, Typ, Address_Type_Id, Name_Address_Type); - Address_Type_Id := Entity (Expr); - -- Shouldn't we check for duplicates of the same subaspect name, - -- and issue an error in such cases??? + else + -- It's allowed to leave out the Address_Type argument, in which + -- case the address type is defined to default to System.Address. - elsif not Present (Address_Type_Id) then - Error_Msg_N - ("Address_Type missing, must be first association", Choice); - - elsif Chars (Choice) = Name_Null_Address then - Resolve_Storage_Model_Type_Argument - (Expr, Typ, Address_Type_Id, Name_Null_Address); - Null_Address_Id := Entity (Expr); - - elsif Chars (Choice) = Name_Allocate then - Resolve_Storage_Model_Type_Argument - (Expr, Typ, Address_Type_Id, Name_Allocate); - Allocate_Id := Entity (Expr); - - elsif Chars (Choice) = Name_Deallocate then - Resolve_Storage_Model_Type_Argument - (Expr, Typ, Address_Type_Id, Name_Deallocate); - Deallocate_Id := Entity (Expr); - - elsif Chars (Choice) = Name_Copy_From then - Resolve_Storage_Model_Type_Argument - (Expr, Typ, Address_Type_Id, Name_Copy_From); - Copy_From_Id := Entity (Expr); - - elsif Chars (Choice) = Name_Copy_To then - Resolve_Storage_Model_Type_Argument - (Expr, Typ, Address_Type_Id, Name_Copy_To); - Copy_To_Id := Entity (Expr); - - elsif Chars (Choice) = Name_Storage_Size then - Resolve_Storage_Model_Type_Argument - (Expr, Typ, Address_Type_Id, Name_Storage_Size); - Storage_Size_Id := Entity (Expr); + if No (Address_Type_Id) then + Address_Type_Id := RTE (RE_Address); + end if; - else - Error_Msg_N - ("invalid name for Storage_Model_Type argument", Choice); + if Choice_Name = Name_Null_Address then + Check_And_Resolve_Storage_Model_Type_Argument + (Expr, Typ, Null_Address_Id, Name_Null_Address); + + elsif Choice_Name = Name_Allocate then + Check_And_Resolve_Storage_Model_Type_Argument + (Expr, Typ, Allocate_Id, Name_Allocate); + + elsif Choice_Name = Name_Deallocate then + Check_And_Resolve_Storage_Model_Type_Argument + (Expr, Typ, Deallocate_Id, Name_Deallocate); + + elsif Choice_Name = Name_Copy_From then + Check_And_Resolve_Storage_Model_Type_Argument + (Expr, Typ, Copy_From_Id, Name_Copy_From); + + elsif Choice_Name = Name_Copy_To then + Check_And_Resolve_Storage_Model_Type_Argument + (Expr, Typ, Copy_To_Id, Name_Copy_To); + + elsif Choice_Name = Name_Storage_Size then + Check_And_Resolve_Storage_Model_Type_Argument + (Expr, Typ, Storage_Size_Id, Name_Storage_Size); + + else + Error_Msg_N + ("invalid name for Storage_Model_Type argument", Choice); + end if; end if; Next (Assoc); end loop; - if No (Address_Type_Id) then - Error_Msg_N ("match for Address_Type not found", ASN); + -- If Address_Type has been specified as or defaults to System.Address, + -- then other "subaspect" arguments can be specified, but are optional. + -- Otherwise, all other arguments are required and an error is flagged + -- about any that are missing. + + if Address_Type_Id = RTE (RE_Address) then + return; elsif No (Null_Address_Id) then Error_Msg_N ("match for Null_Address primitive not found", ASN); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 854afdf..13ffb11 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -32575,18 +32575,37 @@ package body Sem_Util is Find_Value_Of_Aspect (Typ, Aspect_Storage_Model_Type); begin - pragma Assert (Present (SMT_Aspect_Value)); + -- When the aspect has an aggregate expression, search through it + -- to locate a match for the name of the given "subaspect" and return + -- the entity of the aggregate association's expression. + + if Present (SMT_Aspect_Value) then + Assoc := First (Component_Associations (SMT_Aspect_Value)); + while Present (Assoc) loop + if Chars (First (Choices (Assoc))) = Nam then + return Entity (Expression (Assoc)); + end if; - Assoc := First (Component_Associations (SMT_Aspect_Value)); - while Present (Assoc) loop - if Chars (First (Choices (Assoc))) = Nam then - return Entity (Expression (Assoc)); - end if; + Next (Assoc); + end loop; + end if; - Next (Assoc); - end loop; + -- The aggregate argument of Storage_Model_Type is optional, and when + -- not present the aspect defaults to the native storage model, where + -- the address type is System.Address. In that case, we return + -- System.Address for Name_Address_Type and System.Null_Address for + -- Name_Null_Address, but return Empty for other cases, and leave it + -- to the back end to map those to the appropriate native operations. - return Empty; + if Nam = Name_Address_Type then + return RTE (RE_Address); + + elsif Nam = Name_Null_Address then + return RTE (RE_Null_Address); + + else + return Empty; + end if; end Get_Storage_Model_Type_Entity; -------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 64cf5d0..dde5b27 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -3680,21 +3680,26 @@ package Sem_Util is -- Given a type with aspect Storage_Model_Type or an object of such a -- type, and Nam denoting the name of one of the argument kinds allowed -- for that aspect, returns the Entity_Id corresponding to the entity - -- associated with Nam in the aspect. If such an entity is not present, - -- then returns Empty. (Note: This function is modeled on function - -- Get_Iterable_Type_Primitive.) + -- associated with Nam in the aspect. If an entity was not explicitly + -- specified for Nam, then returns Empty, except that in the defaulted + -- Address_Type case, System.Address will be returned, and in the + -- defaulted Null_Address case, System.Null_Address will be returned. + -- (Note: This function is modeled on Get_Iterable_Type_Primitive.) function Storage_Model_Address_Type (SM_Obj_Or_Type : Entity_Id) return Entity_Id; -- Given a type with aspect Storage_Model_Type or an object of such a -- type, returns the type specified for the Address_Type choice in that - -- aspect; returns Empty if the type isn't specified. + -- aspect; returns type System.Address if the address type was not + -- explicitly specified (indicating use of the native memory model). function Storage_Model_Null_Address (SM_Obj_Or_Type : Entity_Id) return Entity_Id; -- Given a type with aspect Storage_Model_Type or an object of such a -- type, returns the constant specified for the Null_Address choice in - -- that aspect; returns Empty if the constant object isn't specified. + -- that aspect; returns Empty if the constant object isn't specified, + -- unless the native memory model is in use (System.Address), in which + -- case it returns System.Null_Address. function Storage_Model_Allocate (SM_Obj_Or_Type : Entity_Id) return Entity_Id; |