From b479c0f7d7c45f9d99292ca2aa71d7845c7769bc Mon Sep 17 00:00:00 2001 From: Gary Dismukes Date: Mon, 13 Sep 2021 17:40:34 -0400 Subject: [PATCH] [Ada] Front-end support for Storage_Model feature gcc/ada/ * aspects.ads (type Aspect_Id): Add Aspect_Designated_Storage_Model and Aspect_Storage_Model_Type. (Aspect_Argument): Add associations for the above new aspects. (Is_Representation_Aspect): Likewise. (Aspect_Names, Aspect_Delay): Likewise. * exp_ch4.adb (Expand_N_Allocator): Call Find_Storage_Op rather than Find_Prim_Op. * exp_intr.adb (Expand_Unc_Deallocation): Likewise. * exp_util.ads (Find_Storage_Op): New function that locates either a primitive operation of a storage pool or an operation of a storage-model type specified in its Storage_Model_Type aspect. * exp_util.adb (Find_Storage_Op): New function that calls either Find_Prim_Op or Get_Storage_Model_Type_Entity to locate a storage-related operation that is associated with a type. * sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Analyzes, resolves, and validates the arguments of aspect Designated_Storage_Model_Type. (Analyze_Aspect_Specifications): Sets delay-related flags on storage-model aspects when Delay_Required. Checks that aspect Designated_Storage_Model is only specified for an access type and that aspect Storage_Model_Type is only specified on an immutably limited type. Also records such aspects for their associated types. (Check_Aspect_At_Freeze_Point): Resolve each of the argument associations given for a Storage_Model_Type aspect. (Resolve_Storage_Model_Type_Argument): New procedure that resolves an argument given in the association for a given entity name associated with a type with aspect Storage_Model_Type, ensuring that it has the proper kind or profile. (Validate_Storage_Model_Type_Aspect): New procedure that checks the legality and completeness of the entity associations given in a Storage_Model_Type aspect. * sem_util.ads (package Storage_Model_Support): New nested package that encapsulates a set of convenient utility functions for retrieving entities, etc. associated with storage-model-related types and objects. (Get_Storage_Model_Type_Entity): New function to return a specified entity associated with a type that has aspect Storage_Model_Type. (Has_Designated_Storage_Model_Aspect): New function that returns whether a type has aspect Designated_Storage_Model. (Has_Storage_Model_Type_Aspect): New function that returns whether a type has aspect Storage_Model_Type. (Storage_Model_Object): New function that returns the object Entity_Id associated with a type's Designated_Storage_Model aspect. (Storage_Model_Type): New function that returns the type associated with a storage-model object (when the object's type specifies Storage_Model_Type). (Storage_Model_Address_Type): New function that returns the Address_Type associated with a type that has aspect Storage_Model_Type. (Storage_Model_Null_Address): New function that returns the Null_Address constant associated with a type that has aspect Storage_Model_Type. (Storage_Model_Allocate): New function that returns the Allocate procedure associated with a type that has aspect Storage_Model_Type. (Storage_Model_Deallocate): New function that returns the Deallocate procedure associated with a type that has aspect Storage_Model_Type. (Storage_Model_Copy_From): New function that returns the Copy_From procedure associated with a type that has aspect Storage_Model_Type. (Storage_Model_Copy_To): New function that returns the Copy_To procedure associated with a type that has aspect Storage_Model_Type. (Storage_Model_Storage_Size): New function that returns the Storage_Size function associated with a type that has aspect Storage_Model_Type. * sem_util.adb (package Storage_Model_Support): Body of new nested package that contains the implementations the utility functions declared in the spec of this package. * snames.ads-tmpl: Add new names Name_Designated_Storage_Pool, Name_Storage_Model, Name_Storage_Model_Type, Name_Address_Type, Name_Copy_From, Name_Copy_To, and Name_Null_Address for the new aspects and associated aspect arguments. --- gcc/ada/aspects.ads | 10 + gcc/ada/exp_ch4.adb | 2 +- gcc/ada/exp_intr.adb | 2 +- gcc/ada/exp_util.adb | 26 ++ gcc/ada/exp_util.ads | 10 + gcc/ada/sem_ch13.adb | 550 +++++++++++++++++++++++++++++++++++++++- gcc/ada/sem_util.adb | 160 ++++++++++++ gcc/ada/sem_util.ads | 72 ++++++ gcc/ada/snames.ads-tmpl | 7 + 9 files changed, 834 insertions(+), 5 deletions(-) diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 11e0aebfeeb7..ab11bfda2f95 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -89,6 +89,7 @@ package Aspects is Aspect_Default_Storage_Pool, Aspect_Default_Value, Aspect_Depends, -- GNAT + Aspect_Designated_Storage_Model, -- GNAT Aspect_Dimension, -- GNAT Aspect_Dimension_System, -- GNAT Aspect_Dispatching_Domain, @@ -147,6 +148,7 @@ package Aspects is Aspect_SPARK_Mode, -- GNAT Aspect_Stable_Properties, Aspect_Static_Predicate, + Aspect_Storage_Model_Type, -- GNAT Aspect_Storage_Pool, Aspect_Storage_Size, Aspect_Stream_Size, @@ -380,6 +382,7 @@ package Aspects is Aspect_Default_Storage_Pool => Expression, Aspect_Default_Value => Expression, Aspect_Depends => Expression, + Aspect_Designated_Storage_Model => Name, Aspect_Dimension => Expression, Aspect_Dimension_System => Expression, Aspect_Dispatching_Domain => Expression, @@ -438,6 +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_Pool => Name, Aspect_Storage_Size => Expression, Aspect_Stream_Size => Expression, @@ -485,6 +489,7 @@ package Aspects is Aspect_Default_Storage_Pool => True, Aspect_Default_Value => True, Aspect_Depends => False, + Aspect_Designated_Storage_Model => True, Aspect_Dimension => False, Aspect_Dimension_System => False, Aspect_Dispatching_Domain => False, @@ -544,6 +549,7 @@ package Aspects is Aspect_SPARK_Mode => False, Aspect_Stable_Properties => False, Aspect_Static_Predicate => False, + Aspect_Storage_Model_Type => False, Aspect_Storage_Pool => True, Aspect_Storage_Size => True, Aspect_Stream_Size => True, @@ -637,6 +643,7 @@ package Aspects is Aspect_Default_Storage_Pool => Name_Default_Storage_Pool, Aspect_Default_Value => Name_Default_Value, Aspect_Depends => Name_Depends, + Aspect_Designated_Storage_Model => Name_Designated_Storage_Model, Aspect_Dimension => Name_Dimension, Aspect_Dimension_System => Name_Dimension_System, Aspect_Disable_Controlled => Name_Disable_Controlled, @@ -726,6 +733,7 @@ package Aspects is Aspect_Stable_Properties => Name_Stable_Properties, Aspect_Static => Name_Static, Aspect_Static_Predicate => Name_Static_Predicate, + Aspect_Storage_Model_Type => Name_Storage_Model_Type, Aspect_Storage_Pool => Name_Storage_Pool, Aspect_Storage_Size => Name_Storage_Size, Aspect_Stream_Size => Name_Stream_Size, @@ -881,6 +889,7 @@ package Aspects is Aspect_Default_Storage_Pool => Always_Delay, Aspect_Default_Value => Always_Delay, Aspect_Default_Component_Value => Always_Delay, + Aspect_Designated_Storage_Model => Always_Delay, Aspect_Discard_Names => Always_Delay, Aspect_Dispatching_Domain => Always_Delay, Aspect_Dynamic_Predicate => Always_Delay, @@ -932,6 +941,7 @@ package Aspects is Aspect_Simple_Storage_Pool => Always_Delay, Aspect_Simple_Storage_Pool_Type => Always_Delay, Aspect_Static_Predicate => Always_Delay, + Aspect_Storage_Model_Type => Always_Delay, Aspect_Storage_Pool => Always_Delay, Aspect_Stream_Size => Always_Delay, Aspect_String_Literal => Always_Delay, diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index d636cb0f6137..8dcfa85e7568 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4704,7 +4704,7 @@ package body Exp_Ch4 is else Set_Procedure_To_Call (N, - Find_Prim_Op (Etype (Pool), Name_Allocate)); + Find_Storage_Op (Etype (Pool), Name_Allocate)); end if; end if; end if; diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 45de0fb4e51c..86cb70234e61 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -1151,7 +1151,7 @@ package body Exp_Intr is else Set_Procedure_To_Call - (Free_Nod, Find_Prim_Op (Etype (Pool), Name_Deallocate)); + (Free_Nod, Find_Storage_Op (Etype (Pool), Name_Deallocate)); end if; end if; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index eef278fb3911..cb180967d67f 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6256,6 +6256,32 @@ package body Exp_Util is raise Program_Error; end Find_Protection_Type; + function Find_Storage_Op + (Typ : Entity_Id; + Nam : Name_Id) return Entity_Id + is + use Sem_Util.Storage_Model_Support; + + 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; + + -- Otherwise we assume that Typ is a descendant of Root_Storage_Pool + + else + return Find_Prim_Op (Typ, Nam); + end if; + end Find_Storage_Op; + ----------------------- -- Find_Hook_Context -- ----------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index eddf314c9321..2b61132107ce 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -628,6 +628,16 @@ package Exp_Util is -- Given a protected type or its corresponding record, find the type of -- field _object. + function Find_Storage_Op + (Typ : Entity_Id; + Nam : Name_Id) return Entity_Id; + -- Given type Typ that's either a descendant of Root_Storage_Pool or else + -- 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. + function Find_Hook_Context (N : Node_Id) return Node_Id; -- Determine a suitable node on which to attach actions related to N that -- need to be elaborated unconditionally. In general this is the topmost diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 412855490d38..fb1be479de1f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -262,6 +262,19 @@ package body Sem_Ch13 is -- Check legality of functions given in the Ada 2022 Stable_Properties -- (or Stable_Properties'Class) aspect. + procedure Validate_Storage_Model_Type_Aspect + (Typ : Entity_Id; ASN : Node_Id); + -- Check legality and completeness of the aggregate associations given in + -- the Storage_Model_Type aspect associated with Typ. + + procedure Resolve_Storage_Model_Type_Argument + (N : Node_Id; + Typ : Entity_Id; + Addr_Type : in out Entity_Id; + Nam : Name_Id); + -- Resolve argument N to be of the proper kind (when a type or constant) + -- or to have the proper profile (when a subprogram). + procedure Resolve_Aspect_Stable_Properties (Typ_Or_Subp : Entity_Id; Expr : Node_Id; @@ -1517,6 +1530,32 @@ package body Sem_Ch13 is when Aspect_Iterable => Validate_Iterable_Aspect (E, ASN); + when Aspect_Designated_Storage_Model => + Analyze_And_Resolve (Expression (ASN)); + + if not Is_Entity_Name (Expression (ASN)) + or else not Is_Object (Entity (Expression (ASN))) + or else + not Present (Find_Aspect (Etype (Expression (ASN)), + Aspect_Storage_Model_Type)) + then + Error_Msg_N + ("must specify name of stand-alone object of type " + & "with aspect Storage_Model_Type", + Expression (ASN)); + + -- Set access type's Associated_Storage_Pool to denote + -- the Storage_Model_Type object given for the aspect + -- (even though that isn't actually an Ada storage pool). + + else + Set_Associated_Storage_Pool + (E, Entity (Expression (ASN))); + end if; + + when Aspect_Storage_Model_Type => + Validate_Storage_Model_Type_Aspect (E, ASN); + when Aspect_Aggregate => null; @@ -3065,10 +3104,11 @@ package body Sem_Ch13 is if Delay_Required - and then A_Id = Aspect_Stable_Properties + and then (A_Id = Aspect_Stable_Properties + or else A_Id = Aspect_Designated_Storage_Model + or else A_Id = Aspect_Storage_Model_Type) -- ??? It seems like we should do this for all aspects, not - -- just Stable_Properties, but that causes as-yet-undiagnosed - -- regressions. + -- just these, but that causes as-yet-undiagnosed regressions. then Set_Has_Delayed_Aspects (E); @@ -4368,6 +4408,44 @@ package body Sem_Ch13 is Record_Rep_Item (E, Aspect); goto Continue; + when Aspect_Designated_Storage_Model => + if not Extensions_Allowed then + Error_Msg_N + ("aspect only allowed if extensions enabled", + Aspect); + Error_Msg_N + ("\unit must be compiled with -gnatX switch", Aspect); + + elsif not Is_Type (E) + or else Ekind (E) /= E_Access_Type + then + Error_Msg_N + ("can only be specified for pool-specific access type", + Aspect); + end if; + + Record_Rep_Item (E, Aspect); + goto Continue; + + when Aspect_Storage_Model_Type => + if not Extensions_Allowed then + Error_Msg_N + ("aspect only allowed if extensions enabled", + Aspect); + Error_Msg_N + ("\unit must be compiled with -gnatX switch", Aspect); + + elsif not Is_Type (E) + or else not Is_Immutably_Limited_Type (E) + then + Error_Msg_N + ("can only be specified for immutably limited type", + Aspect); + end if; + + Record_Rep_Item (E, Aspect); + goto Continue; + when Aspect_Integer_Literal | Aspect_Real_Literal | Aspect_String_Literal @@ -11229,6 +11307,34 @@ package body Sem_Ch13 is -- Here is the list of aspects that don't require delay analysis + when Aspect_Designated_Storage_Model => + return; + + when Aspect_Storage_Model_Type => + T := Entity (ASN); + + declare + Assoc : Node_Id; + Expr : Node_Id; + Addr_Type : Entity_Id := Empty; + + begin + Assoc := First (Component_Associations (Expression (ASN))); + while Present (Assoc) loop + Expr := Expression (Assoc); + Analyze (Expr); + + if not Error_Posted (Expr) then + Resolve_Storage_Model_Type_Argument + (Expr, T, Addr_Type, Chars (First (Choices (Assoc)))); + end if; + + Next (Assoc); + end loop; + end; + + return; + when Aspect_Abstract_State | Aspect_Annotate | Aspect_Async_Readers @@ -16199,6 +16305,334 @@ package body Sem_Ch13 is Set_Analyzed (Expr); end Resolve_Aspect_Stable_Properties; + ----------------------------------------- + -- Resolve_Storage_Model_Type_Argument -- + ----------------------------------------- + + procedure Resolve_Storage_Model_Type_Argument + (N : Node_Id; + Typ : Entity_Id; + Addr_Type : in out Entity_Id; + Nam : Name_Id) + is + + type Formal_Profile is record + Subt : Entity_Id; + Mode : Formal_Kind; + end record; + + type Formal_Profiles is array (Positive range <>) of Formal_Profile; + + function Aspect_Argument_Profile_Matches + (Subp : Entity_Id; + Profiles : Formal_Profiles; + Result_Subt : Entity_Id; + Err_On_Mismatch : Boolean) return Boolean; + -- Checks that the formal parameters of subprogram Subp conform to the + -- subtypes and modes specified by Profiles, as well as to the result + -- subtype Result_Subt when that is nonempty. + + function Aspect_Argument_Profile_Matches + (Subp : Entity_Id; + Profiles : Formal_Profiles; + Result_Subt : Entity_Id; + Err_On_Mismatch : Boolean) return Boolean + is + + procedure Report_Argument_Error + (Msg : String; + Formal : Entity_Id := Empty; + Subt : Entity_Id := Empty); + -- If Err_On_Mismatch is True, reports an argument error given by Msg + -- associated with Formal and/or Subt. + + procedure Report_Argument_Error + (Msg : String; + Formal : Entity_Id := Empty; + Subt : Entity_Id := Empty) + is + begin + if Err_On_Mismatch then + if Present (Formal) then + if Present (Subt) then + Error_Msg_Node_2 := Subt; + end if; + Error_Msg_NE (Msg, N, Formal); + + elsif Present (Subt) then + Error_Msg_NE (Msg, N, Subt); + + else + Error_Msg_N (Msg, N); + end if; + end if; + end Report_Argument_Error; + + -- Local variables + + Formal : Entity_Id := First_Formal (Subp); + Is_Error : Boolean := False; + + -- Start of processing for Aspect_Argument_Profile_Matches + + begin + for FP of Profiles loop + if not Present (Formal) then + Is_Error := True; + Report_Argument_Error ("missing formal of }", Subt => FP.Subt); + exit; + + elsif not Subtypes_Statically_Match + (Etype (Formal), FP.Subt) + then + Is_Error := True; + Report_Argument_Error + ("formal& must be of subtype&", + Formal => Formal, Subt => FP.Subt); + exit; + + elsif Ekind (Formal) /= FP.Mode then + Is_Error := True; + Report_Argument_Error + ("formal& has wrong mode", Formal => Formal); + exit; + end if; + + Formal := Next_Formal (Formal); + end loop; + + if not Is_Error + and then Present (Formal) + then + Is_Error := True; + Report_Argument_Error + ("too many formals for subprogram in aspect"); + end if; + + if not Is_Error + and then Present (Result_Subt) + and then not Subtypes_Statically_Match (Etype (Subp), Result_Subt) + then + Is_Error := True; + Report_Argument_Error + ("subprogram must have result}", Subt => Result_Subt); + end if; + + return not Is_Error; + end Aspect_Argument_Profile_Matches; + + -- Local variables + + Ent : Entity_Id; + + Storage_Count_Type : constant Entity_Id := RTE (RE_Storage_Count); + System_Address_Type : constant Entity_Id := RTE (RE_Address); + + -- Start of processing for Resolve_Storage_Model_Type_Argument + + begin + if Nam = Name_Address_Type then + if not Is_Entity_Name (N) + or else not Is_Type (Entity (N)) + or else (Root_Type (Entity (N)) /= System_Address_Type + and then not Is_Integer_Type (Entity (N))) + then + Error_Msg_N ("named entity must be a descendant of System.Address " + & "or an integer type", N); + end if; + + Addr_Type := Entity (N); + + return; + + elsif not Present (Addr_Type) then + Error_Msg_N ("argument association for Address_Type missing; " + & "must be specified as first aspect argument", N); + return; + + elsif Nam = Name_Null_Address then + if not Is_Entity_Name (N) + or else not Is_Constant_Object (Entity (N)) + or else + not Subtypes_Statically_Match (Etype (Entity (N)), Addr_Type) + then + Error_Msg_NE + ("named entity must be constant of subtype}", N, Addr_Type); + end if; + + return; + + elsif not Is_Overloaded (N) then + if not Is_Entity_Name (N) + or else Ekind (Entity (N)) not in E_Function | E_Procedure + or else Scope (Entity (N)) /= Scope (Typ) + then + Error_Msg_N ("argument must be local subprogram name", N); + return; + end if; + + Ent := Entity (N); + + if Nam = Name_Allocate then + if not Aspect_Argument_Profile_Matches + (Ent, + Profiles => + ((Typ, E_In_Out_Parameter), + (Addr_Type, E_Out_Parameter), + (Storage_Count_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => True) + then + Error_Msg_N ("no match for Allocate operation", N); + end if; + + elsif Nam = Name_Deallocate then + if not Aspect_Argument_Profile_Matches + (Ent, + Profiles => + ((Typ, E_In_Out_Parameter), + (Addr_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => True) + then + Error_Msg_N ("no match for Deallocate operation", N); + end if; + + elsif Nam = Name_Copy_From then + if not Aspect_Argument_Profile_Matches + (Ent, + Profiles => + ((Typ, E_In_Out_Parameter), + (System_Address_Type, E_In_Parameter), + (Addr_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => True) + then + Error_Msg_N ("no match for Copy_From operation", N); + end if; + + elsif Nam = Name_Copy_To then + if not Aspect_Argument_Profile_Matches + (Ent, + Profiles => + ((Typ, E_In_Out_Parameter), + (Addr_Type, E_In_Parameter), + (System_Address_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => True) + then + Error_Msg_N ("no match for Copy_To operation", N); + end if; + + elsif Nam = Name_Storage_Size then + if not Aspect_Argument_Profile_Matches + (Ent, + Profiles => (1 => (Typ, E_In_Parameter)), + Result_Subt => Storage_Count_Type, + Err_On_Mismatch => True) + then + Error_Msg_N ("no match for Storage_Size operation", N); + end if; + + else + null; -- Error will be caught in Validate_Storage_Model_Type_Aspect + end if; + + else + -- Overloaded case: find subprogram with proper signature + + declare + I : Interp_Index; + It : Interp; + Found_Match : Boolean := False; + + begin + Get_First_Interp (N, I, It); + while Present (It.Typ) loop + if Ekind (It.Nam) in E_Function | E_Procedure + and then Scope (It.Nam) = Scope (Typ) + then + if Nam = Name_Allocate then + Found_Match := + Aspect_Argument_Profile_Matches + (It.Nam, + Profiles => + ((Typ, E_In_Out_Parameter), + (Addr_Type, E_Out_Parameter), + (Storage_Count_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => False); + + elsif Nam = Name_Deallocate then + Found_Match := + Aspect_Argument_Profile_Matches + (It.Nam, + Profiles => + ((Typ, E_In_Out_Parameter), + (Addr_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => False); + + elsif Nam = Name_Copy_From then + Found_Match := + Aspect_Argument_Profile_Matches + (It.Nam, + Profiles => + ((Typ, E_In_Out_Parameter), + (System_Address_Type, E_In_Parameter), + (Addr_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => False); + + elsif Nam = Name_Copy_To then + Found_Match := + Aspect_Argument_Profile_Matches + (It.Nam, + Profiles => + ((Typ, E_In_Out_Parameter), + (Addr_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter), + (System_Address_Type, E_In_Parameter), + (Storage_Count_Type, E_In_Parameter)), + Result_Subt => Empty, + Err_On_Mismatch => False); + + elsif Nam = Name_Storage_Size then + Found_Match := + Aspect_Argument_Profile_Matches + (It.Nam, + Profiles => (1 => (Typ, E_In_Parameter)), + Result_Subt => Storage_Count_Type, + Err_On_Mismatch => False); + end if; + + if Found_Match then + Set_Entity (N, It.Nam); + exit; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + + if not Found_Match then + Error_Msg_N + ("no match found for Storage_Model_Type operation", N); + end if; + end; + end if; + end Resolve_Storage_Model_Type_Argument; + ---------------- -- Set_Biased -- ---------------- @@ -16781,6 +17215,116 @@ package body Sem_Ch13 is end if; end Validate_Literal_Aspect; + ---------------------------------------- + -- Validate_Storage_Model_Type_Aspect -- + ---------------------------------------- + + procedure Validate_Storage_Model_Type_Aspect + (Typ : Entity_Id; ASN : Node_Id) + is + Assoc : Node_Id; + Choice : Entity_Id; + Expr : Node_Id; + + Address_Type_Id : Entity_Id := Empty; + Null_Address_Id : Entity_Id := Empty; + Allocate_Id : Entity_Id := Empty; + Deallocate_Id : Entity_Id := Empty; + Copy_From_Id : Entity_Id := Empty; + Copy_To_Id : Entity_Id := Empty; + Storage_Size_Id : Entity_Id := Empty; + + begin + -- Each expression must resolve to an entity of the right kind or proper + -- profile. + + Assoc := First (Component_Associations (Expression (ASN))); + while Present (Assoc) loop + Expr := Expression (Assoc); + Analyze (Expr); + + Choice := First (Choices (Assoc)); + + 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 + 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 + (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??? + + 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); + + else + Error_Msg_N + ("invalid name for Storage_Model_Type argument", Choice); + end if; + + Next (Assoc); + end loop; + + if No (Address_Type_Id) then + Error_Msg_N ("match for Address_Type not found", ASN); + + elsif No (Null_Address_Id) then + Error_Msg_N ("match for Null_Address primitive not found", ASN); + + elsif No (Allocate_Id) then + Error_Msg_N ("match for Allocate primitive not found", ASN); + + elsif No (Deallocate_Id) then + Error_Msg_N ("match for Deallocate primitive not found", ASN); + + elsif No (Copy_From_Id) then + Error_Msg_N ("match for Copy_From primitive not found", ASN); + + elsif No (Copy_To_Id) then + Error_Msg_N ("match for Copy_To primitive not found", ASN); + + elsif No (Storage_Size_Id) then + Error_Msg_N ("match for Storage_Size primitive not found", ASN); + end if; + end Validate_Storage_Model_Type_Aspect; + ----------------------------------- -- Validate_Unchecked_Conversion -- ----------------------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 072cd3f6745d..b5f3d4cce034 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -32153,6 +32153,166 @@ package body Sem_Util is end Indirect_Temps; end Old_Attr_Util; + + package body Storage_Model_Support is + + ----------------------------------- + -- Get_Storage_Model_Type_Entity -- + ----------------------------------- + + function Get_Storage_Model_Type_Entity + (Typ : Entity_Id; + Nam : Name_Id) return Entity_Id + is + pragma Assert + (Is_Type (Typ) + and then + Nam in Name_Address_Type + | Name_Null_Address + | Name_Allocate + | Name_Deallocate + | Name_Copy_From + | Name_Copy_To + | Name_Storage_Size); + + SMT_Aspect_Value : constant Node_Id := + Find_Value_Of_Aspect (Typ, Aspect_Storage_Model_Type); + Assoc : Node_Id; + + begin + if No (SMT_Aspect_Value) then + return Empty; + + else + 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; + + return Empty; + end if; + end Get_Storage_Model_Type_Entity; + + ----------------------------------------- + -- Has_Designated_Storage_Model_Aspect -- + ----------------------------------------- + + function Has_Designated_Storage_Model_Aspect + (Typ : Entity_Id) return Boolean + is + begin + return Present (Find_Aspect (Typ, Aspect_Designated_Storage_Model)); + end Has_Designated_Storage_Model_Aspect; + + ----------------------------------- + -- Has_Storage_Model_Type_Aspect -- + ----------------------------------- + + function Has_Storage_Model_Type_Aspect (Typ : Entity_Id) return Boolean + is + begin + return Present (Find_Aspect (Typ, Aspect_Storage_Model_Type)); + end Has_Storage_Model_Type_Aspect; + + -------------------------- + -- Storage_Model_Object -- + -------------------------- + + function Storage_Model_Object (Typ : Entity_Id) return Entity_Id is + begin + if Has_Designated_Storage_Model_Aspect (Typ) then + return + Entity + (Find_Value_Of_Aspect (Typ, Aspect_Designated_Storage_Model)); + else + return Empty; + end if; + end Storage_Model_Object; + + ------------------------ + -- Storage_Model_Type -- + ------------------------ + + function Storage_Model_Type (Obj : Entity_Id) return Entity_Id is + begin + if Present + (Find_Value_Of_Aspect (Etype (Obj), Aspect_Storage_Model_Type)) + then + return Etype (Obj); + else + return Empty; + end if; + end Storage_Model_Type; + + -------------------------------- + -- Storage_Model_Address_Type -- + -------------------------------- + + function Storage_Model_Address_Type (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Address_Type); + end Storage_Model_Address_Type; + + -------------------------------- + -- Storage_Model_Null_Address -- + -------------------------------- + + function Storage_Model_Null_Address (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Null_Address); + end Storage_Model_Null_Address; + + ---------------------------- + -- Storage_Model_Allocate -- + ---------------------------- + + function Storage_Model_Allocate (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Allocate); + end Storage_Model_Allocate; + + ------------------------------ + -- Storage_Model_Deallocate -- + ------------------------------ + + function Storage_Model_Deallocate (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Deallocate); + end Storage_Model_Deallocate; + + ----------------------------- + -- Storage_Model_Copy_From -- + ----------------------------- + + function Storage_Model_Copy_From (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Copy_From); + end Storage_Model_Copy_From; + + --------------------------- + -- Storage_Model_Copy_To -- + --------------------------- + + function Storage_Model_Copy_To (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Copy_To); + end Storage_Model_Copy_To; + + -------------------------------- + -- Storage_Model_Storage_Size -- + -------------------------------- + + function Storage_Model_Storage_Size (Typ : Entity_Id) return Entity_Id is + begin + return Get_Storage_Model_Type_Entity (Typ, Name_Storage_Size); + end Storage_Model_Storage_Size; + + end Storage_Model_Support; + begin Erroutc.Subprogram_Name_Ptr := Subprogram_Name'Access; end Sem_Util; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 63f1d6bb10ee..85010b571308 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -3550,4 +3550,76 @@ package Sem_Util is end Indirect_Temps; end Old_Attr_Util; + + package Storage_Model_Support is + + -- This package provides a set of utility functions related to support + -- for the Storage_Model feature. These functions provide an interface + -- that the compiler (in particular back-end phases such as gigi and + -- GNAT-LLVM) can use to easily obtain entities and operations that + -- are specified for types in the aspects Storage_Model_Type and + -- Designated_Storage_Model. + + function Get_Storage_Model_Type_Entity + (Typ : Entity_Id; + Nam : Name_Id) return Entity_Id; + -- Given type Typ with aspect Storage_Model_Type, returns the Entity_Id + -- corresponding to the entity associated with Nam in the aspect. If the + -- type does not specify the aspect, or such an entity is not present, + -- then returns Empty. (Note: This function is modeled on function + -- Get_Iterable_Type_Primitive.) + + function Has_Designated_Storage_Model_Aspect + (Typ : Entity_Id) return Boolean; + -- Returns True iff Typ specifies aspect Designated_Storage_Model + + function Has_Storage_Model_Type_Aspect (Typ : Entity_Id) return Boolean; + -- Returns True iff Typ specifies aspect Storage_Model_Type + + function Storage_Model_Object (Typ : Entity_Id) return Entity_Id; + -- Given an access type with aspect Designated_Storage_Model, returns + -- the storage-model object associated with that type; returns Empty + -- if there is no associated object. + + function Storage_Model_Type (Obj : Entity_Id) return Entity_Id; + -- Given an object Obj of a type specifying aspect Storage_Model_Type, + -- returns that type; otherwise returns Empty. + + function Storage_Model_Address_Type (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- the type specified for the Address_Type choice in that aspect; + -- returns Empty if the aspect or the type isn't specified. + + function Storage_Model_Null_Address (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- constant specified for Null_Address choice in that aspect; returns + -- Empty if the aspect or the constant object isn't specified. + + function Storage_Model_Allocate (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- procedure specified for the Allocate choice in that aspect; returns + -- Empty if the aspect or the procedure isn't specified. + + function Storage_Model_Deallocate (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- procedure specified for the Deallocate choice in that aspect; returns + -- Empty if the aspect or the procedure isn't specified. + + function Storage_Model_Copy_From (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- procedure specified for the Copy_From choice in that aspect; returns + -- Empty if the aspect or the procedure isn't specified. + + function Storage_Model_Copy_To (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- procedure specified for the Copy_To choice in that aspect; returns + -- Empty if the aspect or the procedure isn't specified. + + function Storage_Model_Storage_Size (Typ : Entity_Id) return Entity_Id; + -- Given a type Typ that specifies aspect Storage_Model_Type, returns + -- function specified for Storage_Size choice in that aspect; returns + -- Empty if the aspect or the procedure isn't specified. + + end Storage_Model_Support; + end Sem_Util; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 400adb03baea..8a98deef3862 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -149,6 +149,7 @@ package Snames is Name_Default_Value : constant Name_Id := N + $; Name_Default_Component_Value : constant Name_Id := N + $; + Name_Designated_Storage_Model : constant Name_Id := N + $; Name_Dimension : constant Name_Id := N + $; Name_Dimension_System : constant Name_Id := N + $; Name_Disable_Controlled : constant Name_Id := N + $; @@ -162,6 +163,8 @@ package Snames is Name_Relaxed_Initialization : constant Name_Id := N + $; Name_Stable_Properties : constant Name_Id := N + $; Name_Static_Predicate : constant Name_Id := N + $; + Name_Storage_Model : constant Name_Id := N + $; + Name_Storage_Model_Type : constant Name_Id := N + $; Name_String_Literal : constant Name_Id := N + $; Name_Synchronization : constant Name_Id := N + $; Name_Unimplemented : constant Name_Id := N + $; @@ -779,6 +782,7 @@ package Snames is -- Other special names used in processing attributes, aspects, and pragmas + Name_Address_Type : constant Name_Id := N + $; Name_Aggregate : constant Name_Id := N + $; Name_Allow : constant Name_Id := N + $; Name_Amount : constant Name_Id := N + $; @@ -798,6 +802,8 @@ package Snames is Name_Component : constant Name_Id := N + $; Name_Component_Size_4 : constant Name_Id := N + $; Name_Copy : constant Name_Id := N + $; + Name_Copy_From : constant Name_Id := N + $; + Name_Copy_To : constant Name_Id := N + $; Name_D_Float : constant Name_Id := N + $; Name_Decreases : constant Name_Id := N + $; Name_Disable : constant Name_Id := N + $; @@ -867,6 +873,7 @@ package Snames is Name_Nominal : constant Name_Id := N + $; Name_Non_Volatile : constant Name_Id := N + $; Name_None : constant Name_Id := N + $; + Name_Null_Address : constant Name_Id := N + $; Name_On : constant Name_Id := N + $; Name_Optional : constant Name_Id := N + $; Name_Policy : constant Name_Id := N + $;