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-2009, 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 (Address, chars_ptr);
  46
  47    function To_Address is
  48       new Ada.Unchecked_Conversion (chars_ptr, 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, "__gnat_malloc");
  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    begin
 143       return New_Char_Array (To_C (Str));
 144    end New_String;
 145
 146    ----------
 147    -- Peek --
 148    ----------
 149
 150    function Peek (From : chars_ptr) return char is
 151    begin
 152       return char (From.all);
 153    end Peek;
 154
 155    ----------
 156    -- Poke --
 157    ----------
 158
 159    procedure Poke (Value : char; Into : chars_ptr) is
 160    begin
 161       Into.all := Character (Value);
 162    end Poke;
 163
 164    ---------------------
 165    -- Position_Of_Nul --
 166    ---------------------
 167
 168    function Position_Of_Nul (Into : char_array) return size_t is
 169    begin
 170       for J in Into'Range loop
 171          if Into (J) = nul then
 172             return J;
 173          end if;
 174       end loop;
 175
 176       return Into'Last + 1;
 177    end Position_Of_Nul;
 178
 179    ------------
 180    -- Strlen --
 181    ------------
 182
 183    function Strlen (Item : chars_ptr) return size_t is
 184       Item_Index : size_t := 0;
 185
 186    begin
 187       if Item = Null_Ptr then
 188          raise Dereference_Error;
 189       end if;
 190
 191       loop
 192          if Peek (Item + Item_Index) = nul then
 193             return Item_Index;
 194          end if;
 195
 196          Item_Index := Item_Index + 1;
 197       end loop;
 198    end Strlen;
 199
 200    ------------------
 201    -- To_Chars_Ptr --
 202    ------------------
 203
 204    function To_Chars_Ptr
 205      (Item      : char_array_access;
 206       Nul_Check : Boolean := False) return chars_ptr
 207    is
 208    begin
 209       if Item = null then
 210          return Null_Ptr;
 211       elsif Nul_Check
 212         and then Position_Of_Nul (Into => Item.all) > Item'Last
 213       then
 214          raise Terminator_Error;
 215       else
 216          return To_chars_ptr (Item (Item'First)'Address);
 217       end if;
 218    end To_Chars_Ptr;
 219
 220    ------------
 221    -- Update --
 222    ------------
 223
 224    procedure Update
 225      (Item   : chars_ptr;
 226       Offset : size_t;
 227       Chars  : char_array;
 228       Check  : Boolean := True)
 229    is
 230       Index : chars_ptr := Item + Offset;
 231
 232    begin
 233       if Check and then Offset + Chars'Length  > Strlen (Item) then
 234          raise Update_Error;
 235       end if;
 236
 237       for J in Chars'Range loop
 238          Poke (Chars (J), Into => Index);
 239          Index := Index + size_t'(1);
 240       end loop;
 241    end Update;
 242
 243    procedure Update
 244      (Item   : chars_ptr;
 245       Offset : size_t;
 246       Str    : String;
 247       Check  : Boolean := True)
 248    is
 249    begin
 250       --  Note: in RM 95, the Append_Nul => False parameter is omitted. But
 251       --  this has the unintended consequence of truncating the string after
 252       --  an update. As discussed in Ada 2005 AI-242, this was unintended,
 253       --  and should be corrected. Since this is a clear error, it seems
 254       --  appropriate to apply the correction in Ada 95 mode as well.
 255
 256       Update (Item, Offset, To_C (Str, Append_Nul => False), Check);
 257    end Update;
 258
 259    -----------
 260    -- Value --
 261    -----------
 262
 263    function Value (Item : chars_ptr) return char_array is
 264       Result : char_array (0 .. Strlen (Item));
 265
 266    begin
 267       if Item = Null_Ptr then
 268          raise Dereference_Error;
 269       end if;
 270
 271       --  Note that the following loop will also copy the terminating Nul
 272
 273       for J in Result'Range loop
 274          Result (J) := Peek (Item + J);
 275       end loop;
 276
 277       return Result;
 278    end Value;
 279
 280    function Value
 281      (Item   : chars_ptr;
 282       Length : size_t) return char_array
 283    is
 284    begin
 285       if Item = Null_Ptr then
 286          raise Dereference_Error;
 287       end if;
 288
 289       --  ACATS cxb3010 checks that Constraint_Error gets raised when Length
 290       --  is 0. Seems better to check that Length is not null before declaring
 291       --  an array with size_t bounds of 0 .. Length - 1 anyway.
 292
 293       if Length = 0 then
 294          raise Constraint_Error;
 295       end if;
 296
 297       declare
 298          Result : char_array (0 .. Length - 1);
 299
 300       begin
 301          for J in Result'Range loop
 302             Result (J) := Peek (Item + J);
 303
 304             if Result (J) = nul then
 305                return Result (0 .. J);
 306             end if;
 307          end loop;
 308
 309          return Result;
 310       end;
 311    end Value;
 312
 313    function Value (Item : chars_ptr) return String is
 314    begin
 315       return To_Ada (Value (Item));
 316    end Value;
 317
 318    function Value (Item : chars_ptr; Length : size_t) return String is
 319       Result : char_array (0 .. Length);
 320
 321    begin
 322       --  As per AI-00177, this is equivalent to:
 323
 324       --    To_Ada (Value (Item, Length) & nul);
 325
 326       if Item = Null_Ptr then
 327          raise Dereference_Error;
 328       end if;
 329
 330       for J in 0 .. Length - 1 loop
 331          Result (J) := Peek (Item + J);
 332
 333          if Result (J) = nul then
 334             return To_Ada (Result (0 .. J));
 335          end if;
 336       end loop;
 337
 338       Result (Length) := nul;
 339       return To_Ada (Result);
 340    end Value;
 341
 342 end Interfaces.C.Strings;