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