1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- I N T E R F A C E S . C . S T R I N G S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with System; use System; 33with System.Storage_Elements; use System.Storage_Elements; 34 35with Ada.Unchecked_Conversion; 36 37package body Interfaces.C.Strings is 38 39 -- Note that the type chars_ptr has a pragma No_Strict_Aliasing in the 40 -- spec, to prevent any assumptions about aliasing for values of this type, 41 -- since arbitrary addresses can be converted, and it is quite likely that 42 -- this type will in fact be used for aliasing values of other types. 43 44 function To_chars_ptr is 45 new Ada.Unchecked_Conversion (System.Parameters.C_Address, chars_ptr); 46 47 function To_Address is 48 new Ada.Unchecked_Conversion (chars_ptr, System.Parameters.C_Address); 49 50 ----------------------- 51 -- Local Subprograms -- 52 ----------------------- 53 54 function Peek (From : chars_ptr) return char; 55 pragma Inline (Peek); 56 -- Given a chars_ptr value, obtain referenced character 57 58 procedure Poke (Value : char; Into : chars_ptr); 59 pragma Inline (Poke); 60 -- Given a chars_ptr, modify referenced Character value 61 62 function "+" (Left : chars_ptr; Right : size_t) return chars_ptr; 63 pragma Inline ("+"); 64 -- Address arithmetic on chars_ptr value 65 66 function Position_Of_Nul (Into : char_array) return size_t; 67 -- Returns position of the first Nul in Into or Into'Last + 1 if none 68 69 -- We can't use directly System.Memory because the categorization is not 70 -- compatible, so we directly import here the malloc and free routines. 71 72 function Memory_Alloc (Size : size_t) return chars_ptr; 73 pragma Import (C, Memory_Alloc, System.Parameters.C_Malloc_Linkname); 74 75 procedure Memory_Free (Address : chars_ptr); 76 pragma Import (C, Memory_Free, "__gnat_free"); 77 78 --------- 79 -- "+" -- 80 --------- 81 82 function "+" (Left : chars_ptr; Right : size_t) return chars_ptr is 83 begin 84 return To_chars_ptr (To_Address (Left) + Storage_Offset (Right)); 85 end "+"; 86 87 ---------- 88 -- Free -- 89 ---------- 90 91 procedure Free (Item : in out chars_ptr) is 92 begin 93 if Item = Null_Ptr then 94 return; 95 end if; 96 97 Memory_Free (Item); 98 Item := Null_Ptr; 99 end Free; 100 101 -------------------- 102 -- New_Char_Array -- 103 -------------------- 104 105 function New_Char_Array (Chars : char_array) return chars_ptr is 106 Index : size_t; 107 Pointer : chars_ptr; 108 109 begin 110 -- Get index of position of null. If Index > Chars'Last, 111 -- nul is absent and must be added explicitly. 112 113 Index := Position_Of_Nul (Into => Chars); 114 Pointer := Memory_Alloc ((Index - Chars'First + 1)); 115 116 -- If nul is present, transfer string up to and including nul 117 118 if Index <= Chars'Last then 119 Update (Item => Pointer, 120 Offset => 0, 121 Chars => Chars (Chars'First .. Index), 122 Check => False); 123 else 124 -- If original string has no nul, transfer whole string and add 125 -- terminator explicitly. 126 127 Update (Item => Pointer, 128 Offset => 0, 129 Chars => Chars, 130 Check => False); 131 Poke (nul, Into => Pointer + size_t'(Chars'Length)); 132 end if; 133 134 return Pointer; 135 end New_Char_Array; 136 137 ---------------- 138 -- New_String -- 139 ---------------- 140 141 function New_String (Str : String) return chars_ptr is 142 143 -- It's important that this subprogram uses the heap directly to compute 144 -- the result, and doesn't copy the string on the stack, otherwise its 145 -- use is limited when used from tasks on large strings. 146 147 Result : constant chars_ptr := Memory_Alloc (Str'Length + 1); 148 149 Result_Array : char_array (1 .. Str'Length + 1); 150 for Result_Array'Address use To_Address (Result); 151 pragma Import (Ada, Result_Array); 152 153 Count : size_t; 154 155 begin 156 To_C 157 (Item => Str, 158 Target => Result_Array, 159 Count => Count, 160 Append_Nul => True); 161 return Result; 162 end New_String; 163 164 ---------- 165 -- Peek -- 166 ---------- 167 168 function Peek (From : chars_ptr) return char is 169 begin 170 return char (From.all); 171 end Peek; 172 173 ---------- 174 -- Poke -- 175 ---------- 176 177 procedure Poke (Value : char; Into : chars_ptr) is 178 begin 179 Into.all := Character (Value); 180 end Poke; 181 182 --------------------- 183 -- Position_Of_Nul -- 184 --------------------- 185 186 function Position_Of_Nul (Into : char_array) return size_t is 187 begin 188 for J in Into'Range loop 189 if Into (J) = nul then 190 return J; 191 end if; 192 end loop; 193 194 return Into'Last + 1; 195 end Position_Of_Nul; 196 197 ------------ 198 -- Strlen -- 199 ------------ 200 201 function Strlen (Item : chars_ptr) return size_t is 202 Item_Index : size_t := 0; 203 204 begin 205 if Item = Null_Ptr then 206 raise Dereference_Error; 207 end if; 208 209 loop 210 if Peek (Item + Item_Index) = nul then 211 return Item_Index; 212 end if; 213 214 Item_Index := Item_Index + 1; 215 end loop; 216 end Strlen; 217 218 ------------------ 219 -- To_Chars_Ptr -- 220 ------------------ 221 222 function To_Chars_Ptr 223 (Item : char_array_access; 224 Nul_Check : Boolean := False) return chars_ptr 225 is 226 begin 227 if Item = null then 228 return Null_Ptr; 229 elsif Nul_Check 230 and then Position_Of_Nul (Into => Item.all) > Item'Last 231 then 232 raise Terminator_Error; 233 else 234 return To_chars_ptr (Item (Item'First)'Address); 235 end if; 236 end To_Chars_Ptr; 237 238 ------------ 239 -- Update -- 240 ------------ 241 242 procedure Update 243 (Item : chars_ptr; 244 Offset : size_t; 245 Chars : char_array; 246 Check : Boolean := True) 247 is 248 Index : chars_ptr := Item + Offset; 249 250 begin 251 if Check and then Offset + Chars'Length > Strlen (Item) then 252 raise Update_Error; 253 end if; 254 255 for J in Chars'Range loop 256 Poke (Chars (J), Into => Index); 257 Index := Index + size_t'(1); 258 end loop; 259 end Update; 260 261 procedure Update 262 (Item : chars_ptr; 263 Offset : size_t; 264 Str : String; 265 Check : Boolean := True) 266 is 267 begin 268 -- Note: in RM 95, the Append_Nul => False parameter is omitted. But 269 -- this has the unintended consequence of truncating the string after 270 -- an update. As discussed in Ada 2005 AI-242, this was unintended, 271 -- and should be corrected. Since this is a clear error, it seems 272 -- appropriate to apply the correction in Ada 95 mode as well. 273 274 Update (Item, Offset, To_C (Str, Append_Nul => False), Check); 275 end Update; 276 277 ----------- 278 -- Value -- 279 ----------- 280 281 function Value (Item : chars_ptr) return char_array is 282 Result : char_array (0 .. Strlen (Item)); 283 284 begin 285 if Item = Null_Ptr then 286 raise Dereference_Error; 287 end if; 288 289 -- Note that the following loop will also copy the terminating Nul 290 291 for J in Result'Range loop 292 Result (J) := Peek (Item + J); 293 end loop; 294 295 return Result; 296 end Value; 297 298 function Value 299 (Item : chars_ptr; 300 Length : size_t) return char_array 301 is 302 begin 303 if Item = Null_Ptr then 304 raise Dereference_Error; 305 end if; 306 307 -- ACATS cxb3010 checks that Constraint_Error gets raised when Length 308 -- is 0. Seems better to check that Length is not null before declaring 309 -- an array with size_t bounds of 0 .. Length - 1 anyway. 310 311 if Length = 0 then 312 raise Constraint_Error; 313 end if; 314 315 declare 316 Result : char_array (0 .. Length - 1); 317 318 begin 319 for J in Result'Range loop 320 Result (J) := Peek (Item + J); 321 322 if Result (J) = nul then 323 return Result (0 .. J); 324 end if; 325 end loop; 326 327 return Result; 328 end; 329 end Value; 330 331 function Value (Item : chars_ptr) return String is 332 begin 333 return To_Ada (Value (Item)); 334 end Value; 335 336 function Value (Item : chars_ptr; Length : size_t) return String is 337 Result : char_array (0 .. Length); 338 339 begin 340 -- As per AI-00177, this is equivalent to: 341 342 -- To_Ada (Value (Item, Length) & nul); 343 344 if Item = Null_Ptr then 345 raise Dereference_Error; 346 end if; 347 348 for J in 0 .. Length - 1 loop 349 Result (J) := Peek (Item + J); 350 351 if Result (J) = nul then 352 return To_Ada (Result (0 .. J)); 353 end if; 354 end loop; 355 356 Result (Length) := nul; 357 return To_Ada (Result); 358 end Value; 359 360end Interfaces.C.Strings; 361