gcc/ada/libgnat/i-cstrin.adb

   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-2017, 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
  32 with System; use System;
  33 with System.Storage_Elements; use System.Storage_Elements;
  34
  35 with Ada.Unchecked_Conversion;
  36
  37 package 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
 360 end Interfaces.C.Strings;