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