--
--  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;