Warning, /cpukit/include/adainclude/rtems-object.adb is written in an unsupported language. File is not indexed.
0001 -- SPDX-License-Identifier: BSD-2-Clause
0002
0003 --
0004 -- RTEMS / Body
0005 --
0006 -- DESCRIPTION:
0007 --
0008 -- This package provides the interface to the RTEMS API.
0009 --
0010 --
0011 -- DEPENDENCIES:
0012 --
0013 --
0014 --
0015 -- COPYRIGHT (c) 1997-2011.
0016 -- On-Line Applications Research Corporation (OAR).
0017 --
0018 -- Redistribution and use in source and binary forms, with or without
0019 -- modification, are permitted provided that the following conditions
0020 -- are met:
0021 -- 1. Redistributions of source code must retain the above copyright
0022 -- notice, this list of conditions and the following disclaimer.
0023 -- 2. Redistributions in binary form must reproduce the above copyright
0024 -- notice, this list of conditions and the following disclaimer in the
0025 -- documentation and/or other materials provided with the distribution.
0026 --
0027 -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
0028 -- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
0029 -- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
0030 -- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
0031 -- LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
0032 -- CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
0033 -- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
0034 -- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
0035 -- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
0036 -- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
0037 -- POSSIBILITY OF SUCH DAMAGE.
0038 --
0039
0040 with Interfaces; use Interfaces;
0041 with Interfaces.C.Strings; use Interfaces.C.Strings;
0042
0043 package body RTEMS.Object is
0044
0045 --
0046 -- Object Services
0047 --
0048
0049 function Build_Name
0050 (C1 : in Character;
0051 C2 : in Character;
0052 C3 : in Character;
0053 C4 : in Character)
0054 return RTEMS.Name
0055 is
0056 C1_Value : RTEMS.Unsigned32;
0057 C2_Value : RTEMS.Unsigned32;
0058 C3_Value : RTEMS.Unsigned32;
0059 C4_Value : RTEMS.Unsigned32;
0060 begin
0061
0062 C1_Value := Character'Pos (C1);
0063 C2_Value := Character'Pos (C2);
0064 C3_Value := Character'Pos (C3);
0065 C4_Value := Character'Pos (C4);
0066
0067 return Interfaces.Shift_Left (C1_Value, 24) or
0068 Interfaces.Shift_Left (C2_Value, 16) or
0069 Interfaces.Shift_Left (C3_Value, 8) or
0070 C4_Value;
0071
0072 end Build_Name;
0073
0074 procedure Get_Classic_Name
0075 (ID : in RTEMS.ID;
0076 Name : out RTEMS.Name;
0077 Result : out RTEMS.Status_Codes)
0078 is
0079 function Get_Classic_Name_Base
0080 (ID : RTEMS.ID;
0081 Name : access RTEMS.Name)
0082 return RTEMS.Status_Codes;
0083 pragma Import
0084 (C,
0085 Get_Classic_Name_Base,
0086 "rtems_object_get_classic_name");
0087 Tmp_Name : aliased RTEMS.Name;
0088 begin
0089 Result := Get_Classic_Name_Base (ID, Tmp_Name'Access);
0090 Name := Tmp_Name;
0091 end Get_Classic_Name;
0092
0093 procedure Get_Name
0094 (ID : in RTEMS.ID;
0095 Name : out String;
0096 Result : out RTEMS.Address)
0097 is
0098 function Get_Name_Base
0099 (ID : RTEMS.ID;
0100 Length : RTEMS.Unsigned32;
0101 Name : RTEMS.Address)
0102 return RTEMS.Address;
0103 pragma Import (C, Get_Name_Base, "rtems_object_get_name");
0104 begin
0105 Name := (others => ASCII.NUL);
0106 Result :=
0107 Get_Name_Base (ID, Name'Length, Name (Name'First)'Address);
0108 end Get_Name;
0109
0110 procedure Set_Name
0111 (ID : in RTEMS.ID;
0112 Name : in String;
0113 Result : out RTEMS.Status_Codes)
0114 is
0115 function Set_Name_Base
0116 (ID : RTEMS.ID;
0117 Name : chars_ptr)
0118 return RTEMS.Status_Codes;
0119 pragma Import (C, Set_Name_Base, "rtems_object_set_name");
0120 NameAsCString : constant chars_ptr := New_String (Name);
0121 begin
0122 Result := Set_Name_Base (ID, NameAsCString);
0123 end Set_Name;
0124
0125 procedure Id_Get_API
0126 (ID : in RTEMS.ID;
0127 API : out RTEMS.Unsigned32)
0128 is
0129 function Id_Get_API_Base
0130 (ID : RTEMS.ID)
0131 return RTEMS.Unsigned32;
0132 pragma Import (C, Id_Get_API_Base, "rtems_object_id_get_api");
0133 begin
0134 API := Id_Get_API_Base (ID);
0135 end Id_Get_API;
0136
0137 procedure Id_Get_Class
0138 (ID : in RTEMS.ID;
0139 The_Class : out RTEMS.Unsigned32)
0140 is
0141 function Id_Get_Class_Base
0142 (ID : RTEMS.ID)
0143 return RTEMS.Unsigned32;
0144 pragma Import
0145 (C,
0146 Id_Get_Class_Base,
0147 "rtems_object_id_get_class");
0148 begin
0149 The_Class := Id_Get_Class_Base (ID);
0150 end Id_Get_Class;
0151
0152 procedure Id_Get_Node
0153 (ID : in RTEMS.ID;
0154 Node : out RTEMS.Unsigned32)
0155 is
0156 function Id_Get_Node_Base
0157 (ID : RTEMS.ID)
0158 return RTEMS.Unsigned32;
0159 pragma Import (C, Id_Get_Node_Base, "rtems_object_id_get_node");
0160 begin
0161 Node := Id_Get_Node_Base (ID);
0162 end Id_Get_Node;
0163
0164 procedure Id_Get_Index
0165 (ID : in RTEMS.ID;
0166 Index : out RTEMS.Unsigned32)
0167 is
0168 function Id_Get_Index_Base
0169 (ID : RTEMS.ID)
0170 return RTEMS.Unsigned32;
0171 pragma Import
0172 (C,
0173 Id_Get_Index_Base,
0174 "rtems_object_id_get_index");
0175 begin
0176 Index := Id_Get_Index_Base (ID);
0177 end Id_Get_Index;
0178
0179 function Build_Id
0180 (The_API : in RTEMS.Unsigned32;
0181 The_Class : in RTEMS.Unsigned32;
0182 The_Node : in RTEMS.Unsigned32;
0183 The_Index : in RTEMS.Unsigned32)
0184 return RTEMS.ID
0185 is
0186 function Build_Id_Base
0187 (The_API : RTEMS.Unsigned32;
0188 The_Class : RTEMS.Unsigned32;
0189 The_Node : RTEMS.Unsigned32;
0190 The_Index : RTEMS.Unsigned32)
0191 return RTEMS.ID;
0192 pragma Import (C, Build_Id_Base, "rtems_build_id");
0193 begin
0194 return Build_Id_Base (The_API, The_Class, The_Node, The_Index);
0195 end Build_Id;
0196
0197 function Id_API_Minimum return RTEMS.Unsigned32 is
0198 function Id_API_Minimum_Base return RTEMS.Unsigned32;
0199 pragma Import
0200 (C,
0201 Id_API_Minimum_Base,
0202 "rtems_object_id_api_minimum");
0203 begin
0204 return Id_API_Minimum_Base;
0205 end Id_API_Minimum;
0206
0207 function Id_API_Maximum return RTEMS.Unsigned32 is
0208 function Id_API_Maximum_Base return RTEMS.Unsigned32;
0209 pragma Import
0210 (C,
0211 Id_API_Maximum_Base,
0212 "rtems_object_id_api_maximum");
0213 begin
0214 return Id_API_Maximum_Base;
0215 end Id_API_Maximum;
0216
0217 procedure API_Minimum_Class
0218 (API : in RTEMS.Unsigned32;
0219 Minimum : out RTEMS.Unsigned32)
0220 is
0221 function API_Minimum_Class_Base
0222 (API : RTEMS.Unsigned32)
0223 return RTEMS.Unsigned32;
0224 pragma Import
0225 (C,
0226 API_Minimum_Class_Base,
0227 "rtems_object_api_minimum_class");
0228 begin
0229 Minimum := API_Minimum_Class_Base (API);
0230 end API_Minimum_Class;
0231
0232 procedure API_Maximum_Class
0233 (API : in RTEMS.Unsigned32;
0234 Maximum : out RTEMS.Unsigned32)
0235 is
0236 function API_Maximum_Class_Base
0237 (API : RTEMS.Unsigned32)
0238 return RTEMS.Unsigned32;
0239 pragma Import
0240 (C,
0241 API_Maximum_Class_Base,
0242 "rtems_object_api_maximum_class");
0243 begin
0244 Maximum := API_Maximum_Class_Base (API);
0245 end API_Maximum_Class;
0246
0247 -- Translate S from a C-style char* into an Ada String.
0248 -- If S is Null_Ptr, return "", don't raise an exception.
0249 -- Copied from Lovelace Tutorial
0250 function Value_Without_Exception (S : chars_ptr) return String is
0251 begin
0252 if S = Null_Ptr then
0253 return "";
0254 else
0255 return Value (S);
0256 end if;
0257 end Value_Without_Exception;
0258 pragma Inline (Value_Without_Exception);
0259
0260 procedure Get_API_Name
0261 (API : in RTEMS.Unsigned32;
0262 Name : out String)
0263 is
0264 function Get_API_Name_Base
0265 (API : RTEMS.Unsigned32)
0266 return chars_ptr;
0267 pragma Import
0268 (C,
0269 Get_API_Name_Base,
0270 "rtems_object_get_api_name");
0271 Result : constant chars_ptr := Get_API_Name_Base (API);
0272 APIName : constant String := Value_Without_Exception (Result);
0273 begin
0274 Name := APIName;
0275 end Get_API_Name;
0276
0277 procedure Get_API_Class_Name
0278 (The_API : in RTEMS.Unsigned32;
0279 The_Class : in RTEMS.Unsigned32;
0280 Name : out String)
0281 is
0282 function Get_API_Class_Name_Base
0283 (API : RTEMS.Unsigned32;
0284 Class : RTEMS.Unsigned32)
0285 return chars_ptr;
0286 pragma Import
0287 (C,
0288 Get_API_Class_Name_Base,
0289 "rtems_object_get_api_class_name");
0290 Result : constant chars_ptr :=
0291 Get_API_Class_Name_Base (The_API, The_Class);
0292 ClassName : constant String := Value_Without_Exception (Result);
0293 begin
0294 Name := ClassName;
0295 end Get_API_Class_Name;
0296
0297 procedure Get_Class_Information
0298 (The_API : in RTEMS.Unsigned32;
0299 The_Class : in RTEMS.Unsigned32;
0300 Info : out API_Class_Information;
0301 Result : out RTEMS.Status_Codes)
0302 is
0303 function Get_Class_Information_Base
0304 (The_API : RTEMS.Unsigned32;
0305 The_Class : RTEMS.Unsigned32;
0306 Info : access API_Class_Information)
0307 return RTEMS.Status_Codes;
0308 pragma Import
0309 (C,
0310 Get_Class_Information_Base,
0311 "rtems_object_get_class_information");
0312 TmpInfo : aliased API_Class_Information;
0313 begin
0314 Result :=
0315 Get_Class_Information_Base
0316 (The_API,
0317 The_Class,
0318 TmpInfo'Access);
0319 Info := TmpInfo;
0320 end Get_Class_Information;
0321
0322 end RTEMS.Object;
