source: rtems/c/src/ada/rtems-object.adb @ c499856

4.115
Last change on this file since c499856 was c499856, checked in by Chris Johns <chrisj@…>, on Mar 20, 2014 at 9:10:47 PM

Change all references of rtems.com to rtems.org.

  • Property mode set to 100644
File size: 8.1 KB
Line 
1--
2--  RTEMS / Body
3--
4--  DESCRIPTION:
5--
6--  This package provides the interface to the RTEMS API.
7--
8--
9--  DEPENDENCIES:
10--
11--
12--
13--  COPYRIGHT (c) 1997-2011.
14--  On-Line Applications Research Corporation (OAR).
15--
16--  The license and distribution terms for this file may in
17--  the file LICENSE in this distribution or at
18--  http://www.rtems.org/license/LICENSE.
19--
20
21with Interfaces;           use Interfaces;
22with Interfaces.C.Strings; use Interfaces.C.Strings;
23
24package body RTEMS.Object is
25
26   --
27   --  Object Services
28   --
29
30   function Build_Name
31     (C1   : in Character;
32      C2   : in Character;
33      C3   : in Character;
34      C4   : in Character)
35      return RTEMS.Name
36   is
37      C1_Value : RTEMS.Unsigned32;
38      C2_Value : RTEMS.Unsigned32;
39      C3_Value : RTEMS.Unsigned32;
40      C4_Value : RTEMS.Unsigned32;
41   begin
42
43      C1_Value := Character'Pos (C1);
44      C2_Value := Character'Pos (C2);
45      C3_Value := Character'Pos (C3);
46      C4_Value := Character'Pos (C4);
47
48      return Interfaces.Shift_Left (C1_Value, 24) or
49             Interfaces.Shift_Left (C2_Value, 16) or
50             Interfaces.Shift_Left (C3_Value, 8) or
51             C4_Value;
52
53   end Build_Name;
54
55   procedure Get_Classic_Name
56     (ID     : in RTEMS.ID;
57      Name   : out RTEMS.Name;
58      Result : out RTEMS.Status_Codes)
59   is
60      function Get_Classic_Name_Base
61        (ID   : RTEMS.ID;
62         Name : access RTEMS.Name)
63         return RTEMS.Status_Codes;
64      pragma Import
65        (C,
66         Get_Classic_Name_Base,
67         "rtems_object_get_classic_name");
68      Tmp_Name : aliased RTEMS.Name;
69   begin
70      Result := Get_Classic_Name_Base (ID, Tmp_Name'Access);
71      Name   := Tmp_Name;
72   end Get_Classic_Name;
73
74   procedure Get_Name
75     (ID     : in RTEMS.ID;
76      Name   : out String;
77      Result : out RTEMS.Address)
78   is
79      function Get_Name_Base
80        (ID     : RTEMS.ID;
81         Length : RTEMS.Unsigned32;
82         Name   : RTEMS.Address)
83         return   RTEMS.Address;
84      pragma Import (C, Get_Name_Base, "rtems_object_get_name");
85   begin
86      Name   := (others => ASCII.NUL);
87      Result :=
88         Get_Name_Base (ID, Name'Length, Name (Name'First)'Address);
89   end Get_Name;
90
91   procedure Set_Name
92     (ID     : in RTEMS.ID;
93      Name   : in String;
94      Result : out RTEMS.Status_Codes)
95   is
96      function Set_Name_Base
97        (ID   : RTEMS.ID;
98         Name : chars_ptr)
99         return RTEMS.Status_Codes;
100      pragma Import (C, Set_Name_Base, "rtems_object_set_name");
101      NameAsCString : constant chars_ptr := New_String (Name);
102   begin
103      Result := Set_Name_Base (ID, NameAsCString);
104   end Set_Name;
105
106   procedure Id_Get_API
107     (ID  : in RTEMS.ID;
108      API : out RTEMS.Unsigned32)
109   is
110      function Id_Get_API_Base
111        (ID   : RTEMS.ID)
112         return RTEMS.Unsigned32;
113      pragma Import (C, Id_Get_API_Base, "rtems_object_id_get_api");
114   begin
115      API := Id_Get_API_Base (ID);
116   end Id_Get_API;
117
118   procedure Id_Get_Class
119     (ID        : in RTEMS.ID;
120      The_Class : out RTEMS.Unsigned32)
121   is
122      function Id_Get_Class_Base
123        (ID   : RTEMS.ID)
124         return RTEMS.Unsigned32;
125      pragma Import
126        (C,
127         Id_Get_Class_Base,
128         "rtems_object_id_get_class");
129   begin
130      The_Class := Id_Get_Class_Base (ID);
131   end Id_Get_Class;
132
133   procedure Id_Get_Node
134     (ID   : in RTEMS.ID;
135      Node : out RTEMS.Unsigned32)
136   is
137      function Id_Get_Node_Base
138        (ID   : RTEMS.ID)
139         return RTEMS.Unsigned32;
140      pragma Import (C, Id_Get_Node_Base, "rtems_object_id_get_node");
141   begin
142      Node := Id_Get_Node_Base (ID);
143   end Id_Get_Node;
144
145   procedure Id_Get_Index
146     (ID    : in RTEMS.ID;
147      Index : out RTEMS.Unsigned32)
148   is
149      function Id_Get_Index_Base
150        (ID   : RTEMS.ID)
151         return RTEMS.Unsigned32;
152      pragma Import
153        (C,
154         Id_Get_Index_Base,
155         "rtems_object_id_get_index");
156   begin
157      Index := Id_Get_Index_Base (ID);
158   end Id_Get_Index;
159
160   function Build_Id
161     (The_API   : in RTEMS.Unsigned32;
162      The_Class : in RTEMS.Unsigned32;
163      The_Node  : in RTEMS.Unsigned32;
164      The_Index : in RTEMS.Unsigned32)
165      return      RTEMS.ID
166   is
167      function Build_Id_Base
168        (The_API   : RTEMS.Unsigned32;
169         The_Class : RTEMS.Unsigned32;
170         The_Node  : RTEMS.Unsigned32;
171         The_Index : RTEMS.Unsigned32)
172         return      RTEMS.ID;
173      pragma Import (C, Build_Id_Base, "rtems_build_id");
174   begin
175      return Build_Id_Base (The_API, The_Class, The_Node, The_Index);
176   end Build_Id;
177
178   function Id_API_Minimum return  RTEMS.Unsigned32 is
179      function Id_API_Minimum_Base return  RTEMS.Unsigned32;
180      pragma Import
181        (C,
182         Id_API_Minimum_Base,
183         "rtems_object_id_api_minimum");
184   begin
185      return Id_API_Minimum_Base;
186   end Id_API_Minimum;
187
188   function Id_API_Maximum return  RTEMS.Unsigned32 is
189      function Id_API_Maximum_Base return  RTEMS.Unsigned32;
190      pragma Import
191        (C,
192         Id_API_Maximum_Base,
193         "rtems_object_id_api_maximum");
194   begin
195      return Id_API_Maximum_Base;
196   end Id_API_Maximum;
197
198   procedure API_Minimum_Class
199     (API     : in RTEMS.Unsigned32;
200      Minimum : out RTEMS.Unsigned32)
201   is
202      function API_Minimum_Class_Base
203        (API  : RTEMS.Unsigned32)
204         return RTEMS.Unsigned32;
205      pragma Import
206        (C,
207         API_Minimum_Class_Base,
208         "rtems_object_api_minimum_class");
209   begin
210      Minimum := API_Minimum_Class_Base (API);
211   end API_Minimum_Class;
212
213   procedure API_Maximum_Class
214     (API     : in RTEMS.Unsigned32;
215      Maximum : out RTEMS.Unsigned32)
216   is
217      function API_Maximum_Class_Base
218        (API  : RTEMS.Unsigned32)
219         return RTEMS.Unsigned32;
220      pragma Import
221        (C,
222         API_Maximum_Class_Base,
223         "rtems_object_api_maximum_class");
224   begin
225      Maximum := API_Maximum_Class_Base (API);
226   end API_Maximum_Class;
227
228   -- Translate S from a C-style char* into an Ada String.
229   -- If S is Null_Ptr, return "", don't raise an exception.
230   -- Copied from Lovelace Tutorial
231   function Value_Without_Exception (S : chars_ptr) return String is
232   begin
233      if S = Null_Ptr then
234         return "";
235      else
236         return Value (S);
237      end if;
238   end Value_Without_Exception;
239   pragma Inline (Value_Without_Exception);
240
241   procedure Get_API_Name
242     (API  : in RTEMS.Unsigned32;
243      Name : out String)
244   is
245      function Get_API_Name_Base
246        (API  : RTEMS.Unsigned32)
247         return chars_ptr;
248      pragma Import
249        (C,
250         Get_API_Name_Base,
251         "rtems_object_get_api_name");
252      Result  : constant chars_ptr := Get_API_Name_Base (API);
253      APIName : constant String    := Value_Without_Exception (Result);
254   begin
255      Name := APIName;
256   end Get_API_Name;
257
258   procedure Get_API_Class_Name
259     (The_API   : in RTEMS.Unsigned32;
260      The_Class : in RTEMS.Unsigned32;
261      Name      : out String)
262   is
263      function Get_API_Class_Name_Base
264        (API   : RTEMS.Unsigned32;
265         Class : RTEMS.Unsigned32)
266         return  chars_ptr;
267      pragma Import
268        (C,
269         Get_API_Class_Name_Base,
270         "rtems_object_get_api_class_name");
271      Result    : constant chars_ptr :=
272         Get_API_Class_Name_Base (The_API, The_Class);
273      ClassName : constant String    := Value_Without_Exception (Result);
274   begin
275      Name := ClassName;
276   end Get_API_Class_Name;
277
278   procedure Get_Class_Information
279     (The_API   : in RTEMS.Unsigned32;
280      The_Class : in RTEMS.Unsigned32;
281      Info      : out API_Class_Information;
282      Result    : out RTEMS.Status_Codes)
283   is
284      function Get_Class_Information_Base
285        (The_API   : RTEMS.Unsigned32;
286         The_Class : RTEMS.Unsigned32;
287         Info      : access API_Class_Information)
288         return      RTEMS.Status_Codes;
289      pragma Import
290        (C,
291         Get_Class_Information_Base,
292         "rtems_object_get_class_information");
293      TmpInfo : aliased API_Class_Information;
294   begin
295      Result :=
296         Get_Class_Information_Base
297           (The_API,
298            The_Class,
299            TmpInfo'Access);
300      Info   := TmpInfo;
301   end Get_Class_Information;
302
303end RTEMS.Object;
Note: See TracBrowser for help on using the repository browser.