gcc/ada/i-c.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                         I N T E R F A C E S . C                          --
   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 package body Interfaces.C is
  35
  36    -----------------------
  37    -- Is_Nul_Terminated --
  38    -----------------------
  39
  40    --  Case of char_array
  41
  42    function Is_Nul_Terminated (Item : char_array) return Boolean is
  43    begin
  44       for J in Item'Range loop
  45          if Item (J) = nul then
  46             return True;
  47          end if;
  48       end loop;
  49
  50       return False;
  51    end Is_Nul_Terminated;
  52
  53    --  Case of wchar_array
  54
  55    function Is_Nul_Terminated (Item : wchar_array) return Boolean is
  56    begin
  57       for J in Item'Range loop
  58          if Item (J) = wide_nul then
  59             return True;
  60          end if;
  61       end loop;
  62
  63       return False;
  64    end Is_Nul_Terminated;
  65
  66    ------------
  67    -- To_Ada --
  68    ------------
  69
  70    --  Convert char to Character
  71
  72    function To_Ada (Item : char) return Character is
  73    begin
  74       return Character'Val (char'Pos (Item));
  75    end To_Ada;
  76
  77    --  Convert char_array to String (function form)
  78
  79    function To_Ada
  80      (Item     : char_array;
  81       Trim_Nul : Boolean := True)
  82       return     String
  83    is
  84       Count : Natural;
  85       From  : size_t;
  86
  87    begin
  88       if Trim_Nul then
  89          From := Item'First;
  90
  91          loop
  92             if From > Item'Last then
  93                raise Terminator_Error;
  94             elsif Item (From) = nul then
  95                exit;
  96             else
  97                From := From + 1;
  98             end if;
  99          end loop;
 100
 101          Count := Natural (From - Item'First);
 102
 103       else
 104          Count := Item'Length;
 105       end if;
 106
 107       declare
 108          R : String (1 .. Count);
 109
 110       begin
 111          for J in R'Range loop
 112             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 113          end loop;
 114
 115          return R;
 116       end;
 117    end To_Ada;
 118
 119    --  Convert char_array to String (procedure form)
 120
 121    procedure To_Ada
 122      (Item       : char_array;
 123       Target     : out String;
 124       Count      : out Natural;
 125       Trim_Nul   : Boolean := True)
 126    is
 127       From : size_t;
 128       To   : Positive;
 129
 130    begin
 131       if Trim_Nul then
 132          From := Item'First;
 133          loop
 134             if From > Item'Last then
 135                raise Terminator_Error;
 136             elsif Item (From) = nul then
 137                exit;
 138             else
 139                From := From + 1;
 140             end if;
 141          end loop;
 142
 143          Count := Natural (From - Item'First);
 144
 145       else
 146          Count := Item'Length;
 147       end if;
 148
 149       if Count > Target'Length then
 150          raise Constraint_Error;
 151
 152       else
 153          From := Item'First;
 154          To   := Target'First;
 155
 156          for J in 1 .. Count loop
 157             Target (To) := Character (Item (From));
 158             From := From + 1;
 159             To   := To + 1;
 160          end loop;
 161       end if;
 162
 163    end To_Ada;
 164
 165    --  Convert wchar_t to Wide_Character
 166
 167    function To_Ada (Item : wchar_t) return Wide_Character is
 168    begin
 169       return Wide_Character (Item);
 170    end To_Ada;
 171
 172    --  Convert wchar_array to Wide_String (function form)
 173
 174    function To_Ada
 175      (Item     : wchar_array;
 176       Trim_Nul : Boolean := True)
 177       return     Wide_String
 178    is
 179       Count : Natural;
 180       From  : size_t;
 181
 182    begin
 183       if Trim_Nul then
 184          From := Item'First;
 185
 186          loop
 187             if From > Item'Last then
 188                raise Terminator_Error;
 189             elsif Item (From) = wide_nul then
 190                exit;
 191             else
 192                From := From + 1;
 193             end if;
 194          end loop;
 195
 196          Count := Natural (From - Item'First);
 197
 198       else
 199          Count := Item'Length;
 200       end if;
 201
 202       declare
 203          R : Wide_String (1 .. Count);
 204
 205       begin
 206          for J in R'Range loop
 207             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 208          end loop;
 209
 210          return R;
 211       end;
 212    end To_Ada;
 213
 214    --  Convert wchar_array to Wide_String (procedure form)
 215
 216    procedure To_Ada
 217      (Item       : wchar_array;
 218       Target     : out Wide_String;
 219       Count      : out Natural;
 220       Trim_Nul   : Boolean := True)
 221    is
 222       From   : size_t;
 223       To     : Positive;
 224
 225    begin
 226       if Trim_Nul then
 227          From := Item'First;
 228          loop
 229             if From > Item'Last then
 230                raise Terminator_Error;
 231             elsif Item (From) = wide_nul then
 232                exit;
 233             else
 234                From := From + 1;
 235             end if;
 236          end loop;
 237
 238          Count := Natural (From - Item'First);
 239
 240       else
 241          Count := Item'Length;
 242       end if;
 243
 244       if Count > Target'Length then
 245          raise Constraint_Error;
 246
 247       else
 248          From := Item'First;
 249          To   := Target'First;
 250
 251          for J in 1 .. Count loop
 252             Target (To) := To_Ada (Item (From));
 253             From := From + 1;
 254             To   := To + 1;
 255          end loop;
 256       end if;
 257
 258    end To_Ada;
 259
 260    ----------
 261    -- To_C --
 262    ----------
 263
 264    --  Convert Character to char
 265
 266    function To_C (Item : Character) return char is
 267    begin
 268       return char'Val (Character'Pos (Item));
 269    end To_C;
 270
 271    --  Convert String to char_array (function form)
 272
 273    function To_C
 274      (Item       : String;
 275       Append_Nul : Boolean := True)
 276       return       char_array
 277    is
 278    begin
 279       if Append_Nul then
 280          declare
 281             R : char_array (0 .. Item'Length);
 282
 283          begin
 284             for J in Item'Range loop
 285                R (size_t (J - Item'First)) := To_C (Item (J));
 286             end loop;
 287
 288             R (R'Last) := nul;
 289             return R;
 290          end;
 291
 292       --  Append_Nul False
 293
 294       else
 295
 296          --  A nasty case, if the string is null, we must return
 297          --  a null char_array. The lower bound of this array is
 298          --  required to be zero (RM B.3(50)) but that is of course
 299          --  impossible given that size_t is unsigned. According to
 300          --  Ada 2005 AI-258, the result is to raise Constraint_Error.
 301
 302          if Item'Length = 0 then
 303             raise Constraint_Error;
 304
 305          --  Normal case
 306
 307          else
 308             declare
 309                R : char_array (0 .. Item'Length - 1);
 310
 311             begin
 312                for J in Item'Range loop
 313                   R (size_t (J - Item'First)) := To_C (Item (J));
 314                end loop;
 315
 316                return R;
 317             end;
 318          end if;
 319       end if;
 320    end To_C;
 321
 322    --  Convert String to char_array (procedure form)
 323
 324    procedure To_C
 325      (Item       : String;
 326       Target     : out char_array;
 327       Count      : out size_t;
 328       Append_Nul : Boolean := True)
 329    is
 330       To : size_t;
 331
 332    begin
 333       if Target'Length < Item'Length then
 334          raise Constraint_Error;
 335
 336       else
 337          To := Target'First;
 338          for From in Item'Range loop
 339             Target (To) := char (Item (From));
 340             To := To + 1;
 341          end loop;
 342
 343          if Append_Nul then
 344             if To > Target'Last then
 345                raise Constraint_Error;
 346             else
 347                Target (To) := nul;
 348                Count := Item'Length + 1;
 349             end if;
 350
 351          else
 352             Count := Item'Length;
 353          end if;
 354       end if;
 355    end To_C;
 356
 357    --  Convert Wide_Character to wchar_t
 358
 359    function To_C (Item : Wide_Character) return wchar_t is
 360    begin
 361       return wchar_t (Item);
 362    end To_C;
 363
 364    --  Convert Wide_String to wchar_array (function form)
 365
 366    function To_C
 367      (Item       : Wide_String;
 368       Append_Nul : Boolean := True)
 369       return       wchar_array
 370    is
 371    begin
 372       if Append_Nul then
 373          declare
 374             R : wchar_array (0 .. Item'Length);
 375
 376          begin
 377             for J in Item'Range loop
 378                R (size_t (J - Item'First)) := To_C (Item (J));
 379             end loop;
 380
 381             R (R'Last) := wide_nul;
 382             return R;
 383          end;
 384
 385       else
 386          --  A nasty case, if the string is null, we must return
 387          --  a null char_array. The lower bound of this array is
 388          --  required to be zero (RM B.3(50)) but that is of course
 389          --  impossible given that size_t is unsigned. This needs
 390          --  ARG resolution, but for now GNAT returns bounds 1 .. 0
 391
 392          if Item'Length = 0 then
 393             declare
 394                R : wchar_array (1 .. 0);
 395
 396             begin
 397                return R;
 398             end;
 399
 400          else
 401             declare
 402                R : wchar_array (0 .. Item'Length - 1);
 403
 404             begin
 405                for J in size_t range 0 .. Item'Length - 1 loop
 406                   R (J) := To_C (Item (Integer (J) + Item'First));
 407                end loop;
 408
 409                return R;
 410             end;
 411          end if;
 412       end if;
 413    end To_C;
 414
 415    --  Convert Wide_String to wchar_array (procedure form)
 416
 417    procedure To_C
 418      (Item       : Wide_String;
 419       Target     : out wchar_array;
 420       Count      : out size_t;
 421       Append_Nul : Boolean := True)
 422    is
 423       To : size_t;
 424
 425    begin
 426       if Target'Length < Item'Length then
 427          raise Constraint_Error;
 428
 429       else
 430          To := Target'First;
 431          for From in Item'Range loop
 432             Target (To) := To_C (Item (From));
 433             To := To + 1;
 434          end loop;
 435
 436          if Append_Nul then
 437             if To > Target'Last then
 438                raise Constraint_Error;
 439             else
 440                Target (To) := wide_nul;
 441                Count := Item'Length + 1;
 442             end if;
 443
 444          else
 445             Count := Item'Length;
 446          end if;
 447       end if;
 448    end To_C;
 449
 450 end Interfaces.C;