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,
Aspect_SPARK_Mode, -- GNAT
Aspect_Stable_Properties,
Aspect_Static_Predicate,
+ Aspect_Storage_Model_Type, -- GNAT
Aspect_Storage_Pool,
Aspect_Storage_Size,
Aspect_Stream_Size,
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,
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,
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,
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,
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,
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,
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,
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,
-- 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;
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;
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);
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
-- 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
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 --
----------------
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 --
-----------------------------------
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;
projects / thirdparty / gcc.git / commitdiff
