Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/vxlink.adb @ 131:84e7813d76e9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-8.2
author mir3636
date Thu, 25 Oct 2018 07:37:49 +0900
parents
children
comparison
equal deleted inserted replaced
111:04ced10e8804 131:84e7813d76e9
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- V X L I N K --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2018, AdaCore --
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 pragma Ada_2012;
27
28 with Ada.Command_Line;
29 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
30 with Ada.Text_IO;
31
32 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
33 with GNAT.Expect; use GNAT.Expect;
34 with GNAT.OS_Lib; use GNAT.OS_Lib;
35
36 package body VxLink is
37
38 Target_Triplet : Unbounded_String := Null_Unbounded_String;
39 Verbose : Boolean := False;
40 Error_State : Boolean := False;
41
42 function Triplet return String;
43 -- ??? missing spec
44
45 function Which (Exe : String) return String;
46 -- ??? missing spec
47
48 -------------
49 -- Triplet --
50 -------------
51
52 function Triplet return String is
53 begin
54 if Target_Triplet = Null_Unbounded_String then
55 declare
56 Exe : constant String := File_Name (Ada.Command_Line.Command_Name);
57 begin
58 for J in reverse Exe'Range loop
59 if Exe (J) = '-' then
60 Target_Triplet := To_Unbounded_String (Exe (Exe'First .. J));
61 exit;
62 end if;
63 end loop;
64 end;
65 end if;
66
67 return To_String (Target_Triplet);
68 end Triplet;
69
70 -----------
71 -- Which --
72 -----------
73
74 function Which (Exe : String) return String is
75 Suffix : GNAT.OS_Lib.String_Access := Get_Executable_Suffix;
76 Basename : constant String := Exe & Suffix.all;
77 Path : GNAT.OS_Lib.String_Access := Getenv ("PATH");
78 Last : Natural := Path'First;
79
80 begin
81 Free (Suffix);
82
83 for J in Path'Range loop
84 if Path (J) = Path_Separator then
85 declare
86 Full : constant String := Normalize_Pathname
87 (Name => Basename,
88 Directory => Path (Last .. J - 1),
89 Resolve_Links => False,
90 Case_Sensitive => True);
91 begin
92 if Is_Executable_File (Full) then
93 Free (Path);
94
95 return Full;
96 end if;
97 end;
98
99 Last := J + 1;
100 end if;
101 end loop;
102
103 Free (Path);
104
105 return "";
106 end Which;
107
108 -----------------
109 -- Set_Verbose --
110 -----------------
111
112 procedure Set_Verbose (Value : Boolean) is
113 begin
114 Verbose := Value;
115 end Set_Verbose;
116
117 ----------------
118 -- Is_Verbose --
119 ----------------
120
121 function Is_Verbose return Boolean is
122 begin
123 return Verbose;
124 end Is_Verbose;
125
126 ---------------------
127 -- Set_Error_State --
128 ---------------------
129
130 procedure Set_Error_State (Message : String) is
131 begin
132 Log_Error ("Error: " & Message);
133 Error_State := True;
134 Ada.Command_Line.Set_Exit_Status (1);
135 end Set_Error_State;
136
137 --------------------
138 -- Is_Error_State --
139 --------------------
140
141 function Is_Error_State return Boolean is
142 begin
143 return Error_State;
144 end Is_Error_State;
145
146 --------------
147 -- Log_Info --
148 --------------
149
150 procedure Log_Info (S : String) is
151 begin
152 if Verbose then
153 Ada.Text_IO.Put_Line (S);
154 end if;
155 end Log_Info;
156
157 ---------------
158 -- Log_Error --
159 ---------------
160
161 procedure Log_Error (S : String) is
162 begin
163 Ada.Text_IO.Put_Line (Ada.Text_IO.Standard_Error, S);
164 end Log_Error;
165
166 ---------
167 -- Run --
168 ---------
169
170 procedure Run (Arguments : Arguments_List) is
171 Output : constant String := Run (Arguments);
172 begin
173 if not Is_Error_State then
174 -- In case of erroneous execution, the function version of run will
175 -- have already displayed the output
176 Ada.Text_IO.Put (Output);
177 end if;
178 end Run;
179
180 ---------
181 -- Run --
182 ---------
183
184 function Run (Arguments : Arguments_List) return String is
185 Args : GNAT.OS_Lib.Argument_List_Access :=
186 new GNAT.OS_Lib.Argument_List
187 (1 .. Natural (Arguments.Length) - 1);
188 Base : constant String := Base_Name (Arguments.First_Element);
189
190 Debug_Line : Unbounded_String;
191 Add_Quotes : Boolean;
192
193 begin
194 if Verbose then
195 Append (Debug_Line, Base);
196 end if;
197
198 for J in Arguments.First_Index + 1 .. Arguments.Last_Index loop
199 declare
200 Arg : String renames Arguments.Element (J);
201 begin
202 Args (J - 1) := new String'(Arg);
203
204 if Verbose then
205 Add_Quotes := False;
206
207 for K in Arg'Range loop
208 if Arg (K) = ' ' then
209 Add_Quotes := True;
210 exit;
211 end if;
212 end loop;
213
214 Append (Debug_Line, ' ');
215
216 if Add_Quotes then
217 Append (Debug_Line, '"' & Arg & '"');
218 else
219 Append (Debug_Line, Arg);
220 end if;
221 end if;
222 end;
223 end loop;
224
225 if Verbose then
226 Ada.Text_IO.Put_Line (To_String (Debug_Line));
227 end if;
228
229 declare
230 Status : aliased Integer := 0;
231 Ret : constant String :=
232 Get_Command_Output
233 (Command => Arguments.First_Element,
234 Arguments => Args.all,
235 Input => "",
236 Status => Status'Access,
237 Err_To_Out => True);
238
239 begin
240 GNAT.OS_Lib.Free (Args);
241
242 if Status /= 0 then
243 Ada.Text_IO.Put_Line (Ret);
244 Set_Error_State
245 (Base_Name (Arguments.First_Element) &
246 " returned" & Status'Image);
247 end if;
248
249 return Ret;
250 end;
251 end Run;
252
253 ---------
254 -- Gcc --
255 ---------
256
257 function Gcc return String is
258 begin
259 return Which (Triplet & "gcc");
260 end Gcc;
261
262 ---------
263 -- Gxx --
264 ---------
265
266 function Gxx return String is
267 begin
268 return Which (Triplet & "g++");
269 end Gxx;
270
271 --------
272 -- Nm --
273 --------
274
275 function Nm return String is
276 begin
277 return Which (Triplet & "nm");
278 end Nm;
279
280 end VxLink;