File : spark2c_wrapper.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S P A R K C 2 C _ W R A P P E R --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2010-2015, 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 with Ada.Command_Line; use Ada.Command_Line;
27 with Ada.Environment_Variables; use Ada.Environment_Variables;
28
29 with GNAT.Case_Util; use GNAT.Case_Util;
30 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
31 with GNAT.IO; use GNAT.IO;
32 with GNAT.OS_Lib; use GNAT.OS_Lib;
33
34 -- Wrapper around <install>/libexec/spark2c/bin/c-xxx to be
35 -- installed under <install>/bin
36
37 procedure SPARK2C_Wrapper is
38
39 function Executable_Location return String;
40 -- Return the name of the parent directory where the executable is stored
41 -- (so if you are running "prefix"/bin/gcc, you would get "prefix").
42 -- A special case is done for "bin" directories, which are skipped.
43 -- The returned directory always ends up with a directory separator.
44
45 function Is_Directory_Separator (C : Character) return Boolean;
46 -- Return True if C is a directory separator
47
48 function Locate_Exec (Exec : String) return String;
49 -- Locate Exec from <prefix>/libexec/spark2c/bin. If not found, generate an
50 -- error message on stdout and exit with status 1.
51
52 -------------------------
53 -- Executable_Location --
54 -------------------------
55
56 function Executable_Location return String is
57 Exec_Name : constant String := Ada.Command_Line.Command_Name;
58
59 function Get_Install_Dir (S : String) return String;
60 -- S is the executable name preceeded by the absolute or relative path,
61 -- e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc". Returns the absolute or
62 -- relative directory where "bin" lies (in the example "C:\usr" or
63 -- ".."). If the executable is not a "bin" directory, return "".
64
65 ---------------------
66 -- Get_Install_Dir --
67 ---------------------
68
69 function Get_Install_Dir (S : String) return String is
70 Exec : String := GNAT.OS_Lib.Normalize_Pathname
71 (S, Resolve_Links => True);
72 Path_Last : Integer := 0;
73
74 begin
75 for J in reverse Exec'Range loop
76 if Is_Directory_Separator (Exec (J)) then
77 Path_Last := J - 1;
78 exit;
79 end if;
80 end loop;
81
82 if Path_Last >= Exec'First + 2 then
83 GNAT.Case_Util.To_Lower (Exec (Path_Last - 2 .. Path_Last));
84 end if;
85
86 -- If we are not in a bin/ directory
87
88 if Path_Last < Exec'First + 2
89 or else Exec (Path_Last - 2 .. Path_Last) /= "bin"
90 or else (Path_Last - 3 >= Exec'First
91 and then
92 not Is_Directory_Separator (Exec (Path_Last - 3)))
93 then
94 return Exec (Exec'First .. Path_Last)
95 & GNAT.OS_Lib.Directory_Separator;
96
97 else
98 -- Skip bin/, but keep the last directory separator
99
100 return Exec (Exec'First .. Path_Last - 3);
101 end if;
102 end Get_Install_Dir;
103
104 -- Start of processing for Executable_Location
105
106 begin
107 -- First determine if a path prefix was placed in front of the
108 -- executable name.
109
110 for J in reverse Exec_Name'Range loop
111 if Is_Directory_Separator (Exec_Name (J)) then
112 return Get_Install_Dir (Exec_Name);
113 end if;
114 end loop;
115
116 -- If you are here, the user has typed the executable name with no
117 -- directory prefix.
118
119 declare
120 Ex : String_Access := GNAT.OS_Lib.Locate_Exec_On_Path (Exec_Name);
121 Dir : constant String := Get_Install_Dir (Ex.all);
122
123 begin
124 Free (Ex);
125 return Dir;
126 end;
127 end Executable_Location;
128
129 ----------------------------
130 -- Is_Directory_Separator --
131 ----------------------------
132
133 function Is_Directory_Separator (C : Character) return Boolean is
134 begin
135 -- In addition to the default directory_separator allow the '/' to act
136 -- as separator.
137
138 return C = Directory_Separator or else C = '/';
139 end Is_Directory_Separator;
140
141 Libexec : constant String := Executable_Location & "libexec/spark2c/bin";
142
143 -----------------
144 -- Locate_Exec --
145 -----------------
146
147 function Locate_Exec (Exec : String) return String is
148 Exe : constant String_Access := Get_Target_Executable_Suffix;
149 -- Note: the leak on Exe does not matter since this function is called
150 -- only once.
151
152 Result : constant String := Libexec & "/" & Exec;
153
154 begin
155 if Is_Executable_File (Result & Exe.all) then
156 return Result;
157 else
158 Put_Line (Result & " executable not found, exiting.");
159 OS_Exit (1);
160 end if;
161 end Locate_Exec;
162
163 -- Local variables
164
165 Count : constant Natural := Argument_Count;
166 Path_Val : constant String := Value ("PATH", "");
167 Args : Argument_List (1 .. Count);
168 Status : Integer;
169
170 -- Start of processing for SPARK2C_Wrapper
171
172 begin
173 -- Add <prefix>/libexec/spark2c/bin in front of the PATH
174
175 Set ("PATH", Libexec & Path_Separator & Path_Val);
176
177 for J in 1 .. Count loop
178 Args (J) := new String'(Argument (J));
179 end loop;
180
181 Status := Spawn (Locate_Exec (Base_Name (Command_Name, ".exe")), Args);
182
183 for J in Args'Range loop
184 Free (Args (J));
185 end loop;
186
187 OS_Exit (Status);
188 end SPARK2C_Wrapper;