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

4.115
Last change on this file since 1987020 was 1987020, checked in by Joel Sherrill <joel.sherrill@…>, on 02/16/11 at 15:52:29

2011-02-16 Joel Sherrill <joel.sherrill@…>

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