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 --                            $Revision: 1.15 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 package body Interfaces.C is
  37
  38    -----------------------
  39    -- Is_Nul_Terminated --
  40    -----------------------
  41
  42    --  Case of char_array
  43
  44    function Is_Nul_Terminated (Item : char_array) return Boolean is
  45    begin
  46       for J in Item'Range loop
  47          if Item (J) = nul then
  48             return True;
  49          end if;
  50       end loop;
  51
  52       return False;
  53    end Is_Nul_Terminated;
  54
  55    --  Case of wchar_array
  56
  57    function Is_Nul_Terminated (Item : wchar_array) return Boolean is
  58    begin
  59       for J in Item'Range loop
  60          if Item (J) = wide_nul then
  61             return True;
  62          end if;
  63       end loop;
  64
  65       return False;
  66    end Is_Nul_Terminated;
  67
  68    ------------
  69    -- To_Ada --
  70    ------------
  71
  72    --  Convert char to Character
  73
  74    function To_Ada (Item : char) return Character is
  75    begin
  76       return Character'Val (char'Pos (Item));
  77    end To_Ada;
  78
  79    --  Convert char_array to String (function form)
  80
  81    function To_Ada
  82      (Item     : char_array;
  83       Trim_Nul : Boolean := True)
  84       return     String
  85    is
  86       Count : Natural;
  87       From  : size_t;
  88
  89    begin
  90       if Trim_Nul then
  91          From := Item'First;
  92
  93          loop
  94             if From > Item'Last then
  95                raise Terminator_Error;
  96             elsif Item (From) = nul then
  97                exit;
  98             else
  99                From := From + 1;
 100             end if;
 101          end loop;
 102
 103          Count := Natural (From - Item'First);
 104
 105       else
 106          Count := Item'Length;
 107       end if;
 108
 109       declare
 110          R : String (1 .. Count);
 111
 112       begin
 113          for J in R'Range loop
 114             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 115          end loop;
 116
 117          return R;
 118       end;
 119    end To_Ada;
 120
 121    --  Convert char_array to String (procedure form)
 122
 123    procedure To_Ada
 124      (Item       : char_array;
 125       Target     : out String;
 126       Count      : out Natural;
 127       Trim_Nul   : Boolean := True)
 128    is
 129       From : size_t;
 130       To   : Positive;
 131
 132    begin
 133       if Trim_Nul then
 134          From := Item'First;
 135          loop
 136             if From > Item'Last then
 137                raise Terminator_Error;
 138             elsif Item (From) = nul then
 139                exit;
 140             else
 141                From := From + 1;
 142             end if;
 143          end loop;
 144
 145          Count := Natural (From - Item'First);
 146
 147       else
 148          Count := Item'Length;
 149       end if;
 150
 151       if Count > Target'Length then
 152          raise Constraint_Error;
 153
 154       else
 155          From := Item'First;
 156          To   := Target'First;
 157
 158          for J in 1 .. Count loop
 159             Target (To) := Character (Item (From));
 160             From := From + 1;
 161             To   := To + 1;
 162          end loop;
 163       end if;
 164
 165    end To_Ada;
 166
 167    --  Convert wchar_t to Wide_Character
 168
 169    function To_Ada (Item : wchar_t) return Wide_Character is
 170    begin
 171       return Wide_Character (Item);
 172    end To_Ada;
 173
 174    --  Convert wchar_array to Wide_String (function form)
 175
 176    function To_Ada
 177      (Item     : wchar_array;
 178       Trim_Nul : Boolean := True)
 179       return     Wide_String
 180    is
 181       Count : Natural;
 182       From  : size_t;
 183
 184    begin
 185       if Trim_Nul then
 186          From := Item'First;
 187
 188          loop
 189             if From > Item'Last then
 190                raise Terminator_Error;
 191             elsif Item (From) = wide_nul then
 192                exit;
 193             else
 194                From := From + 1;
 195             end if;
 196          end loop;
 197
 198          Count := Natural (From - Item'First);
 199
 200       else
 201          Count := Item'Length;
 202       end if;
 203
 204       declare
 205          R : Wide_String (1 .. Count);
 206
 207       begin
 208          for J in R'Range loop
 209             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 210          end loop;
 211
 212          return R;
 213       end;
 214    end To_Ada;
 215
 216    --  Convert wchar_array to Wide_String (procedure form)
 217
 218    procedure To_Ada
 219      (Item       : wchar_array;
 220       Target     : out Wide_String;
 221       Count      : out Natural;
 222       Trim_Nul   : Boolean := True)
 223    is
 224       From   : size_t;
 225       To     : Positive;
 226
 227    begin
 228       if Trim_Nul then
 229          From := Item'First;
 230          loop
 231             if From > Item'Last then
 232                raise Terminator_Error;
 233             elsif Item (From) = wide_nul then
 234                exit;
 235             else
 236                From := From + 1;
 237             end if;
 238          end loop;
 239
 240          Count := Natural (From - Item'First);
 241
 242       else
 243          Count := Item'Length;
 244       end if;
 245
 246       if Count > Target'Length then
 247          raise Constraint_Error;
 248
 249       else
 250          From := Item'First;
 251          To   := Target'First;
 252
 253          for J in 1 .. Count loop
 254             Target (To) := To_Ada (Item (From));
 255             From := From + 1;
 256             To   := To + 1;
 257          end loop;
 258       end if;
 259
 260    end To_Ada;
 261
 262    ----------
 263    -- To_C --
 264    ----------
 265
 266    --  Convert Character to char
 267
 268    function To_C (Item : Character) return char is
 269    begin
 270       return char'Val (Character'Pos (Item));
 271    end To_C;
 272
 273    --  Convert String to char_array (function form)
 274
 275    function To_C
 276      (Item       : String;
 277       Append_Nul : Boolean := True)
 278       return       char_array
 279    is
 280    begin
 281       if Append_Nul then
 282          declare
 283             R : char_array (0 .. Item'Length);
 284
 285          begin
 286             for J in Item'Range loop
 287                R (size_t (J - Item'First)) := To_C (Item (J));
 288             end loop;
 289
 290             R (R'Last) := nul;
 291             return R;
 292          end;
 293
 294       else -- Append_Nul is False
 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. This needs
 300          --  ARG resolution, but for now GNAT returns bounds 1 .. 0
 301
 302          if Item'Length = 0 then
 303             declare
 304                R : char_array (1 .. 0);
 305
 306             begin
 307                return R;
 308             end;
 309
 310          else
 311             declare
 312                R : char_array (0 .. Item'Length - 1);
 313
 314             begin
 315                for J in Item'Range loop
 316                   R (size_t (J - Item'First)) := To_C (Item (J));
 317                end loop;
 318
 319                return R;
 320             end;
 321          end if;
 322       end if;
 323    end To_C;
 324
 325    --  Convert String to char_array (procedure form)
 326
 327    procedure To_C
 328      (Item       : String;
 329       Target     : out char_array;
 330       Count      : out size_t;
 331       Append_Nul : Boolean := True)
 332    is
 333       To : size_t;
 334
 335    begin
 336       if Target'Length < Item'Length then
 337          raise Constraint_Error;
 338
 339       else
 340          To := Target'First;
 341          for From in Item'Range loop
 342             Target (To) := char (Item (From));
 343             To := To + 1;
 344          end loop;
 345
 346          if Append_Nul then
 347             if To > Target'Last then
 348                raise Constraint_Error;
 349             else
 350                Target (To) := nul;
 351                Count := Item'Length + 1;
 352             end if;
 353
 354          else
 355             Count := Item'Length;
 356          end if;
 357       end if;
 358    end To_C;
 359
 360    --  Convert Wide_Character to wchar_t
 361
 362    function To_C (Item : Wide_Character) return wchar_t is
 363    begin
 364       return wchar_t (Item);
 365    end To_C;
 366
 367    --  Convert Wide_String to wchar_array (function form)
 368
 369    function To_C
 370      (Item       : Wide_String;
 371       Append_Nul : Boolean := True)
 372       return       wchar_array
 373    is
 374    begin
 375       if Append_Nul then
 376          declare
 377             R : wchar_array (0 .. Item'Length);
 378
 379          begin
 380             for J in Item'Range loop
 381                R (size_t (J - Item'First)) := To_C (Item (J));
 382             end loop;
 383
 384             R (R'Last) := wide_nul;
 385             return R;
 386          end;
 387
 388       else
 389          --  A nasty case, if the string is null, we must return
 390          --  a null char_array. The lower bound of this array is
 391          --  required to be zero (RM B.3(50)) but that is of course
 392          --  impossible given that size_t is unsigned. This needs
 393          --  ARG resolution, but for now GNAT returns bounds 1 .. 0
 394
 395          if Item'Length = 0 then
 396             declare
 397                R : wchar_array (1 .. 0);
 398
 399             begin
 400                return R;
 401             end;
 402
 403          else
 404             declare
 405                R : wchar_array (0 .. Item'Length - 1);
 406
 407             begin
 408                for J in size_t range 0 .. Item'Length - 1 loop
 409                   R (J) := To_C (Item (Integer (J) + Item'First));
 410                end loop;
 411
 412                return R;
 413             end;
 414          end if;
 415       end if;
 416    end To_C;
 417
 418    --  Convert Wide_String to wchar_array (procedure form)
 419
 420    procedure To_C
 421      (Item       : Wide_String;
 422       Target     : out wchar_array;
 423       Count      : out size_t;
 424       Append_Nul : Boolean := True)
 425    is
 426       To : size_t;
 427
 428    begin
 429       if Target'Length < Item'Length then
 430          raise Constraint_Error;
 431
 432       else
 433          To := Target'First;
 434          for From in Item'Range loop
 435             Target (To) := To_C (Item (From));
 436             To := To + 1;
 437          end loop;
 438
 439          if Append_Nul then
 440             if To > Target'Last then
 441                raise Constraint_Error;
 442             else
 443                Target (To) := wide_nul;
 444                Count := Item'Length + 1;
 445             end if;
 446
 447          else
 448             Count := Item'Length;
 449          end if;
 450       end if;
 451    end To_C;
 452
 453 end Interfaces.C;