gcc/ada/gnatlbr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              G N A T L B R                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1997-2008, 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 --  Program to create, set, or delete an alternate runtime library
  27
  28 --  Works by calling an appropriate target specific Makefile residing
  29 --  in the default library object (e.g. adalib) directory from the context
  30 --  of the new library objects directory.
  31
  32 --  Command line arguments are:
  33 --  1st:  --[create | set | delete]=<directory_spec>
  34 --    --create : Build a library
  35 --    --set    : Set environment variables to point to a library
  36 --    --delete : Delete a library
  37
  38 --  2nd:  --config=<file_spec>
  39 --  A -gnatg valid file containing desired configuration pragmas
  40
  41 --  This program is currently used only on Alpha/VMS
  42
  43 with Ada.Command_Line;     use Ada.Command_Line;
  44 with Ada.Text_IO;          use Ada.Text_IO;
  45 with GNAT.OS_Lib;          use GNAT.OS_Lib;
  46 with Gnatvsn;              use Gnatvsn;
  47 with Interfaces.C_Streams; use Interfaces.C_Streams;
  48 with Osint;                use Osint;
  49 with System;
  50
  51 procedure GnatLbr is
  52    pragma Ident (Gnat_Static_Version_String);
  53
  54    type Lib_Mode is (None, Create, Set, Delete);
  55    Next_Arg  : Integer;
  56    Mode      : Lib_Mode := None;
  57    ADC_File  : String_Access := null;
  58    Lib_Dir   : String_Access := null;
  59    Make      : constant String := "make";
  60    Make_Path : String_Access;
  61
  62    procedure Create_Directory (Name : System.Address; Mode : Integer);
  63    pragma Import (C, Create_Directory, "decc$mkdir");
  64
  65 begin
  66    if Argument_Count = 0 then
  67       Put ("Usage: ");
  68       Put_Line
  69         ("gnatlbr --[create|set|delete]=<directory> [--config=<file>]");
  70       Exit_Program (E_Fatal);
  71    end if;
  72
  73    Next_Arg := 1;
  74
  75    loop
  76       exit when Next_Arg > Argument_Count;
  77
  78       Process_One_Arg : declare
  79          Arg : constant String := Argument (Next_Arg);
  80
  81       begin
  82          if Arg'Length > 9 and then Arg (1 .. 9) = "--create=" then
  83             if Mode = None then
  84                Mode := Create;
  85                Lib_Dir := new String'(Arg (10 .. Arg'Last));
  86             else
  87                Put_Line (Standard_Error, "Error: Multiple modes specified");
  88                Exit_Program (E_Fatal);
  89             end if;
  90
  91          elsif Arg'Length > 6 and then Arg (1 .. 6) = "--set=" then
  92             if Mode = None then
  93                Mode := Set;
  94                Lib_Dir := new String'(Arg (7 .. Arg'Last));
  95             else
  96                Put_Line (Standard_Error, "Error: Multiple modes specified");
  97                Exit_Program (E_Fatal);
  98             end if;
  99
 100          elsif Arg'Length > 9 and then Arg (1 .. 9) = "--delete=" then
 101             if Mode = None then
 102                Mode := Delete;
 103                Lib_Dir := new String'(Arg (10 .. Arg'Last));
 104             else
 105                Put_Line (Standard_Error, "Error: Multiple modes specified");
 106                Exit_Program (E_Fatal);
 107             end if;
 108
 109          elsif Arg'Length > 9 and then Arg (1 .. 9) = "--config=" then
 110             if ADC_File /= null then
 111                Put_Line (Standard_Error,
 112                          "Error: Multiple gnat.adc files specified");
 113                Exit_Program (E_Fatal);
 114             end if;
 115
 116             ADC_File := new String'(Arg (10 .. Arg'Last));
 117
 118          else
 119             Put_Line (Standard_Error, "Error: Unrecognized option: " & Arg);
 120             Exit_Program (E_Fatal);
 121
 122          end if;
 123       end Process_One_Arg;
 124
 125       Next_Arg := Next_Arg + 1;
 126    end loop;
 127
 128    case Mode is
 129       when Create =>
 130
 131          --  Validate arguments
 132
 133          if Lib_Dir = null then
 134             Put_Line (Standard_Error, "Error: No library directory specified");
 135             Exit_Program (E_Fatal);
 136          end if;
 137
 138          if Is_Directory (Lib_Dir.all) then
 139             Put_Line (Standard_Error,
 140                       "Error:" & Lib_Dir.all & " already exists");
 141             Exit_Program (E_Fatal);
 142          end if;
 143
 144          if ADC_File = null then
 145             Put_Line (Standard_Error,
 146                       "Error: No configuration file specified");
 147             Exit_Program (E_Fatal);
 148          end if;
 149
 150          if not Is_Regular_File (ADC_File.all) then
 151             Put_Line (Standard_Error,
 152                       "Error: " & ADC_File.all & " doesn't exist");
 153             Exit_Program (E_Fatal);
 154          end if;
 155
 156          Create_Block : declare
 157             Success        : Boolean;
 158             Make_Args      : Argument_List (1 .. 9);
 159             C_Lib_Dir      : String := Lib_Dir.all & ASCII.NUL;
 160             C_ADC_File     : String := ADC_File.all & ASCII.NUL;
 161             F_ADC_File     : String (1 .. max_path_len);
 162             F_ADC_File_Len : Integer := max_path_len;
 163             Include_Dirs   : Integer;
 164             Object_Dirs    : Integer;
 165             Include_Dir    : array (Integer range 1 .. 256) of String_Access;
 166             Object_Dir     : array (Integer range 1 .. 256) of String_Access;
 167             Include_Dir_Name : String_Access;
 168             Object_Dir_Name  : String_Access;
 169
 170          begin
 171             --  Create the new top level library directory
 172
 173             if not Is_Directory (Lib_Dir.all) then
 174                Create_Directory (C_Lib_Dir'Address, 8#755#);
 175             end if;
 176
 177             full_name (C_ADC_File'Address, F_ADC_File'Address);
 178
 179             for I in 1 .. max_path_len loop
 180                if F_ADC_File (I) = ASCII.NUL then
 181                   F_ADC_File_Len := I - 1;
 182                   exit;
 183                end if;
 184             end loop;
 185
 186             --
 187             --  Make a list of the default library source and object
 188             --  directories.  Usually only one, except on VMS where
 189             --  there are two.
 190             --
 191             Include_Dirs := 0;
 192             Include_Dir_Name := new String'(Include_Dir_Default_Prefix);
 193             Get_Next_Dir_In_Path_Init (Include_Dir_Name);
 194
 195             loop
 196                declare
 197                   Dir : constant String_Access := String_Access
 198                     (Get_Next_Dir_In_Path (Include_Dir_Name));
 199                begin
 200                   exit when Dir = null;
 201                   Include_Dirs := Include_Dirs + 1;
 202                   Include_Dir (Include_Dirs) :=
 203                     String_Access (Normalize_Directory_Name (Dir.all));
 204                end;
 205             end loop;
 206
 207             Object_Dirs := 0;
 208             Object_Dir_Name := new String'(Object_Dir_Default_Prefix);
 209             Get_Next_Dir_In_Path_Init (Object_Dir_Name);
 210
 211             loop
 212                declare
 213                   Dir : constant String_Access :=
 214                           String_Access
 215                             (Get_Next_Dir_In_Path (Object_Dir_Name));
 216                begin
 217                   exit when Dir = null;
 218                   Object_Dirs := Object_Dirs + 1;
 219                   Object_Dir (Object_Dirs)
 220                     := String_Access (Normalize_Directory_Name (Dir.all));
 221                end;
 222             end loop;
 223
 224             --  "Make" an alternate sublibrary for each default sublibrary
 225
 226             for Dirs in 1 .. Object_Dirs loop
 227                Make_Args (1) :=
 228                  new String'("-C");
 229
 230                Make_Args (2) :=
 231                  new String'(Lib_Dir.all);
 232
 233                --  Resolve /gnu on VMS by converting to host format and then
 234                --  convert resolved path back to canonical format for the
 235                --  make program. This fixes the problem that can occur when
 236                --  GNU: is a search path pointing to multiple versions of GNAT.
 237
 238                Make_Args (3) :=
 239                  new String'("ADA_INCLUDE_PATH=" &
 240                    To_Canonical_Dir_Spec
 241                      (To_Host_Dir_Spec
 242                        (Include_Dir (Dirs).all, True).all, True).all);
 243
 244                Make_Args (4) :=
 245                  new String'("ADA_OBJECTS_PATH=" &
 246                    To_Canonical_Dir_Spec
 247                      (To_Host_Dir_Spec
 248                        (Object_Dir (Dirs).all, True).all, True).all);
 249
 250                Make_Args (5) :=
 251                  new String'("GNAT_ADC_FILE="
 252                              & F_ADC_File (1 .. F_ADC_File_Len));
 253
 254                Make_Args (6) :=
 255                  new String'("LIBRARY_VERSION=" & '"' &
 256                              Verbose_Library_Version & '"');
 257
 258                Make_Args (7) :=
 259                  new String'("-f");
 260
 261                Make_Args (8) :=
 262                  new String'(Object_Dir (Dirs).all & "Makefile.lib");
 263
 264                Make_Args (9) :=
 265                  new String'("create");
 266
 267                Make_Path := Locate_Exec_On_Path (Make);
 268                Put (Make);
 269
 270                for J in 1 .. Make_Args'Last loop
 271                   Put (" ");
 272                   Put (Make_Args (J).all);
 273                end loop;
 274
 275                New_Line;
 276                Spawn (Make_Path.all, Make_Args, Success);
 277
 278                if not Success then
 279                   Put_Line (Standard_Error, "Error: Make failed");
 280                   Exit_Program (E_Fatal);
 281                end if;
 282             end loop;
 283          end Create_Block;
 284
 285       when Set =>
 286
 287          --  Validate arguments
 288
 289          if Lib_Dir = null then
 290             Put_Line (Standard_Error,
 291                       "Error: No library directory specified");
 292             Exit_Program (E_Fatal);
 293          end if;
 294
 295          if not Is_Directory (Lib_Dir.all) then
 296             Put_Line (Standard_Error,
 297                       "Error: " & Lib_Dir.all & " doesn't exist");
 298             Exit_Program (E_Fatal);
 299          end if;
 300
 301          if ADC_File = null then
 302             Put_Line (Standard_Error,
 303                       "Error: No configuration file specified");
 304             Exit_Program (E_Fatal);
 305          end if;
 306
 307          if not Is_Regular_File (ADC_File.all) then
 308             Put_Line (Standard_Error,
 309                       "Error: " & ADC_File.all & " doesn't exist");
 310             Exit_Program (E_Fatal);
 311          end if;
 312
 313          --  Give instructions
 314
 315          Put_Line ("Copy the contents of "
 316            & ADC_File.all & " into your GNAT.ADC file");
 317          Put_Line ("and use GNAT Make qualifier /OBJECT_SEARCH=("
 318            & To_Host_Dir_Spec
 319                (Lib_Dir (Lib_Dir'First .. Lib_Dir'Last) & "/declib", False).all
 320            & ","
 321            & To_Host_Dir_Spec
 322                (Lib_Dir (Lib_Dir'First .. Lib_Dir'Last) & "/adalib", False).all
 323            & ")");
 324          Put_Line ("or else define ADA_OBJECTS_PATH as " & '"'
 325            & To_Host_Dir_Spec
 326                (Lib_Dir (Lib_Dir'First .. Lib_Dir'Last) & "/declib", False).all
 327            & ','
 328            & To_Host_Dir_Spec
 329                (Lib_Dir (Lib_Dir'First .. Lib_Dir'Last) & "/adalib", False).all
 330            & '"');
 331
 332       when Delete =>
 333
 334          --  Give instructions
 335
 336          Put_Line ("GNAT Librarian DELETE not yet implemented.");
 337          Put_Line ("Use appropriate system tools to remove library");
 338
 339       when None =>
 340          Put_Line (Standard_Error,
 341                    "Error: No mode (create|set|delete) specified");
 342          Exit_Program (E_Fatal);
 343
 344    end case;
 345
 346 end GnatLbr;