forked from Imagelibrary/rtems
304 lines
8.1 KiB
Ada
304 lines
8.1 KiB
Ada
--
|
|
-- RTEMS / Body
|
|
--
|
|
-- DESCRIPTION:
|
|
--
|
|
-- This package provides the interface to the RTEMS API.
|
|
--
|
|
--
|
|
-- DEPENDENCIES:
|
|
--
|
|
--
|
|
--
|
|
-- COPYRIGHT (c) 1997-2011.
|
|
-- On-Line Applications Research Corporation (OAR).
|
|
--
|
|
-- The license and distribution terms for this file may in
|
|
-- the file LICENSE in this distribution or at
|
|
-- http://www.rtems.org/license/LICENSE.
|
|
--
|
|
|
|
with Interfaces; use Interfaces;
|
|
with Interfaces.C.Strings; use Interfaces.C.Strings;
|
|
|
|
package body RTEMS.Object is
|
|
|
|
--
|
|
-- Object Services
|
|
--
|
|
|
|
function Build_Name
|
|
(C1 : in Character;
|
|
C2 : in Character;
|
|
C3 : in Character;
|
|
C4 : in Character)
|
|
return RTEMS.Name
|
|
is
|
|
C1_Value : RTEMS.Unsigned32;
|
|
C2_Value : RTEMS.Unsigned32;
|
|
C3_Value : RTEMS.Unsigned32;
|
|
C4_Value : RTEMS.Unsigned32;
|
|
begin
|
|
|
|
C1_Value := Character'Pos (C1);
|
|
C2_Value := Character'Pos (C2);
|
|
C3_Value := Character'Pos (C3);
|
|
C4_Value := Character'Pos (C4);
|
|
|
|
return Interfaces.Shift_Left (C1_Value, 24) or
|
|
Interfaces.Shift_Left (C2_Value, 16) or
|
|
Interfaces.Shift_Left (C3_Value, 8) or
|
|
C4_Value;
|
|
|
|
end Build_Name;
|
|
|
|
procedure Get_Classic_Name
|
|
(ID : in RTEMS.ID;
|
|
Name : out RTEMS.Name;
|
|
Result : out RTEMS.Status_Codes)
|
|
is
|
|
function Get_Classic_Name_Base
|
|
(ID : RTEMS.ID;
|
|
Name : access RTEMS.Name)
|
|
return RTEMS.Status_Codes;
|
|
pragma Import
|
|
(C,
|
|
Get_Classic_Name_Base,
|
|
"rtems_object_get_classic_name");
|
|
Tmp_Name : aliased RTEMS.Name;
|
|
begin
|
|
Result := Get_Classic_Name_Base (ID, Tmp_Name'Access);
|
|
Name := Tmp_Name;
|
|
end Get_Classic_Name;
|
|
|
|
procedure Get_Name
|
|
(ID : in RTEMS.ID;
|
|
Name : out String;
|
|
Result : out RTEMS.Address)
|
|
is
|
|
function Get_Name_Base
|
|
(ID : RTEMS.ID;
|
|
Length : RTEMS.Unsigned32;
|
|
Name : RTEMS.Address)
|
|
return RTEMS.Address;
|
|
pragma Import (C, Get_Name_Base, "rtems_object_get_name");
|
|
begin
|
|
Name := (others => ASCII.NUL);
|
|
Result :=
|
|
Get_Name_Base (ID, Name'Length, Name (Name'First)'Address);
|
|
end Get_Name;
|
|
|
|
procedure Set_Name
|
|
(ID : in RTEMS.ID;
|
|
Name : in String;
|
|
Result : out RTEMS.Status_Codes)
|
|
is
|
|
function Set_Name_Base
|
|
(ID : RTEMS.ID;
|
|
Name : chars_ptr)
|
|
return RTEMS.Status_Codes;
|
|
pragma Import (C, Set_Name_Base, "rtems_object_set_name");
|
|
NameAsCString : constant chars_ptr := New_String (Name);
|
|
begin
|
|
Result := Set_Name_Base (ID, NameAsCString);
|
|
end Set_Name;
|
|
|
|
procedure Id_Get_API
|
|
(ID : in RTEMS.ID;
|
|
API : out RTEMS.Unsigned32)
|
|
is
|
|
function Id_Get_API_Base
|
|
(ID : RTEMS.ID)
|
|
return RTEMS.Unsigned32;
|
|
pragma Import (C, Id_Get_API_Base, "rtems_object_id_get_api");
|
|
begin
|
|
API := Id_Get_API_Base (ID);
|
|
end Id_Get_API;
|
|
|
|
procedure Id_Get_Class
|
|
(ID : in RTEMS.ID;
|
|
The_Class : out RTEMS.Unsigned32)
|
|
is
|
|
function Id_Get_Class_Base
|
|
(ID : RTEMS.ID)
|
|
return RTEMS.Unsigned32;
|
|
pragma Import
|
|
(C,
|
|
Id_Get_Class_Base,
|
|
"rtems_object_id_get_class");
|
|
begin
|
|
The_Class := Id_Get_Class_Base (ID);
|
|
end Id_Get_Class;
|
|
|
|
procedure Id_Get_Node
|
|
(ID : in RTEMS.ID;
|
|
Node : out RTEMS.Unsigned32)
|
|
is
|
|
function Id_Get_Node_Base
|
|
(ID : RTEMS.ID)
|
|
return RTEMS.Unsigned32;
|
|
pragma Import (C, Id_Get_Node_Base, "rtems_object_id_get_node");
|
|
begin
|
|
Node := Id_Get_Node_Base (ID);
|
|
end Id_Get_Node;
|
|
|
|
procedure Id_Get_Index
|
|
(ID : in RTEMS.ID;
|
|
Index : out RTEMS.Unsigned32)
|
|
is
|
|
function Id_Get_Index_Base
|
|
(ID : RTEMS.ID)
|
|
return RTEMS.Unsigned32;
|
|
pragma Import
|
|
(C,
|
|
Id_Get_Index_Base,
|
|
"rtems_object_id_get_index");
|
|
begin
|
|
Index := Id_Get_Index_Base (ID);
|
|
end Id_Get_Index;
|
|
|
|
function Build_Id
|
|
(The_API : in RTEMS.Unsigned32;
|
|
The_Class : in RTEMS.Unsigned32;
|
|
The_Node : in RTEMS.Unsigned32;
|
|
The_Index : in RTEMS.Unsigned32)
|
|
return RTEMS.ID
|
|
is
|
|
function Build_Id_Base
|
|
(The_API : RTEMS.Unsigned32;
|
|
The_Class : RTEMS.Unsigned32;
|
|
The_Node : RTEMS.Unsigned32;
|
|
The_Index : RTEMS.Unsigned32)
|
|
return RTEMS.ID;
|
|
pragma Import (C, Build_Id_Base, "rtems_build_id");
|
|
begin
|
|
return Build_Id_Base (The_API, The_Class, The_Node, The_Index);
|
|
end Build_Id;
|
|
|
|
function Id_API_Minimum return RTEMS.Unsigned32 is
|
|
function Id_API_Minimum_Base return RTEMS.Unsigned32;
|
|
pragma Import
|
|
(C,
|
|
Id_API_Minimum_Base,
|
|
"rtems_object_id_api_minimum");
|
|
begin
|
|
return Id_API_Minimum_Base;
|
|
end Id_API_Minimum;
|
|
|
|
function Id_API_Maximum return RTEMS.Unsigned32 is
|
|
function Id_API_Maximum_Base return RTEMS.Unsigned32;
|
|
pragma Import
|
|
(C,
|
|
Id_API_Maximum_Base,
|
|
"rtems_object_id_api_maximum");
|
|
begin
|
|
return Id_API_Maximum_Base;
|
|
end Id_API_Maximum;
|
|
|
|
procedure API_Minimum_Class
|
|
(API : in RTEMS.Unsigned32;
|
|
Minimum : out RTEMS.Unsigned32)
|
|
is
|
|
function API_Minimum_Class_Base
|
|
(API : RTEMS.Unsigned32)
|
|
return RTEMS.Unsigned32;
|
|
pragma Import
|
|
(C,
|
|
API_Minimum_Class_Base,
|
|
"rtems_object_api_minimum_class");
|
|
begin
|
|
Minimum := API_Minimum_Class_Base (API);
|
|
end API_Minimum_Class;
|
|
|
|
procedure API_Maximum_Class
|
|
(API : in RTEMS.Unsigned32;
|
|
Maximum : out RTEMS.Unsigned32)
|
|
is
|
|
function API_Maximum_Class_Base
|
|
(API : RTEMS.Unsigned32)
|
|
return RTEMS.Unsigned32;
|
|
pragma Import
|
|
(C,
|
|
API_Maximum_Class_Base,
|
|
"rtems_object_api_maximum_class");
|
|
begin
|
|
Maximum := API_Maximum_Class_Base (API);
|
|
end API_Maximum_Class;
|
|
|
|
-- Translate S from a C-style char* into an Ada String.
|
|
-- If S is Null_Ptr, return "", don't raise an exception.
|
|
-- Copied from Lovelace Tutorial
|
|
function Value_Without_Exception (S : chars_ptr) return String is
|
|
begin
|
|
if S = Null_Ptr then
|
|
return "";
|
|
else
|
|
return Value (S);
|
|
end if;
|
|
end Value_Without_Exception;
|
|
pragma Inline (Value_Without_Exception);
|
|
|
|
procedure Get_API_Name
|
|
(API : in RTEMS.Unsigned32;
|
|
Name : out String)
|
|
is
|
|
function Get_API_Name_Base
|
|
(API : RTEMS.Unsigned32)
|
|
return chars_ptr;
|
|
pragma Import
|
|
(C,
|
|
Get_API_Name_Base,
|
|
"rtems_object_get_api_name");
|
|
Result : constant chars_ptr := Get_API_Name_Base (API);
|
|
APIName : constant String := Value_Without_Exception (Result);
|
|
begin
|
|
Name := APIName;
|
|
end Get_API_Name;
|
|
|
|
procedure Get_API_Class_Name
|
|
(The_API : in RTEMS.Unsigned32;
|
|
The_Class : in RTEMS.Unsigned32;
|
|
Name : out String)
|
|
is
|
|
function Get_API_Class_Name_Base
|
|
(API : RTEMS.Unsigned32;
|
|
Class : RTEMS.Unsigned32)
|
|
return chars_ptr;
|
|
pragma Import
|
|
(C,
|
|
Get_API_Class_Name_Base,
|
|
"rtems_object_get_api_class_name");
|
|
Result : constant chars_ptr :=
|
|
Get_API_Class_Name_Base (The_API, The_Class);
|
|
ClassName : constant String := Value_Without_Exception (Result);
|
|
begin
|
|
Name := ClassName;
|
|
end Get_API_Class_Name;
|
|
|
|
procedure Get_Class_Information
|
|
(The_API : in RTEMS.Unsigned32;
|
|
The_Class : in RTEMS.Unsigned32;
|
|
Info : out API_Class_Information;
|
|
Result : out RTEMS.Status_Codes)
|
|
is
|
|
function Get_Class_Information_Base
|
|
(The_API : RTEMS.Unsigned32;
|
|
The_Class : RTEMS.Unsigned32;
|
|
Info : access API_Class_Information)
|
|
return RTEMS.Status_Codes;
|
|
pragma Import
|
|
(C,
|
|
Get_Class_Information_Base,
|
|
"rtems_object_get_class_information");
|
|
TmpInfo : aliased API_Class_Information;
|
|
begin
|
|
Result :=
|
|
Get_Class_Information_Base
|
|
(The_API,
|
|
The_Class,
|
|
TmpInfo'Access);
|
|
Info := TmpInfo;
|
|
end Get_Class_Information;
|
|
|
|
end RTEMS.Object;
|