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