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