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