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-2009, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 package body Interfaces.C is
  33
  34    -----------------------
  35    -- Is_Nul_Terminated --
  36    -----------------------
  37
  38    --  Case of char_array
  39
  40    function Is_Nul_Terminated (Item : char_array) return Boolean is
  41    begin
  42       for J in Item'Range loop
  43          if Item (J) = nul then
  44             return True;
  45          end if;
  46       end loop;
  47
  48       return False;
  49    end Is_Nul_Terminated;
  50
  51    --  Case of wchar_array
  52
  53    function Is_Nul_Terminated (Item : wchar_array) return Boolean is
  54    begin
  55       for J in Item'Range loop
  56          if Item (J) = wide_nul then
  57             return True;
  58          end if;
  59       end loop;
  60
  61       return False;
  62    end Is_Nul_Terminated;
  63
  64    --  Case of char16_array
  65
  66    function Is_Nul_Terminated (Item : char16_array) return Boolean is
  67    begin
  68       for J in Item'Range loop
  69          if Item (J) = char16_nul then
  70             return True;
  71          end if;
  72       end loop;
  73
  74       return False;
  75    end Is_Nul_Terminated;
  76
  77    --  Case of char32_array
  78
  79    function Is_Nul_Terminated (Item : char32_array) return Boolean is
  80    begin
  81       for J in Item'Range loop
  82          if Item (J) = char32_nul then
  83             return True;
  84          end if;
  85       end loop;
  86
  87       return False;
  88    end Is_Nul_Terminated;
  89
  90    ------------
  91    -- To_Ada --
  92    ------------
  93
  94    --  Convert char to Character
  95
  96    function To_Ada (Item : char) return Character is
  97    begin
  98       return Character'Val (char'Pos (Item));
  99    end To_Ada;
 100
 101    --  Convert char_array to String (function form)
 102
 103    function To_Ada
 104      (Item     : char_array;
 105       Trim_Nul : Boolean := True) return String
 106    is
 107       Count : Natural;
 108       From  : size_t;
 109
 110    begin
 111       if Trim_Nul then
 112          From := Item'First;
 113
 114          loop
 115             if From > Item'Last then
 116                raise Terminator_Error;
 117             elsif Item (From) = nul then
 118                exit;
 119             else
 120                From := From + 1;
 121             end if;
 122          end loop;
 123
 124          Count := Natural (From - Item'First);
 125
 126       else
 127          Count := Item'Length;
 128       end if;
 129
 130       declare
 131          R : String (1 .. Count);
 132
 133       begin
 134          for J in R'Range loop
 135             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 136          end loop;
 137
 138          return R;
 139       end;
 140    end To_Ada;
 141
 142    --  Convert char_array to String (procedure form)
 143
 144    procedure To_Ada
 145      (Item     : char_array;
 146       Target   : out String;
 147       Count    : out Natural;
 148       Trim_Nul : Boolean := True)
 149    is
 150       From : size_t;
 151       To   : Positive;
 152
 153    begin
 154       if Trim_Nul then
 155          From := Item'First;
 156          loop
 157             if From > Item'Last then
 158                raise Terminator_Error;
 159             elsif Item (From) = nul then
 160                exit;
 161             else
 162                From := From + 1;
 163             end if;
 164          end loop;
 165
 166          Count := Natural (From - Item'First);
 167
 168       else
 169          Count := Item'Length;
 170       end if;
 171
 172       if Count > Target'Length then
 173          raise Constraint_Error;
 174
 175       else
 176          From := Item'First;
 177          To   := Target'First;
 178
 179          for J in 1 .. Count loop
 180             Target (To) := Character (Item (From));
 181             From := From + 1;
 182             To   := To + 1;
 183          end loop;
 184       end if;
 185
 186    end To_Ada;
 187
 188    --  Convert wchar_t to Wide_Character
 189
 190    function To_Ada (Item : wchar_t) return Wide_Character is
 191    begin
 192       return Wide_Character (Item);
 193    end To_Ada;
 194
 195    --  Convert wchar_array to Wide_String (function form)
 196
 197    function To_Ada
 198      (Item     : wchar_array;
 199       Trim_Nul : Boolean := True) return Wide_String
 200    is
 201       Count : Natural;
 202       From  : size_t;
 203
 204    begin
 205       if Trim_Nul then
 206          From := Item'First;
 207
 208          loop
 209             if From > Item'Last then
 210                raise Terminator_Error;
 211             elsif Item (From) = wide_nul then
 212                exit;
 213             else
 214                From := From + 1;
 215             end if;
 216          end loop;
 217
 218          Count := Natural (From - Item'First);
 219
 220       else
 221          Count := Item'Length;
 222       end if;
 223
 224       declare
 225          R : Wide_String (1 .. Count);
 226
 227       begin
 228          for J in R'Range loop
 229             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 230          end loop;
 231
 232          return R;
 233       end;
 234    end To_Ada;
 235
 236    --  Convert wchar_array to Wide_String (procedure form)
 237
 238    procedure To_Ada
 239      (Item     : wchar_array;
 240       Target   : out Wide_String;
 241       Count    : out Natural;
 242       Trim_Nul : Boolean := True)
 243    is
 244       From : size_t;
 245       To   : Positive;
 246
 247    begin
 248       if Trim_Nul then
 249          From := Item'First;
 250          loop
 251             if From > Item'Last then
 252                raise Terminator_Error;
 253             elsif Item (From) = wide_nul then
 254                exit;
 255             else
 256                From := From + 1;
 257             end if;
 258          end loop;
 259
 260          Count := Natural (From - Item'First);
 261
 262       else
 263          Count := Item'Length;
 264       end if;
 265
 266       if Count > Target'Length then
 267          raise Constraint_Error;
 268
 269       else
 270          From := Item'First;
 271          To   := Target'First;
 272
 273          for J in 1 .. Count loop
 274             Target (To) := To_Ada (Item (From));
 275             From := From + 1;
 276             To   := To + 1;
 277          end loop;
 278       end if;
 279    end To_Ada;
 280
 281    --  Convert char16_t to Wide_Character
 282
 283    function To_Ada (Item : char16_t) return Wide_Character is
 284    begin
 285       return Wide_Character'Val (char16_t'Pos (Item));
 286    end To_Ada;
 287
 288    --  Convert char16_array to Wide_String (function form)
 289
 290    function To_Ada
 291      (Item     : char16_array;
 292       Trim_Nul : Boolean := True) return Wide_String
 293    is
 294       Count : Natural;
 295       From  : size_t;
 296
 297    begin
 298       if Trim_Nul then
 299          From := Item'First;
 300
 301          loop
 302             if From > Item'Last then
 303                raise Terminator_Error;
 304             elsif Item (From) = char16_t'Val (0) then
 305                exit;
 306             else
 307                From := From + 1;
 308             end if;
 309          end loop;
 310
 311          Count := Natural (From - Item'First);
 312
 313       else
 314          Count := Item'Length;
 315       end if;
 316
 317       declare
 318          R : Wide_String (1 .. Count);
 319
 320       begin
 321          for J in R'Range loop
 322             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 323          end loop;
 324
 325          return R;
 326       end;
 327    end To_Ada;
 328
 329    --  Convert char16_array to Wide_String (procedure form)
 330
 331    procedure To_Ada
 332      (Item     : char16_array;
 333       Target   : out Wide_String;
 334       Count    : out Natural;
 335       Trim_Nul : Boolean := True)
 336    is
 337       From : size_t;
 338       To   : Positive;
 339
 340    begin
 341       if Trim_Nul then
 342          From := Item'First;
 343          loop
 344             if From > Item'Last then
 345                raise Terminator_Error;
 346             elsif Item (From) = char16_t'Val (0) then
 347                exit;
 348             else
 349                From := From + 1;
 350             end if;
 351          end loop;
 352
 353          Count := Natural (From - Item'First);
 354
 355       else
 356          Count := Item'Length;
 357       end if;
 358
 359       if Count > Target'Length then
 360          raise Constraint_Error;
 361
 362       else
 363          From := Item'First;
 364          To   := Target'First;
 365
 366          for J in 1 .. Count loop
 367             Target (To) := To_Ada (Item (From));
 368             From := From + 1;
 369             To   := To + 1;
 370          end loop;
 371       end if;
 372    end To_Ada;
 373
 374    --  Convert char32_t to Wide_Wide_Character
 375
 376    function To_Ada (Item : char32_t) return Wide_Wide_Character is
 377    begin
 378       return Wide_Wide_Character'Val (char32_t'Pos (Item));
 379    end To_Ada;
 380
 381    --  Convert char32_array to Wide_Wide_String (function form)
 382
 383    function To_Ada
 384      (Item     : char32_array;
 385       Trim_Nul : Boolean := True) return Wide_Wide_String
 386    is
 387       Count : Natural;
 388       From  : size_t;
 389
 390    begin
 391       if Trim_Nul then
 392          From := Item'First;
 393
 394          loop
 395             if From > Item'Last then
 396                raise Terminator_Error;
 397             elsif Item (From) = char32_t'Val (0) then
 398                exit;
 399             else
 400                From := From + 1;
 401             end if;
 402          end loop;
 403
 404          Count := Natural (From - Item'First);
 405
 406       else
 407          Count := Item'Length;
 408       end if;
 409
 410       declare
 411          R : Wide_Wide_String (1 .. Count);
 412
 413       begin
 414          for J in R'Range loop
 415             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 416          end loop;
 417
 418          return R;
 419       end;
 420    end To_Ada;
 421
 422    --  Convert char32_array to Wide_Wide_String (procedure form)
 423
 424    procedure To_Ada
 425      (Item     : char32_array;
 426       Target   : out Wide_Wide_String;
 427       Count    : out Natural;
 428       Trim_Nul : Boolean := True)
 429    is
 430       From : size_t;
 431       To   : Positive;
 432
 433    begin
 434       if Trim_Nul then
 435          From := Item'First;
 436          loop
 437             if From > Item'Last then
 438                raise Terminator_Error;
 439             elsif Item (From) = char32_t'Val (0) then
 440                exit;
 441             else
 442                From := From + 1;
 443             end if;
 444          end loop;
 445
 446          Count := Natural (From - Item'First);
 447
 448       else
 449          Count := Item'Length;
 450       end if;
 451
 452       if Count > Target'Length then
 453          raise Constraint_Error;
 454
 455       else
 456          From := Item'First;
 457          To   := Target'First;
 458
 459          for J in 1 .. Count loop
 460             Target (To) := To_Ada (Item (From));
 461             From := From + 1;
 462             To   := To + 1;
 463          end loop;
 464       end if;
 465    end To_Ada;
 466
 467    ----------
 468    -- To_C --
 469    ----------
 470
 471    --  Convert Character to char
 472
 473    function To_C (Item : Character) return char is
 474    begin
 475       return char'Val (Character'Pos (Item));
 476    end To_C;
 477
 478    --  Convert String to char_array (function form)
 479
 480    function To_C
 481      (Item       : String;
 482       Append_Nul : Boolean := True) return char_array
 483    is
 484    begin
 485       if Append_Nul then
 486          declare
 487             R : char_array (0 .. Item'Length);
 488
 489          begin
 490             for J in Item'Range loop
 491                R (size_t (J - Item'First)) := To_C (Item (J));
 492             end loop;
 493
 494             R (R'Last) := nul;
 495             return R;
 496          end;
 497
 498       --  Append_Nul False
 499
 500       else
 501          --  A nasty case, if the string is null, we must return a null
 502          --  char_array. The lower bound of this array is required to be zero
 503          --  (RM B.3(50)) but that is of course impossible given that size_t
 504          --  is unsigned. According to Ada 2005 AI-258, the result is to raise
 505          --  Constraint_Error. This is also the appropriate behavior in Ada 95,
 506          --  since nothing else makes sense.
 507
 508          if Item'Length = 0 then
 509             raise Constraint_Error;
 510
 511          --  Normal case
 512
 513          else
 514             declare
 515                R : char_array (0 .. Item'Length - 1);
 516
 517             begin
 518                for J in Item'Range loop
 519                   R (size_t (J - Item'First)) := To_C (Item (J));
 520                end loop;
 521
 522                return R;
 523             end;
 524          end if;
 525       end if;
 526    end To_C;
 527
 528    --  Convert String to char_array (procedure form)
 529
 530    procedure To_C
 531      (Item       : String;
 532       Target     : out char_array;
 533       Count      : out size_t;
 534       Append_Nul : Boolean := True)
 535    is
 536       To : size_t;
 537
 538    begin
 539       if Target'Length < Item'Length then
 540          raise Constraint_Error;
 541
 542       else
 543          To := Target'First;
 544          for From in Item'Range loop
 545             Target (To) := char (Item (From));
 546             To := To + 1;
 547          end loop;
 548
 549          if Append_Nul then
 550             if To > Target'Last then
 551                raise Constraint_Error;
 552             else
 553                Target (To) := nul;
 554                Count := Item'Length + 1;
 555             end if;
 556
 557          else
 558             Count := Item'Length;
 559          end if;
 560       end if;
 561    end To_C;
 562
 563    --  Convert Wide_Character to wchar_t
 564
 565    function To_C (Item : Wide_Character) return wchar_t is
 566    begin
 567       return wchar_t (Item);
 568    end To_C;
 569
 570    --  Convert Wide_String to wchar_array (function form)
 571
 572    function To_C
 573      (Item       : Wide_String;
 574       Append_Nul : Boolean := True) return wchar_array
 575    is
 576    begin
 577       if Append_Nul then
 578          declare
 579             R : wchar_array (0 .. Item'Length);
 580
 581          begin
 582             for J in Item'Range loop
 583                R (size_t (J - Item'First)) := To_C (Item (J));
 584             end loop;
 585
 586             R (R'Last) := wide_nul;
 587             return R;
 588          end;
 589
 590       else
 591          --  A nasty case, if the string is null, we must return a null
 592          --  wchar_array. The lower bound of this array is required to be zero
 593          --  (RM B.3(50)) but that is of course impossible given that size_t
 594          --  is unsigned. According to Ada 2005 AI-258, the result is to raise
 595          --  Constraint_Error. This is also the appropriate behavior in Ada 95,
 596          --  since nothing else makes sense.
 597
 598          if Item'Length = 0 then
 599             raise Constraint_Error;
 600
 601          else
 602             declare
 603                R : wchar_array (0 .. Item'Length - 1);
 604
 605             begin
 606                for J in size_t range 0 .. Item'Length - 1 loop
 607                   R (J) := To_C (Item (Integer (J) + Item'First));
 608                end loop;
 609
 610                return R;
 611             end;
 612          end if;
 613       end if;
 614    end To_C;
 615
 616    --  Convert Wide_String to wchar_array (procedure form)
 617
 618    procedure To_C
 619      (Item       : Wide_String;
 620       Target     : out wchar_array;
 621       Count      : out size_t;
 622       Append_Nul : Boolean := True)
 623    is
 624       To : size_t;
 625
 626    begin
 627       if Target'Length < Item'Length then
 628          raise Constraint_Error;
 629
 630       else
 631          To := Target'First;
 632          for From in Item'Range loop
 633             Target (To) := To_C (Item (From));
 634             To := To + 1;
 635          end loop;
 636
 637          if Append_Nul then
 638             if To > Target'Last then
 639                raise Constraint_Error;
 640             else
 641                Target (To) := wide_nul;
 642                Count := Item'Length + 1;
 643             end if;
 644
 645          else
 646             Count := Item'Length;
 647          end if;
 648       end if;
 649    end To_C;
 650
 651    --  Convert Wide_Character to char16_t
 652
 653    function To_C (Item : Wide_Character) return char16_t is
 654    begin
 655       return char16_t'Val (Wide_Character'Pos (Item));
 656    end To_C;
 657
 658    --  Convert Wide_String to char16_array (function form)
 659
 660    function To_C
 661      (Item       : Wide_String;
 662       Append_Nul : Boolean := True) return char16_array
 663    is
 664    begin
 665       if Append_Nul then
 666          declare
 667             R : char16_array (0 .. Item'Length);
 668
 669          begin
 670             for J in Item'Range loop
 671                R (size_t (J - Item'First)) := To_C (Item (J));
 672             end loop;
 673
 674             R (R'Last) := char16_t'Val (0);
 675             return R;
 676          end;
 677
 678       else
 679          --  A nasty case, if the string is null, we must return a null
 680          --  char16_array. The lower bound of this array is required to be zero
 681          --  (RM B.3(50)) but that is of course impossible given that size_t
 682          --  is unsigned. According to Ada 2005 AI-258, the result is to raise
 683          --  Constraint_Error. This is also the appropriate behavior in Ada 95,
 684          --  since nothing else makes sense.
 685
 686          if Item'Length = 0 then
 687             raise Constraint_Error;
 688
 689          else
 690             declare
 691                R : char16_array (0 .. Item'Length - 1);
 692
 693             begin
 694                for J in size_t range 0 .. Item'Length - 1 loop
 695                   R (J) := To_C (Item (Integer (J) + Item'First));
 696                end loop;
 697
 698                return R;
 699             end;
 700          end if;
 701       end if;
 702    end To_C;
 703
 704    --  Convert Wide_String to char16_array (procedure form)
 705
 706    procedure To_C
 707      (Item       : Wide_String;
 708       Target     : out char16_array;
 709       Count      : out size_t;
 710       Append_Nul : Boolean := True)
 711    is
 712       To : size_t;
 713
 714    begin
 715       if Target'Length < Item'Length then
 716          raise Constraint_Error;
 717
 718       else
 719          To := Target'First;
 720          for From in Item'Range loop
 721             Target (To) := To_C (Item (From));
 722             To := To + 1;
 723          end loop;
 724
 725          if Append_Nul then
 726             if To > Target'Last then
 727                raise Constraint_Error;
 728             else
 729                Target (To) := char16_t'Val (0);
 730                Count := Item'Length + 1;
 731             end if;
 732
 733          else
 734             Count := Item'Length;
 735          end if;
 736       end if;
 737    end To_C;
 738
 739    --  Convert Wide_Character to char32_t
 740
 741    function To_C (Item : Wide_Wide_Character) return char32_t is
 742    begin
 743       return char32_t'Val (Wide_Wide_Character'Pos (Item));
 744    end To_C;
 745
 746    --  Convert Wide_Wide_String to char32_array (function form)
 747
 748    function To_C
 749      (Item       : Wide_Wide_String;
 750       Append_Nul : Boolean := True) return char32_array
 751    is
 752    begin
 753       if Append_Nul then
 754          declare
 755             R : char32_array (0 .. Item'Length);
 756
 757          begin
 758             for J in Item'Range loop
 759                R (size_t (J - Item'First)) := To_C (Item (J));
 760             end loop;
 761
 762             R (R'Last) := char32_t'Val (0);
 763             return R;
 764          end;
 765
 766       else
 767          --  A nasty case, if the string is null, we must return a null
 768          --  char32_array. The lower bound of this array is required to be zero
 769          --  (RM B.3(50)) but that is of course impossible given that size_t
 770          --  is unsigned. According to Ada 2005 AI-258, the result is to raise
 771          --  Constraint_Error.
 772
 773          if Item'Length = 0 then
 774             raise Constraint_Error;
 775
 776          else
 777             declare
 778                R : char32_array (0 .. Item'Length - 1);
 779
 780             begin
 781                for J in size_t range 0 .. Item'Length - 1 loop
 782                   R (J) := To_C (Item (Integer (J) + Item'First));
 783                end loop;
 784
 785                return R;
 786             end;
 787          end if;
 788       end if;
 789    end To_C;
 790
 791    --  Convert Wide_Wide_String to char32_array (procedure form)
 792
 793    procedure To_C
 794      (Item       : Wide_Wide_String;
 795       Target     : out char32_array;
 796       Count      : out size_t;
 797       Append_Nul : Boolean := True)
 798    is
 799       To : size_t;
 800
 801    begin
 802       if Target'Length < Item'Length then
 803          raise Constraint_Error;
 804
 805       else
 806          To := Target'First;
 807          for From in Item'Range loop
 808             Target (To) := To_C (Item (From));
 809             To := To + 1;
 810          end loop;
 811
 812          if Append_Nul then
 813             if To > Target'Last then
 814                raise Constraint_Error;
 815             else
 816                Target (To) := char32_t'Val (0);
 817                Count := Item'Length + 1;
 818             end if;
 819
 820          else
 821             Count := Item'Length;
 822          end if;
 823       end if;
 824    end To_C;
 825
 826 end Interfaces.C;