From 8407b5e4af21199e59d95c64903c400c7959b5a4 Mon Sep 17 00:00:00 2001 From: Joel Sherrill Date: Fri, 1 Feb 2008 21:24:18 +0000 Subject: 2008-02-01 Joel Sherrill * rtems.adb, rtems.ads: Add Ada binding for Object Services. --- c/src/ada/ChangeLog | 4 + c/src/ada/rtems.adb | 284 +++++++++++++++++++++++++++++++++++++++++++++++----- c/src/ada/rtems.ads | 109 ++++++++++++++++++-- 3 files changed, 362 insertions(+), 35 deletions(-) (limited to 'c/src/ada') diff --git a/c/src/ada/ChangeLog b/c/src/ada/ChangeLog index 6b2a36b063..47a1af6c10 100644 --- a/c/src/ada/ChangeLog +++ b/c/src/ada/ChangeLog @@ -1,3 +1,7 @@ +2008-02-01 Joel Sherrill + + * rtems.adb, rtems.ads: Add Ada binding for Object Services. + 2007-12-04 Joel Sherrill * rtems.adb: Add missing semicolon. diff --git a/c/src/ada/rtems.adb b/c/src/ada/rtems.adb index b221bb2ba2..484f170ee2 100644 --- a/c/src/ada/rtems.adb +++ b/c/src/ada/rtems.adb @@ -10,7 +10,7 @@ -- -- -- --- COPYRIGHT (c) 1997-2007. +-- COPYRIGHT (c) 1997-2008. -- On-Line Applications Research Corporation (OAR). -- -- The license and distribution terms for this file may in @@ -24,7 +24,8 @@ with Ada; with Ada.Unchecked_Conversion; with System; with Interfaces; use Interfaces; -with Interfaces.C; +with Interfaces.C; use Interfaces.C; +with Interfaces.C.Strings; use Interfaces.C.Strings; package body RTEMS is @@ -87,30 +88,6 @@ package body RTEMS is end Milliseconds_To_Ticks; - 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 Name_To_Characters ( Name : in RTEMS.Name; C1 : out Character; @@ -1986,4 +1963,259 @@ package body RTEMS is end Debug_Is_Enabled; + -- + -- 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 Object_Get_Classic_Name( + ID : in RTEMS.ID; + Name : out RTEMS.Name; + Result : out RTEMS.Status_Codes + ) is + function Object_Get_Classic_Name_Base ( + ID : RTEMS.ID; + Name : access RTEMS.Name + ) return RTEMS.Status_Codes; + pragma Import + (C, Object_Get_Classic_Name_Base, "rtems_object_get_classic_name"); + Tmp_Name : aliased RTEMS.Name; + begin + -- TBD + Result := Object_Get_Classic_Name_Base (ID, Tmp_Name'Access); + Name := Tmp_Name; + end Object_Get_Classic_Name; + + + procedure Object_Get_Name( + ID : in RTEMS.ID; + Length : in RTEMS.Unsigned32; + Name : out String; + Result : out RTEMS.Status_Codes + ) is + function Object_Get_Name_Base ( + ID : RTEMS.ID; + -- Length : RTEMS.Unsigned32: + -- Name : chars_ptr; + Length : RTEMS.Unsigned32 + ) return RTEMS.Status_Codes; + pragma Import (C, Object_Get_Name_Base, "rtems_object_get_name"); + begin + -- TBD + Name := ""; + Result := Object_Get_Name_Base (Id, Length); + end Object_Get_Name; + + procedure Object_Set_Name( + ID : in RTEMS.ID; + Name : in String; + Result : out RTEMS.Status_Codes + ) is + function Object_Set_Name_Base ( + ID : RTEMS.ID; + Name : chars_ptr + ) return RTEMS.Status_Codes; + pragma Import (C, Object_Set_Name_Base, "rtems_object_set_name"); + NameAsCString : chars_ptr := New_String(Name); + begin + Result := Object_Set_Name_Base (ID, NameAsCString); + end Object_Set_Name; + + procedure Object_Id_Get_API( + ID : in RTEMS.ID; + API : out RTEMS.Unsigned32 + ) is + function Object_Id_Get_API_Base ( + ID : RTEMS.ID + ) return RTEMS.Unsigned32; + pragma Import (C, Object_Id_Get_API_Base, "rtems_object_id_get_api"); + begin + API := Object_Id_Get_API_Base (ID); + end Object_Id_Get_API; + + procedure Object_Id_Get_Class( + ID : in RTEMS.ID; + The_Class : out RTEMS.Unsigned32 + ) is + function Object_Id_Get_Class_Base ( + ID : RTEMS.ID + ) return RTEMS.Unsigned32; + pragma Import (C, Object_Id_Get_Class_Base, "rtems_object_id_get_class"); + begin + The_Class := Object_Id_Get_Class_Base (ID); + end Object_Id_Get_Class; + + procedure Object_Id_Get_Node( + ID : in RTEMS.ID; + Node : out RTEMS.Unsigned32 + ) is + function Object_Id_Get_Node_Base ( + ID : RTEMS.ID + ) return RTEMS.Unsigned32; + pragma Import (C, Object_Id_Get_Node_Base, "rtems_object_id_get_node"); + begin + Node := Object_Id_Get_Node_Base (ID); + end Object_Id_Get_Node; + + procedure Object_Id_Get_Index( + ID : in RTEMS.ID; + Index : out RTEMS.Unsigned32 + ) is + function Object_Id_Get_Index_Base ( + ID : RTEMS.ID + ) return RTEMS.Unsigned32; + pragma Import (C, Object_Id_Get_Index_Base, "rtems_object_id_get_index"); + begin + Index := Object_Id_Get_Index_Base (ID); + end Object_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 Object_Id_API_Minimum + return RTEMS.Unsigned32 is + function Object_Id_API_Minimum_Base return RTEMS.Unsigned32; + pragma Import + (C, Object_Id_API_Minimum_Base, "rtems_object_id_api_minimum"); + begin + return Object_Id_API_Minimum_Base; + end Object_Id_API_Minimum; + + function Object_Id_API_Maximum + return RTEMS.Unsigned32 is + function Object_Id_API_Maximum_Base return RTEMS.Unsigned32; + pragma Import + (C, Object_Id_API_Maximum_Base, "rtems_object_id_api_maximum"); + begin + return Object_Id_API_Maximum_Base; + end Object_Id_API_Maximum; + + procedure Object_API_Minimum_Class( + API : in RTEMS.Unsigned32; + Minimum : out RTEMS.Unsigned32 + ) is + function Object_API_Minimum_Class_Base ( + API : RTEMS.Unsigned32 + ) return RTEMS.Unsigned32; + pragma Import + (C, Object_API_Minimum_Class_Base, "rtems_object_api_minimum_class"); + begin + Minimum := Object_API_Minimum_Class_Base (API); + end Object_API_Minimum_Class; + + procedure Object_API_Maximum_Class( + API : in RTEMS.Unsigned32; + Maximum : out RTEMS.Unsigned32 + ) is + function Object_API_Maximum_Class_Base ( + API : RTEMS.Unsigned32 + ) return RTEMS.Unsigned32; + pragma Import + (C, Object_API_Maximum_Class_Base, "rtems_object_api_maximum_class"); + begin + Maximum := Object_API_Maximum_Class_Base (API); + end Object_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 Object_Get_API_Name( + API : in RTEMS.Unsigned32; + Name : out String + ) is + function Object_Get_API_Name_Base ( + API : RTEMS.Unsigned32 + ) return chars_ptr; + pragma Import (C, Object_Get_API_Name_Base, "rtems_object_get_api_name"); + Result : chars_ptr := Object_Get_API_Name_Base (API); + APIName : String := Value_Without_Exception (Result); + begin + Name := APIName; + end Object_Get_API_Name; + + procedure Object_Get_API_Class_Name( + The_API : in RTEMS.Unsigned32; + The_Class : in RTEMS.Unsigned32; + Name : out String + ) is + function Object_Get_API_Class_Name_Base ( + API : RTEMS.Unsigned32; + Class : RTEMS.Unsigned32 + ) return chars_ptr; + pragma Import + (C, Object_Get_API_Class_Name_Base, "rtems_object_get_api_class_name"); + Result : chars_ptr := Object_Get_API_Class_Name_Base (The_API, The_Class); + ClassName : String := Value_Without_Exception (Result); + begin + Name := ClassName; + end Object_Get_API_Class_Name; + + procedure Object_Get_Class_Information( + The_API : in RTEMS.Unsigned32; + The_Class : in RTEMS.Unsigned32; + Info : out RTEMS.Object_API_Class_Information; + Result : out RTEMS.Status_Codes + ) is + function Object_Get_Class_Information_Base ( + The_API : RTEMS.Unsigned32; + The_Class : RTEMS.Unsigned32; + Info : access RTEMS.Object_API_Class_Information + ) return RTEMS.Status_Codes; + pragma Import ( + C, + Object_Get_Class_Information_Base, + "rtems_object_get_class_information" + ); + TmpInfo : aliased RTEMS.Object_API_Class_Information; + begin + Result := Object_Get_Class_Information_Base + (The_API, The_Class, TmpInfo'Access); + Info := TmpInfo; + end Object_Get_Class_Information; + end RTEMS; diff --git a/c/src/ada/rtems.ads b/c/src/ada/rtems.ads index 4d67f72d15..7a995ae093 100644 --- a/c/src/ada/rtems.ads +++ b/c/src/ada/rtems.ads @@ -11,7 +11,7 @@ -- RTEMS initialization and configuration are called from -- the BSP side, therefore should never be called from ADA. -- --- COPYRIGHT (c) 1997-2007. +-- COPYRIGHT (c) 1997-2008. -- On-Line Applications Research Corporation (OAR). -- -- The license and distribution terms for this file may in @@ -531,13 +531,6 @@ pragma Elaborate_Body (RTEMS); Milliseconds : RTEMS.Unsigned32 ) return RTEMS.Interval; - function Build_Name ( - C1 : in Character; - C2 : in Character; - C3 : in Character; - C4 : in Character - ) return RTEMS.Name; - procedure Name_To_Characters ( Name : in RTEMS.Name; C1 : out Character; @@ -666,7 +659,7 @@ pragma Elaborate_Body (RTEMS); Note : in RTEMS.Unsigned32; Result : out RTEMS.Status_Codes ); - + type Task_Variable_Dtor is access procedure ( Argument : in RTEMS.Address ); @@ -1267,4 +1260,102 @@ pragma Elaborate_Body (RTEMS); Level : in RTEMS.Debug_Set ) return RTEMS.Boolean; + -- + -- Object Services + -- + + function Build_Name ( + C1 : in Character; + C2 : in Character; + C3 : in Character; + C4 : in Character + ) return RTEMS.Name; + + procedure Object_Get_Classic_Name( + ID : in RTEMS.ID; + Name : out RTEMS.Name; + Result : out RTEMS.Status_Codes + ); + + procedure Object_Get_Name( + ID : in RTEMS.ID; + Length : in RTEMS.Unsigned32; + Name : out String; + Result : out RTEMS.Status_Codes + ); + + procedure Object_Set_Name( + ID : in RTEMS.ID; + Name : in String; + Result : out RTEMS.Status_Codes + ); + + procedure Object_Id_Get_API( + ID : in RTEMS.ID; + API : out RTEMS.Unsigned32 + ); + + procedure Object_Id_Get_Class( + ID : in RTEMS.ID; + The_Class : out RTEMS.Unsigned32 + ); + + procedure Object_Id_Get_Node( + ID : in RTEMS.ID; + Node : out RTEMS.Unsigned32 + ); + + procedure Object_Id_Get_Index( + ID : in RTEMS.ID; + Index : out RTEMS.Unsigned32 + ); + + 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; + + function Object_Id_API_Minimum return RTEMS.Unsigned32; + + function Object_Id_API_Maximum return RTEMS.Unsigned32; + + procedure Object_API_Minimum_Class( + API : in RTEMS.Unsigned32; + Minimum : out RTEMS.Unsigned32 + ); + + procedure Object_API_Maximum_Class( + API : in RTEMS.Unsigned32; + Maximum : out RTEMS.Unsigned32 + ); + + procedure Object_Get_API_Name( + API : in RTEMS.Unsigned32; + Name : out String + ); + + procedure Object_Get_API_Class_Name( + The_API : in RTEMS.Unsigned32; + The_Class : in RTEMS.Unsigned32; + Name : out String + ); + + type Object_API_Class_Information is + record + Minimum_Id : RTEMS.Id; + Maximum_Id : RTEMS.Id; + Maximum : RTEMS.Unsigned32; + AutoExtend : RTEMS.Boolean; + Unallocated : RTEMS.Unsigned32; + end record; + + procedure Object_Get_Class_Information( + The_API : in RTEMS.Unsigned32; + The_Class : in RTEMS.Unsigned32; + Info : out RTEMS.Object_API_Class_Information; + Result : out RTEMS.Status_Codes + ); + end RTEMS; -- cgit v1.2.3