gcc/ada/osint-c.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              O S I N T - C                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2023, 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.  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Opt; use Opt;
  27
  28 package body Osint.C is
  29
  30    Output_Object_File_Name : String_Ptr;
  31    --  Argument of -o compiler option, if given. This is needed to verify
  32    --  consistency with the ALI file name.
  33
  34    procedure Adjust_OS_Resource_Limits;
  35    pragma Import (C, Adjust_OS_Resource_Limits,
  36                   "__gnat_adjust_os_resource_limits");
  37    --  Procedure to make system specific adjustments to make GNAT run better
  38
  39    function Create_Auxiliary_File
  40      (Src    : File_Name_Type;
  41       Suffix : String) return File_Name_Type;
  42    --  Common processing for Create_List_File, Create_Repinfo_File and
  43    --  Create_Debug_File. Src is the file name used to create the required
  44    --  output file and Suffix is the desired suffix (dg/rep/xxx for debug/
  45    --  repinfo/list file where xxx is specified extension.
  46
  47    ------------------
  48    -- Close_C_File --
  49    ------------------
  50
  51    procedure Close_C_File is
  52       Status : Boolean;
  53
  54    begin
  55       Close (Output_FD, Status);
  56
  57       if not Status then
  58          Fail
  59            ("error while closing file "
  60             & Get_Name_String (Output_File_Name));
  61       end if;
  62    end Close_C_File;
  63
  64    ----------------------
  65    -- Close_Debug_File --
  66    ----------------------
  67
  68    procedure Close_Debug_File is
  69       Status : Boolean;
  70
  71    begin
  72       Close (Output_FD, Status);
  73
  74       if not Status then
  75          Fail
  76            ("error while closing expanded source file "
  77             & Get_Name_String (Output_File_Name));
  78       end if;
  79    end Close_Debug_File;
  80
  81    ------------------
  82    -- Close_H_File --
  83    ------------------
  84
  85    procedure Close_H_File is
  86       Status : Boolean;
  87
  88    begin
  89       Close (Output_FD, Status);
  90
  91       if not Status then
  92          Fail
  93            ("error while closing file "
  94             & Get_Name_String (Output_File_Name));
  95       end if;
  96    end Close_H_File;
  97
  98    ---------------------
  99    -- Close_List_File --
 100    ---------------------
 101
 102    procedure Close_List_File is
 103       Status : Boolean;
 104
 105    begin
 106       Close (Output_FD, Status);
 107
 108       if not Status then
 109          Fail
 110            ("error while closing list file "
 111             & Get_Name_String (Output_File_Name));
 112       end if;
 113    end Close_List_File;
 114
 115    -------------------------------
 116    -- Close_Output_Library_Info --
 117    -------------------------------
 118
 119    procedure Close_Output_Library_Info is
 120       Status : Boolean;
 121
 122    begin
 123       Close (Output_FD, Status);
 124
 125       if not Status then
 126          Fail
 127            ("error while closing ALI file "
 128             & Get_Name_String (Output_File_Name));
 129       end if;
 130    end Close_Output_Library_Info;
 131
 132    ------------------------
 133    -- Close_Repinfo_File --
 134    ------------------------
 135
 136    procedure Close_Repinfo_File is
 137       Status : Boolean;
 138
 139    begin
 140       Close (Output_FD, Status);
 141
 142       if not Status then
 143          Fail
 144            ("error while closing representation info file "
 145             & Get_Name_String (Output_File_Name));
 146       end if;
 147    end Close_Repinfo_File;
 148
 149    ---------------------------
 150    -- Create_Auxiliary_File --
 151    ---------------------------
 152
 153    function Create_Auxiliary_File
 154      (Src    : File_Name_Type;
 155       Suffix : String) return File_Name_Type
 156    is
 157       Result : File_Name_Type;
 158
 159    begin
 160       Get_Name_String (Src);
 161
 162       Name_Buffer (Name_Len + 1) := '.';
 163       Name_Len := Name_Len + 1;
 164       Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 165       Name_Len := Name_Len + Suffix'Length;
 166
 167       if Output_Object_File_Name /= null then
 168          for Index in reverse Output_Object_File_Name'Range loop
 169             if Output_Object_File_Name (Index) = Directory_Separator then
 170                declare
 171                   File_Name : constant String := Name_Buffer (1 .. Name_Len);
 172                begin
 173                   Name_Len := Index - Output_Object_File_Name'First + 1;
 174                   Name_Buffer (1 .. Name_Len) :=
 175                     Output_Object_File_Name
 176                       (Output_Object_File_Name'First .. Index);
 177                   Name_Buffer (Name_Len + 1 .. Name_Len + File_Name'Length) :=
 178                     File_Name;
 179                   Name_Len := Name_Len + File_Name'Length;
 180                end;
 181
 182                exit;
 183             end if;
 184          end loop;
 185       end if;
 186
 187       Result := Name_Find;
 188       Name_Buffer (Name_Len + 1) := ASCII.NUL;
 189       Create_File_And_Check (Output_FD, Text);
 190       return Result;
 191    end Create_Auxiliary_File;
 192
 193    -------------------
 194    -- Create_C_File --
 195    -------------------
 196
 197    procedure Create_C_File is
 198       Dummy : Boolean;
 199    begin
 200       Set_File_Name ("c");
 201       Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
 202       Create_File_And_Check (Output_FD, Text);
 203    end Create_C_File;
 204
 205    -----------------------
 206    -- Create_Debug_File --
 207    -----------------------
 208
 209    function Create_Debug_File (Src : File_Name_Type) return File_Name_Type is
 210    begin
 211       return Create_Auxiliary_File (Src, "dg");
 212    end Create_Debug_File;
 213
 214    -------------------
 215    -- Create_H_File --
 216    -------------------
 217
 218    procedure Create_H_File is
 219       Dummy : Boolean;
 220    begin
 221       Set_File_Name ("h");
 222       Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
 223       Create_File_And_Check (Output_FD, Text);
 224    end Create_H_File;
 225
 226    ----------------------
 227    -- Create_List_File --
 228    ----------------------
 229
 230    procedure Create_List_File (S : String) is
 231       Dummy : File_Name_Type;
 232    begin
 233       if S (S'First) = '.' then
 234          Dummy :=
 235            Create_Auxiliary_File (Current_Main, S (S'First + 1 .. S'Last));
 236       else
 237          Name_Buffer (1 .. S'Length) := S;
 238          Name_Len := S'Length + 1;
 239          Name_Buffer (Name_Len) := ASCII.NUL;
 240          Create_File_And_Check (Output_FD, Text);
 241       end if;
 242    end Create_List_File;
 243
 244    --------------------------------
 245    -- Create_Output_Library_Info --
 246    --------------------------------
 247
 248    procedure Create_Output_Library_Info is
 249       Dummy : Boolean;
 250    begin
 251       Set_File_Name (ALI_Suffix.all);
 252       Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
 253       Create_File_And_Check (Output_FD, Text);
 254    end Create_Output_Library_Info;
 255
 256    ------------------------------
 257    -- Open_Output_Library_Info --
 258    ------------------------------
 259
 260    procedure Open_Output_Library_Info is
 261    begin
 262       Set_File_Name (ALI_Suffix.all);
 263       Open_File_To_Append_And_Check (Output_FD, Text);
 264    end Open_Output_Library_Info;
 265
 266    -------------------------
 267    -- Create_Repinfo_File --
 268    -------------------------
 269
 270    procedure Create_Repinfo_File (Src : String) is
 271       Discard : File_Name_Type;
 272    begin
 273       Name_Buffer (1 .. Src'Length) := Src;
 274       Name_Len := Src'Length;
 275       if List_Representation_Info_To_JSON then
 276          Discard := Create_Auxiliary_File (Name_Find, "json");
 277       else
 278          Discard := Create_Auxiliary_File (Name_Find, "rep");
 279       end if;
 280    end Create_Repinfo_File;
 281
 282    ---------------------------
 283    -- Debug_File_Eol_Length --
 284    ---------------------------
 285
 286    function Debug_File_Eol_Length return Nat is
 287    begin
 288       --  There has to be a cleaner way to do this ???
 289
 290       if Directory_Separator = '/' then
 291          return 1;
 292       else
 293          return 2;
 294       end if;
 295    end Debug_File_Eol_Length;
 296
 297    -------------------
 298    -- Delete_C_File --
 299    -------------------
 300
 301    procedure Delete_C_File is
 302       Dummy : Boolean;
 303    begin
 304       Set_File_Name ("c");
 305       Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
 306    end Delete_C_File;
 307
 308    -------------------
 309    -- Delete_H_File --
 310    -------------------
 311
 312    procedure Delete_H_File is
 313       Dummy : Boolean;
 314    begin
 315       Set_File_Name ("h");
 316       Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
 317    end Delete_H_File;
 318
 319    ---------------------------------
 320    -- Get_Output_Object_File_Name --
 321    ---------------------------------
 322
 323    function Get_Output_Object_File_Name return String is
 324    begin
 325       pragma Assert (Output_Object_File_Name /= null);
 326
 327       return Output_Object_File_Name.all;
 328    end Get_Output_Object_File_Name;
 329
 330    -----------------------
 331    -- More_Source_Files --
 332    -----------------------
 333
 334    function More_Source_Files return Boolean renames More_Files;
 335
 336    ----------------------
 337    -- Next_Main_Source --
 338    ----------------------
 339
 340    function Next_Main_Source return File_Name_Type renames Next_Main_File;
 341
 342    -----------------------
 343    -- Read_Library_Info --
 344    -----------------------
 345
 346    procedure Read_Library_Info
 347      (Name : out File_Name_Type;
 348       Text : out Text_Buffer_Ptr)
 349    is
 350    begin
 351       Set_File_Name (ALI_Suffix.all);
 352
 353       --  Remove trailing NUL that comes from Set_File_Name above. This is
 354       --  needed for consistency with names that come from Scan_ALI and thus
 355       --  preventing repeated scanning of the same file.
 356
 357       pragma Assert (Name_Len > 1 and then Name_Buffer (Name_Len) = ASCII.NUL);
 358       Name_Len := Name_Len - 1;
 359
 360       Name := Name_Find;
 361       Text := Read_Library_Info (Name, Fatal_Err => False);
 362    end Read_Library_Info;
 363
 364    -------------------
 365    -- Set_File_Name --
 366    -------------------
 367
 368    procedure Set_File_Name (Ext : String) is
 369       Dot_Index : Natural;
 370
 371    begin
 372       Get_Name_String (Current_Main);
 373
 374       --  Find last dot since we replace the existing extension by .ali. The
 375       --  initialization to Name_Len + 1 provides for simply adding the .ali
 376       --  extension if the source file name has no extension.
 377
 378       Dot_Index := Name_Len + 1;
 379
 380       for J in reverse 1 .. Name_Len loop
 381          if Name_Buffer (J) = '.' then
 382             Dot_Index := J;
 383             exit;
 384          end if;
 385       end loop;
 386
 387       --  If we are in multiple-units-per-file mode, then add a ~nnn extension
 388       --  to the name.
 389
 390       if Multiple_Unit_Index /= 0 then
 391          declare
 392             Exten : constant String := Name_Buffer (Dot_Index .. Name_Len);
 393          begin
 394             Name_Len := Dot_Index - 1;
 395             Add_Char_To_Name_Buffer (Multi_Unit_Index_Character);
 396             Add_Nat_To_Name_Buffer (Multiple_Unit_Index);
 397             Dot_Index := Name_Len + 1;
 398             Add_Str_To_Name_Buffer (Exten);
 399          end;
 400       end if;
 401
 402       --  Make sure that the output file name matches the source file name.
 403       --  To compare them, remove file name directories and extensions.
 404
 405       if Output_Object_File_Name /= null then
 406
 407          --  Make sure there is a dot at Dot_Index. This may not be the case
 408          --  if the source file name has no extension.
 409
 410          Name_Buffer (Dot_Index) := '.';
 411
 412          --  Remove extension preparing to replace it
 413
 414          declare
 415             Name   : String  := Name_Buffer (1 .. Dot_Index);
 416             Output : String  := Output_Object_File_Name.all;
 417             First  : Positive;
 418
 419          begin
 420             Name_Buffer (1 .. Output_Object_File_Name'Length) := Output;
 421
 422             --  Put two names in canonical case, to allow object file names
 423             --  with upper-case letters on Windows.
 424             --  Do it with a copy (Output) and keep Name_Buffer as is since we
 425             --  want to preserve the original casing.
 426
 427             Canonical_Case_File_Name (Name);
 428             Canonical_Case_File_Name (Output);
 429
 430             Dot_Index := 0;
 431             for J in reverse Output'Range loop
 432                if Name_Buffer (J) = '.' then
 433                   Dot_Index := J;
 434                   exit;
 435                end if;
 436             end loop;
 437
 438             --  Dot_Index should not be zero now (we check for extension
 439             --  elsewhere).
 440
 441             pragma Assert (Dot_Index /= 0);
 442
 443             --  Look for first character of file name
 444
 445             First := Dot_Index;
 446             while First > 1
 447               and then Name_Buffer (First - 1) /= Directory_Separator
 448               and then Name_Buffer (First - 1) /= '/'
 449             loop
 450                First := First - 1;
 451             end loop;
 452
 453             --  Check name of object file is what we expect
 454
 455             if Name /= Output (First .. Dot_Index) then
 456                Fail ("incorrect object file name");
 457             end if;
 458          end;
 459       end if;
 460
 461       Name_Buffer (Dot_Index) := '.';
 462       Name_Buffer (Dot_Index + 1 .. Dot_Index + Ext'Length) := Ext;
 463       Name_Buffer (Dot_Index + Ext'Length + 1) := ASCII.NUL;
 464       Name_Len := Dot_Index + Ext'Length + 1;
 465    end Set_File_Name;
 466
 467    ---------------------------------
 468    -- Set_Output_Object_File_Name --
 469    ---------------------------------
 470
 471    procedure Set_Output_Object_File_Name (Name : String) is
 472       Ext : constant String  := Target_Object_Suffix;
 473       NL  : constant Natural := Name'Length;
 474       EL  : constant Natural := Ext'Length;
 475
 476    begin
 477       --  Make sure that the object file has the expected extension
 478       --  Allow for either .o or .c (for C code generation)
 479
 480       if NL <= EL
 481          or else
 482           (not Generate_Asm
 483              and then Name (NL - EL + Name'First .. Name'Last) /= Ext
 484              and then Name (NL - 2 + Name'First .. Name'Last) /= ".o"
 485              and then Name (NL - 2 + Name'First .. Name'Last) /= ".c")
 486       then
 487          Fail ("incorrect object file extension");
 488       end if;
 489
 490       Output_Object_File_Name := new String'(Name);
 491    end Set_Output_Object_File_Name;
 492
 493    -----------------------
 494    -- Write_Debug_Info --
 495    -----------------------
 496
 497    procedure Write_Debug_Info (Info : String) renames Write_Info;
 498
 499    ------------------------
 500    -- Write_Library_Info --
 501    ------------------------
 502
 503    procedure Write_Library_Info (Info : String) renames Write_Info;
 504
 505    ---------------------
 506    -- Write_List_Info --
 507    ---------------------
 508
 509    procedure Write_List_Info (S : String) is
 510    begin
 511       Write_With_Check (S'Address, S'Length);
 512    end Write_List_Info;
 513
 514    ------------------------
 515    -- Write_Repinfo_Line --
 516    ------------------------
 517
 518    procedure Write_Repinfo_Line (Info : String) renames Write_Info;
 519
 520 begin
 521    Adjust_OS_Resource_Limits;
 522
 523    Opt.Create_List_File_Access := Create_List_File'Access;
 524    Opt.Write_List_Info_Access  := Write_List_Info'Access;
 525    Opt.Close_List_File_Access  := Close_List_File'Access;
 526
 527    Set_Program (Compiler);
 528 end Osint.C;