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-2004 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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
  42    --  the spec, to prevent any assumptions about aliasing for values
  43    --  of this type, since arbitrary addresses can be converted, and it
  44    --  is quite likely that this type will in fact be used for aliasing
  45    --  values of other types.
  46
  47    function To_chars_ptr is
  48       new Unchecked_Conversion (Address, chars_ptr);
  49
  50    function To_Address is
  51       new Unchecked_Conversion (chars_ptr, Address);
  52
  53    -----------------------
  54    -- Local Subprograms --
  55    -----------------------
  56
  57    function Peek (From : chars_ptr) return char;
  58    pragma Inline (Peek);
  59    --  Given a chars_ptr value, obtain referenced character
  60
  61    procedure Poke (Value : char; Into : chars_ptr);
  62    pragma Inline (Poke);
  63    --  Given a chars_ptr, modify referenced Character value
  64
  65    function "+" (Left : chars_ptr; Right : size_t) return chars_ptr;
  66    pragma Inline ("+");
  67    --  Address arithmetic on chars_ptr value
  68
  69    function Position_Of_Nul (Into : char_array) return size_t;
  70    --  Returns position of the first Nul in Into or Into'Last + 1 if none
  71
  72    --  We can't use directly System.Memory because the categorization is not
  73    --  compatible, so we directly import here the malloc and free routines.
  74
  75    function Memory_Alloc (Size : size_t) return chars_ptr;
  76    pragma Import (C, Memory_Alloc, "__gnat_malloc");
  77
  78    procedure Memory_Free (Address : chars_ptr);
  79    pragma Import (C, Memory_Free, "__gnat_free");
  80
  81    ---------
  82    -- "+" --
  83    ---------
  84
  85    function "+" (Left : chars_ptr; Right : size_t) return chars_ptr is
  86    begin
  87       return To_chars_ptr (To_Address (Left) + Storage_Offset (Right));
  88    end "+";
  89
  90    ----------
  91    -- Free --
  92    ----------
  93
  94    procedure Free (Item : in out chars_ptr) is
  95    begin
  96       if Item = Null_Ptr then
  97          return;
  98       end if;
  99
 100       Memory_Free (Item);
 101       Item := Null_Ptr;
 102    end Free;
 103
 104    --------------------
 105    -- New_Char_Array --
 106    --------------------
 107
 108    function New_Char_Array (Chars : char_array) return chars_ptr is
 109       Index   : size_t;
 110       Pointer : chars_ptr;
 111
 112    begin
 113       --  Get index of position of null. If Index > Chars'last,
 114       --  nul is absent and must be added explicitly.
 115
 116       Index := Position_Of_Nul (Into => Chars);
 117       Pointer := Memory_Alloc ((Index - Chars'First + 1));
 118
 119       --  If nul is present, transfer string up to and including it.
 120
 121       if Index <= Chars'Last then
 122          Update (Item   => Pointer,
 123                  Offset => 0,
 124                  Chars  => Chars (Chars'First .. Index),
 125                  Check  => False);
 126       else
 127          --  If original string has no nul, transfer whole string and add
 128          --  terminator explicitly.
 129
 130          Update (Item   => Pointer,
 131                  Offset => 0,
 132                  Chars  => Chars,
 133                  Check  => False);
 134          Poke (nul, into => Pointer + size_t'(Chars'Length));
 135       end if;
 136
 137       return Pointer;
 138    end New_Char_Array;
 139
 140    ----------------
 141    -- New_String --
 142    ----------------
 143
 144    function New_String (Str : String) return chars_ptr is
 145    begin
 146       return New_Char_Array (To_C (Str));
 147    end New_String;
 148
 149    ----------
 150    -- Peek --
 151    ----------
 152
 153    function Peek (From : chars_ptr) return char is
 154    begin
 155       return char (From.all);
 156    end Peek;
 157
 158    ----------
 159    -- Poke --
 160    ----------
 161
 162    procedure Poke (Value : char; Into : chars_ptr) is
 163    begin
 164       Into.all := Character (Value);
 165    end Poke;
 166
 167    ---------------------
 168    -- Position_Of_Nul --
 169    ---------------------
 170
 171    function Position_Of_Nul (Into : char_array) return size_t is
 172    begin
 173       for J in Into'Range loop
 174          if Into (J) = nul then
 175             return J;
 176          end if;
 177       end loop;
 178
 179       return Into'Last + 1;
 180    end Position_Of_Nul;
 181
 182    ------------
 183    -- Strlen --
 184    ------------
 185
 186    function Strlen (Item : chars_ptr) return size_t is
 187       Item_Index : size_t := 0;
 188
 189    begin
 190       if Item = Null_Ptr then
 191          raise Dereference_Error;
 192       end if;
 193
 194       loop
 195          if Peek (Item + Item_Index) = nul then
 196             return Item_Index;
 197          end if;
 198
 199          Item_Index := Item_Index + 1;
 200       end loop;
 201    end Strlen;
 202
 203    ------------------
 204    -- To_Chars_Ptr --
 205    ------------------
 206
 207    function To_Chars_Ptr
 208      (Item      : char_array_access;
 209       Nul_Check : Boolean := False) return chars_ptr
 210    is
 211    begin
 212       if Item = null then
 213          return Null_Ptr;
 214       elsif Nul_Check
 215         and then Position_Of_Nul (Into => Item.all) > Item'Last
 216       then
 217          raise Terminator_Error;
 218       else
 219          return To_chars_ptr (Item (Item'First)'Address);
 220       end if;
 221    end To_Chars_Ptr;
 222
 223    ------------
 224    -- Update --
 225    ------------
 226
 227    procedure Update
 228      (Item   : chars_ptr;
 229       Offset : size_t;
 230       Chars  : char_array;
 231       Check  : Boolean := True)
 232    is
 233       Index : chars_ptr := Item + Offset;
 234
 235    begin
 236       if Check and then Offset + Chars'Length  > Strlen (Item) then
 237          raise Update_Error;
 238       end if;
 239
 240       for J in Chars'Range loop
 241          Poke (Chars (J), Into => Index);
 242          Index := Index + size_t'(1);
 243       end loop;
 244    end Update;
 245
 246    procedure Update
 247      (Item   : chars_ptr;
 248       Offset : size_t;
 249       Str    : String;
 250       Check  : Boolean := True)
 251    is
 252    begin
 253       Update (Item, Offset, To_C (Str), Check);
 254    end Update;
 255
 256    -----------
 257    -- Value --
 258    -----------
 259
 260    function Value (Item : chars_ptr) return char_array is
 261       Result : char_array (0 .. Strlen (Item));
 262
 263    begin
 264       if Item = Null_Ptr then
 265          raise Dereference_Error;
 266       end if;
 267
 268       --  Note that the following loop will also copy the terminating Nul
 269
 270       for J in Result'Range loop
 271          Result (J) := Peek (Item + J);
 272       end loop;
 273
 274       return Result;
 275    end Value;
 276
 277    function Value
 278      (Item   : chars_ptr;
 279       Length : size_t) return char_array
 280    is
 281    begin
 282       if Item = Null_Ptr then
 283          raise Dereference_Error;
 284       end if;
 285
 286       --  ACATS cxb3010 checks that Constraint_Error gets raised when Length
 287       --  is 0. Seems better to check that Length is not null before declaring
 288       --  an array with size_t bounds of 0 .. Length - 1 anyway.
 289
 290       if Length = 0 then
 291          raise Constraint_Error;
 292       end if;
 293
 294       declare
 295          Result : char_array (0 .. Length - 1);
 296
 297       begin
 298          for J in Result'Range loop
 299             Result (J) := Peek (Item + J);
 300
 301             if Result (J) = nul then
 302                return Result (0 .. J);
 303             end if;
 304          end loop;
 305
 306          return Result;
 307       end;
 308    end Value;
 309
 310    function Value (Item : chars_ptr) return String is
 311    begin
 312       return To_Ada (Value (Item));
 313    end Value;
 314
 315    function Value (Item : chars_ptr; Length : size_t) return String is
 316       Result : char_array (0 .. Length);
 317
 318    begin
 319       --  As per AI-00177, this is equivalent to
 320       --          To_Ada (Value (Item, Length) & nul);
 321
 322       if Item = Null_Ptr then
 323          raise Dereference_Error;
 324       end if;
 325
 326       for J in 0 .. Length - 1 loop
 327          Result (J) := Peek (Item + J);
 328
 329          if Result (J) = nul then
 330             return To_Ada (Result (0 .. J));
 331          end if;
 332       end loop;
 333
 334       Result (Length) := nul;
 335       return To_Ada (Result);
 336    end Value;
 337
 338 end Interfaces.C.Strings;