gcc/ada/mlib.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                 M L I B                                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --           Copyright (C) 1999-2004, Ada Core Technologies, 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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Ada.Characters.Handling; use Ada.Characters.Handling;
  28 with Interfaces.C.Strings;
  29
  30 with Hostparm;
  31 with Opt;
  32 with Output; use Output;
  33 with Namet;  use Namet;
  34
  35 with MLib.Utl; use MLib.Utl;
  36
  37 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  38 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  39
  40 with System;
  41
  42 package body MLib is
  43
  44    -------------------
  45    -- Build_Library --
  46    -------------------
  47
  48    procedure Build_Library
  49      (Ofiles      : Argument_List;
  50       Afiles      : Argument_List;
  51       Output_File : String;
  52       Output_Dir  : String)
  53    is
  54       pragma Warnings (Off, Afiles);
  55
  56       use GNAT.OS_Lib;
  57
  58    begin
  59       if not Opt.Quiet_Output then
  60          Write_Line ("building a library...");
  61          Write_Str  ("   make ");
  62          Write_Line (Output_File);
  63       end if;
  64
  65       Ar (Output_Dir & "/lib" & Output_File & ".a", Objects => Ofiles);
  66    end Build_Library;
  67
  68    ------------------------
  69    -- Check_Library_Name --
  70    ------------------------
  71
  72    procedure Check_Library_Name (Name : String) is
  73    begin
  74       if Name'Length = 0 then
  75          Fail ("library name cannot be empty");
  76       end if;
  77
  78       if Name'Length > Max_Characters_In_Library_Name then
  79          Fail ("illegal library name """, Name, """: too long");
  80       end if;
  81
  82       if not Is_Letter (Name (Name'First)) then
  83          Fail ("illegal library name """,
  84                Name,
  85                """: should start with a letter");
  86       end if;
  87
  88       for Index in Name'Range loop
  89          if not Is_Alphanumeric (Name (Index)) then
  90             Fail ("illegal library name """,
  91                   Name,
  92                   """: should include only letters and digits");
  93          end if;
  94       end loop;
  95    end Check_Library_Name;
  96
  97    --------------------
  98    -- Copy_ALI_Files --
  99    --------------------
 100
 101    procedure Copy_ALI_Files
 102      (Files      : Argument_List;
 103       To         : Name_Id;
 104       Interfaces : String_List)
 105    is
 106       Success   : Boolean := False;
 107       To_Dir    : constant String := Get_Name_String (To);
 108       Interface : Boolean := False;
 109
 110       procedure Set_Readonly (Name : System.Address);
 111       pragma Import (C, Set_Readonly, "__gnat_set_readonly");
 112
 113       procedure Verbose_Copy (Index : Positive);
 114       --  In verbose mode, output a message that the indexed file is copied
 115       --  to the destination directory.
 116
 117       ------------------
 118       -- Verbose_Copy --
 119       ------------------
 120
 121       procedure Verbose_Copy (Index : Positive) is
 122       begin
 123          if Opt.Verbose_Mode then
 124             Write_Str ("Copying """);
 125             Write_Str (Files (Index).all);
 126             Write_Str (""" to """);
 127             Write_Str (To_Dir);
 128             Write_Line ("""");
 129          end if;
 130       end Verbose_Copy;
 131
 132    begin
 133       if Interfaces'Length = 0 then
 134
 135          --  If there are no Interfaces, copy all the ALI files as is
 136
 137          for Index in Files'Range loop
 138             Verbose_Copy (Index);
 139             Copy_File
 140               (Files (Index).all,
 141                To_Dir,
 142                Success,
 143                Mode => Overwrite,
 144                Preserve => Preserve);
 145
 146             exit when not Success;
 147          end loop;
 148
 149       else
 150          --  Copy only the interface ALI file, and put the special indicator
 151          --  "SL" on the P line.
 152
 153          for Index in Files'Range loop
 154
 155             declare
 156                File_Name : String := Base_Name (Files (Index).all);
 157             begin
 158                Canonical_Case_File_Name (File_Name);
 159
 160                --  Check if this is one of the interface ALIs
 161
 162                Interface := False;
 163
 164                for Index in Interfaces'Range loop
 165                   if File_Name = Interfaces (Index).all then
 166                      Interface := True;
 167                      exit;
 168                   end if;
 169                end loop;
 170
 171                --  If it is an interface ALI, copy line by line. Insert
 172                --  the interface indication at the end of the P line.
 173                --  Do not copy ALI files that are not Interfaces.
 174
 175                if Interface then
 176                   Success := False;
 177                   Verbose_Copy (Index);
 178
 179                   declare
 180                      FD         : File_Descriptor;
 181                      Len        : Integer;
 182                      Actual_Len : Integer;
 183                      S          : String_Access;
 184                      Curr       : Natural;
 185                      P_Line_Found : Boolean;
 186                      Status     : Boolean;
 187
 188                   begin
 189                      --  Open the file
 190
 191                      Name_Len := Files (Index)'Length;
 192                      Name_Buffer (1 .. Name_Len) := Files (Index).all;
 193                      Name_Len := Name_Len + 1;
 194                      Name_Buffer (Name_Len) := ASCII.NUL;
 195
 196                      FD := Open_Read (Name_Buffer'Address, Binary);
 197
 198                      if FD /= Invalid_FD then
 199                         Len := Integer (File_Length (FD));
 200
 201                         S := new String (1 .. Len + 3);
 202
 203                         --  Read the file. Note that the loop is not necessary
 204                         --  since the whole file is read at once except on VMS.
 205
 206                         Curr := 1;
 207                         Actual_Len := Len;
 208
 209                         while Actual_Len /= 0 loop
 210                            Actual_Len := Read (FD, S (Curr)'Address, Len);
 211                            Curr := Curr + Actual_Len;
 212                         end loop;
 213
 214                         --  We are done with the input file, so we close it
 215
 216                         Close (FD, Status);
 217                         --  We simply ignore any bad status
 218
 219                         P_Line_Found := False;
 220
 221                         --  Look for the P line. When found, add marker SL
 222                         --  at the beginning of the P line.
 223
 224                         for Index in 1 .. Len - 3 loop
 225                            if (S (Index) = ASCII.LF or else
 226                                  S (Index) = ASCII.CR)
 227                              and then
 228                                S (Index + 1) = 'P'
 229                            then
 230                               S (Index + 5 .. Len + 3) := S (Index + 2 .. Len);
 231                               S (Index + 2 .. Index + 4) := " SL";
 232                               P_Line_Found := True;
 233                               exit;
 234                            end if;
 235                         end loop;
 236
 237                         if P_Line_Found then
 238
 239                            --  Create new modified ALI file
 240
 241                            Name_Len := To_Dir'Length;
 242                            Name_Buffer (1 .. Name_Len) := To_Dir;
 243                            Name_Len := Name_Len + 1;
 244                            Name_Buffer (Name_Len) := Directory_Separator;
 245                            Name_Buffer
 246                              (Name_Len + 1 .. Name_Len + File_Name'Length) :=
 247                                 File_Name;
 248                            Name_Len := Name_Len + File_Name'Length + 1;
 249                            Name_Buffer (Name_Len) := ASCII.NUL;
 250
 251                            FD := Create_File (Name_Buffer'Address, Binary);
 252
 253                            --  Write the modified text and close the newly
 254                            --  created file.
 255
 256                            if FD /= Invalid_FD then
 257                               Actual_Len := Write (FD, S (1)'Address, Len + 3);
 258
 259                               Close (FD, Status);
 260
 261                               --  Set Success to True only if the newly
 262                               --  created file has been correctly written.
 263
 264                               Success := Status and Actual_Len = Len + 3;
 265
 266                               if Success then
 267                                  Set_Readonly (Name_Buffer'Address);
 268                               end if;
 269                            end if;
 270                         end if;
 271                      end if;
 272                   end;
 273
 274                else
 275                   --  This is not an interface ALI
 276
 277                   Success := True;
 278
 279                end if;
 280             end;
 281
 282             if not Success then
 283                Fail ("could not copy ALI files to library dir");
 284             end if;
 285          end loop;
 286       end if;
 287    end Copy_ALI_Files;
 288
 289    --------------------------------
 290    -- Linker_Library_Path_Option --
 291    --------------------------------
 292
 293    function Linker_Library_Path_Option return String_Access is
 294
 295       Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
 296       pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option");
 297       --  Pointer to string representing the native linker option which
 298       --  specifies the path where the dynamic loader should find shared
 299       --  libraries. Equal to null string if this system doesn't support it.
 300
 301       S : constant String := Interfaces.C.Strings.Value (Run_Path_Option_Ptr);
 302
 303    begin
 304       if S'Length = 0 then
 305          return null;
 306       else
 307          return new String'(S);
 308       end if;
 309    end Linker_Library_Path_Option;
 310
 311 --  Package elaboration
 312
 313 begin
 314    --  Copy_Attributes always fails on VMS
 315
 316    if Hostparm.OpenVMS then
 317       Preserve := None;
 318    end if;
 319 end MLib;