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