gcc/ada/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-2005, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with System; use System;
  35 with System.Storage_Elements; use System.Storage_Elements;
  36
  37 with Unchecked_Conversion;
  38
  39 package body Interfaces.C.Strings is
  40
  41    --  Note that the type chars_ptr has a pragma No_Strict_Aliasing in the
  42    --  spec, to prevent any assumptions about aliasing for values of this type,
  43    --  since arbitrary addresses can be converted, and it is quite likely that
  44    --  this type will in fact be used for aliasing values of other types.
  45
  46    function To_chars_ptr is
  47       new Unchecked_Conversion (Address, chars_ptr);
  48
  49    function To_Address is
  50       new Unchecked_Conversion (chars_ptr, Address);
  51
  52    -----------------------
  53    -- Local Subprograms --
  54    -----------------------
  55
  56    function Peek (From : chars_ptr) return char;
  57    pragma Inline (Peek);
  58    --  Given a chars_ptr value, obtain referenced character
  59
  60    procedure Poke (Value : char; Into : chars_ptr);
  61    pragma Inline (Poke);
  62    --  Given a chars_ptr, modify referenced Character value
  63
  64    function "+" (Left : chars_ptr; Right : size_t) return chars_ptr;
  65    pragma Inline ("+");
  66    --  Address arithmetic on chars_ptr value
  67
  68    function Position_Of_Nul (Into : char_array) return size_t;
  69    --  Returns position of the first Nul in Into or Into'Last + 1 if none
  70
  71    --  We can't use directly System.Memory because the categorization is not
  72    --  compatible, so we directly import here the malloc and free routines.
  73
  74    function Memory_Alloc (Size : size_t) return chars_ptr;
  75    pragma Import (C, Memory_Alloc, "__gnat_malloc");
  76
  77    procedure Memory_Free (Address : chars_ptr);
  78    pragma Import (C, Memory_Free, "__gnat_free");
  79
  80    ---------
  81    -- "+" --
  82    ---------
  83
  84    function "+" (Left : chars_ptr; Right : size_t) return chars_ptr is
  85    begin
  86       return To_chars_ptr (To_Address (Left) + Storage_Offset (Right));
  87    end "+";
  88
  89    ----------
  90    -- Free --
  91    ----------
  92
  93    procedure Free (Item : in out chars_ptr) is
  94    begin
  95       if Item = Null_Ptr then
  96          return;
  97       end if;
  98
  99       Memory_Free (Item);
 100       Item := Null_Ptr;
 101    end Free;
 102
 103    --------------------
 104    -- New_Char_Array --
 105    --------------------
 106
 107    function New_Char_Array (Chars : char_array) return chars_ptr is
 108       Index   : size_t;
 109       Pointer : chars_ptr;
 110
 111    begin
 112       --  Get index of position of null. If Index > Chars'last,
 113       --  nul is absent and must be added explicitly.
 114
 115       Index := Position_Of_Nul (Into => Chars);
 116       Pointer := Memory_Alloc ((Index - Chars'First + 1));
 117
 118       --  If nul is present, transfer string up to and including nul
 119
 120       if Index <= Chars'Last then
 121          Update (Item   => Pointer,
 122                  Offset => 0,
 123                  Chars  => Chars (Chars'First .. Index),
 124                  Check  => False);
 125       else
 126          --  If original string has no nul, transfer whole string and add
 127          --  terminator explicitly.
 128
 129          Update (Item   => Pointer,
 130                  Offset => 0,
 131                  Chars  => Chars,
 132                  Check  => False);
 133          Poke (nul, into => Pointer + size_t'(Chars'Length));
 134       end if;
 135
 136       return Pointer;
 137    end New_Char_Array;
 138
 139    ----------------
 140    -- New_String --
 141    ----------------
 142
 143    function New_String (Str : String) return chars_ptr is
 144    begin
 145       return New_Char_Array (To_C (Str));
 146    end New_String;
 147
 148    ----------
 149    -- Peek --
 150    ----------
 151
 152    function Peek (From : chars_ptr) return char is
 153    begin
 154       return char (From.all);
 155    end Peek;
 156
 157    ----------
 158    -- Poke --
 159    ----------
 160
 161    procedure Poke (Value : char; Into : chars_ptr) is
 162    begin
 163       Into.all := Character (Value);
 164    end Poke;
 165
 166    ---------------------
 167    -- Position_Of_Nul --
 168    ---------------------
 169
 170    function Position_Of_Nul (Into : char_array) return size_t is
 171    begin
 172       for J in Into'Range loop
 173          if Into (J) = nul then
 174             return J;
 175          end if;
 176       end loop;
 177
 178       return Into'Last + 1;
 179    end Position_Of_Nul;
 180
 181    ------------
 182    -- Strlen --
 183    ------------
 184
 185    function Strlen (Item : chars_ptr) return size_t is
 186       Item_Index : size_t := 0;
 187
 188    begin
 189       if Item = Null_Ptr then
 190          raise Dereference_Error;
 191       end if;
 192
 193       loop
 194          if Peek (Item + Item_Index) = nul then
 195             return Item_Index;
 196          end if;
 197
 198          Item_Index := Item_Index + 1;
 199       end loop;
 200    end Strlen;
 201
 202    ------------------
 203    -- To_Chars_Ptr --
 204    ------------------
 205
 206    function To_Chars_Ptr
 207      (Item      : char_array_access;
 208       Nul_Check : Boolean := False) return chars_ptr
 209    is
 210    begin
 211       if Item = null then
 212          return Null_Ptr;
 213       elsif Nul_Check
 214         and then Position_Of_Nul (Into => Item.all) > Item'Last
 215       then
 216          raise Terminator_Error;
 217       else
 218          return To_chars_ptr (Item (Item'First)'Address);
 219       end if;
 220    end To_Chars_Ptr;
 221
 222    ------------
 223    -- Update --
 224    ------------
 225
 226    procedure Update
 227      (Item   : chars_ptr;
 228       Offset : size_t;
 229       Chars  : char_array;
 230       Check  : Boolean := True)
 231    is
 232       Index : chars_ptr := Item + Offset;
 233
 234    begin
 235       if Check and then Offset + Chars'Length  > Strlen (Item) then
 236          raise Update_Error;
 237       end if;
 238
 239       for J in Chars'Range loop
 240          Poke (Chars (J), Into => Index);
 241          Index := Index + size_t'(1);
 242       end loop;
 243    end Update;
 244
 245    procedure Update
 246      (Item   : chars_ptr;
 247       Offset : size_t;
 248       Str    : String;
 249       Check  : Boolean := True)
 250    is
 251    begin
 252       --  Note: in RM 95, the Append_Nul => False parameter is omitted. But
 253       --  this has the unintended consequence of truncating the string after
 254       --  an update. As discussed in Ada 2005 AI-242, this was unintended,
 255       --  and should be corrected. Since this is a clear error, it seems
 256       --  appropriate to apply the correction in Ada 95 mode as well.
 257
 258       Update (Item, Offset, To_C (Str, Append_Nul => False), Check);
 259    end Update;
 260
 261    -----------
 262    -- Value --
 263    -----------
 264
 265    function Value (Item : chars_ptr) return char_array is
 266       Result : char_array (0 .. Strlen (Item));
 267
 268    begin
 269       if Item = Null_Ptr then
 270          raise Dereference_Error;
 271       end if;
 272
 273       --  Note that the following loop will also copy the terminating Nul
 274
 275       for J in Result'Range loop
 276          Result (J) := Peek (Item + J);
 277       end loop;
 278
 279       return Result;
 280    end Value;
 281
 282    function Value
 283      (Item   : chars_ptr;
 284       Length : size_t) return char_array
 285    is
 286    begin
 287       if Item = Null_Ptr then
 288          raise Dereference_Error;
 289       end if;
 290
 291       --  ACATS cxb3010 checks that Constraint_Error gets raised when Length
 292       --  is 0. Seems better to check that Length is not null before declaring
 293       --  an array with size_t bounds of 0 .. Length - 1 anyway.
 294
 295       if Length = 0 then
 296          raise Constraint_Error;
 297       end if;
 298
 299       declare
 300          Result : char_array (0 .. Length - 1);
 301
 302       begin
 303          for J in Result'Range loop
 304             Result (J) := Peek (Item + J);
 305
 306             if Result (J) = nul then
 307                return Result (0 .. J);
 308             end if;
 309          end loop;
 310
 311          return Result;
 312       end;
 313    end Value;
 314
 315    function Value (Item : chars_ptr) return String is
 316    begin
 317       return To_Ada (Value (Item));
 318    end Value;
 319
 320    function Value (Item : chars_ptr; Length : size_t) return String is
 321       Result : char_array (0 .. Length);
 322
 323    begin
 324       --  As per AI-00177, this is equivalent to:
 325
 326       --    To_Ada (Value (Item, Length) & nul);
 327
 328       if Item = Null_Ptr then
 329          raise Dereference_Error;
 330       end if;
 331
 332       for J in 0 .. Length - 1 loop
 333          Result (J) := Peek (Item + J);
 334
 335          if Result (J) = nul then
 336             return To_Ada (Result (0 .. J));
 337          end if;
 338       end loop;
 339
 340       Result (Length) := nul;
 341       return To_Ada (Result);
 342    end Value;
 343
 344 end Interfaces.C.Strings;