]>
Commit | Line | Data |
---|---|---|
8f9df7d8 VC |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- M A K E U T L -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
7d903840 | 9 | -- Copyright (C) 2004-2008, Free Software Foundation, Inc. -- |
8f9df7d8 VC |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
8f9df7d8 VC |
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 -- | |
b5c84c3c RD |
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. -- | |
8f9df7d8 VC |
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 | ||
7d903840 | 26 | with Debug; |
5950a3ac | 27 | with Osint; use Osint; |
2cd44f5a | 28 | with Output; use Output; |
8f9df7d8 VC |
29 | with Prj.Ext; |
30 | with Prj.Util; | |
5950a3ac | 31 | with Snames; use Snames; |
8f9df7d8 | 32 | with Table; |
8f9df7d8 | 33 | |
7d903840 AC |
34 | with Ada.Command_Line; use Ada.Command_Line; |
35 | ||
36 | with GNAT.Directory_Operations; use GNAT.Directory_Operations; | |
37 | ||
958a816e | 38 | with System.Case_Util; use System.Case_Util; |
aa720a54 AC |
39 | with System.HTable; |
40 | ||
8f9df7d8 VC |
41 | package body Makeutl is |
42 | ||
aa720a54 AC |
43 | type Mark_Key is record |
44 | File : File_Name_Type; | |
45 | Index : Int; | |
46 | end record; | |
47 | -- Identify either a mono-unit source (when Index = 0) or a specific unit | |
7d903840 | 48 | -- (index = 1's origin index of unit) in a multi-unit source. |
aa720a54 | 49 | |
5950a3ac AC |
50 | -- There follow many global undocumented declarations, comments needed ??? |
51 | ||
aa720a54 AC |
52 | Max_Mask_Num : constant := 2048; |
53 | ||
54 | subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1; | |
55 | ||
56 | function Hash (Key : Mark_Key) return Mark_Num; | |
57 | ||
58 | package Marks is new System.HTable.Simple_HTable | |
59 | (Header_Num => Mark_Num, | |
60 | Element => Boolean, | |
61 | No_Element => False, | |
62 | Key => Mark_Key, | |
63 | Hash => Hash, | |
64 | Equal => "="); | |
9de61fcb | 65 | -- A hash table to keep tracks of the marked units |
aa720a54 | 66 | |
8f9df7d8 VC |
67 | type Linker_Options_Data is record |
68 | Project : Project_Id; | |
69 | Options : String_List_Id; | |
70 | end record; | |
71 | ||
72 | Linker_Option_Initial_Count : constant := 20; | |
73 | ||
74 | Linker_Options_Buffer : String_List_Access := | |
75 | new String_List (1 .. Linker_Option_Initial_Count); | |
76 | ||
77 | Last_Linker_Option : Natural := 0; | |
78 | ||
79 | package Linker_Opts is new Table.Table ( | |
80 | Table_Component_Type => Linker_Options_Data, | |
81 | Table_Index_Type => Integer, | |
82 | Table_Low_Bound => 1, | |
83 | Table_Initial => 10, | |
84 | Table_Increment => 100, | |
85 | Table_Name => "Make.Linker_Opts"); | |
86 | ||
87 | procedure Add_Linker_Option (Option : String); | |
88 | ||
2cd44f5a VC |
89 | --------- |
90 | -- Add -- | |
91 | --------- | |
92 | ||
93 | procedure Add | |
94 | (Option : String_Access; | |
95 | To : in out String_List_Access; | |
96 | Last : in out Natural) | |
97 | is | |
98 | begin | |
99 | if Last = To'Last then | |
100 | declare | |
101 | New_Options : constant String_List_Access := | |
102 | new String_List (1 .. To'Last * 2); | |
103 | begin | |
104 | New_Options (To'Range) := To.all; | |
105 | ||
106 | -- Set all elements of the original options to null to avoid | |
107 | -- deallocation of copies. | |
108 | ||
109 | To.all := (others => null); | |
110 | ||
111 | Free (To); | |
112 | To := New_Options; | |
113 | end; | |
114 | end if; | |
115 | ||
116 | Last := Last + 1; | |
117 | To (Last) := Option; | |
118 | end Add; | |
119 | ||
120 | procedure Add | |
121 | (Option : String; | |
122 | To : in out String_List_Access; | |
123 | Last : in out Natural) | |
124 | is | |
125 | begin | |
126 | Add (Option => new String'(Option), To => To, Last => Last); | |
127 | end Add; | |
128 | ||
8f9df7d8 VC |
129 | ----------------------- |
130 | -- Add_Linker_Option -- | |
131 | ----------------------- | |
132 | ||
133 | procedure Add_Linker_Option (Option : String) is | |
134 | begin | |
135 | if Option'Length > 0 then | |
136 | if Last_Linker_Option = Linker_Options_Buffer'Last then | |
137 | declare | |
138 | New_Buffer : constant String_List_Access := | |
5950a3ac AC |
139 | new String_List |
140 | (1 .. Linker_Options_Buffer'Last + | |
141 | Linker_Option_Initial_Count); | |
8f9df7d8 VC |
142 | begin |
143 | New_Buffer (Linker_Options_Buffer'Range) := | |
144 | Linker_Options_Buffer.all; | |
145 | Linker_Options_Buffer.all := (others => null); | |
146 | Free (Linker_Options_Buffer); | |
147 | Linker_Options_Buffer := New_Buffer; | |
148 | end; | |
149 | end if; | |
150 | ||
151 | Last_Linker_Option := Last_Linker_Option + 1; | |
152 | Linker_Options_Buffer (Last_Linker_Option) := new String'(Option); | |
153 | end if; | |
154 | end Add_Linker_Option; | |
155 | ||
2cd44f5a VC |
156 | ----------------- |
157 | -- Create_Name -- | |
158 | ----------------- | |
159 | ||
160 | function Create_Name (Name : String) return File_Name_Type is | |
161 | begin | |
162 | Name_Len := 0; | |
163 | Add_Str_To_Name_Buffer (Name); | |
164 | return Name_Find; | |
165 | end Create_Name; | |
166 | ||
167 | function Create_Name (Name : String) return Name_Id is | |
168 | begin | |
169 | Name_Len := 0; | |
170 | Add_Str_To_Name_Buffer (Name); | |
171 | return Name_Find; | |
172 | end Create_Name; | |
173 | ||
174 | function Create_Name (Name : String) return Path_Name_Type is | |
175 | begin | |
176 | Name_Len := 0; | |
177 | Add_Str_To_Name_Buffer (Name); | |
178 | return Name_Find; | |
179 | end Create_Name; | |
180 | ||
aa720a54 AC |
181 | ---------------------- |
182 | -- Delete_All_Marks -- | |
183 | ---------------------- | |
184 | ||
185 | procedure Delete_All_Marks is | |
186 | begin | |
187 | Marks.Reset; | |
188 | end Delete_All_Marks; | |
189 | ||
958a816e VC |
190 | ---------------------------- |
191 | -- Executable_Prefix_Path -- | |
192 | ---------------------------- | |
193 | ||
194 | function Executable_Prefix_Path return String is | |
195 | Exec_Name : constant String := Command_Name; | |
196 | ||
197 | function Get_Install_Dir (S : String) return String; | |
dec55d76 | 198 | -- S is the executable name preceded by the absolute or relative |
958a816e VC |
199 | -- path, e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory |
200 | -- where "bin" lies (in the example "C:\usr"). | |
201 | -- If the executable is not in a "bin" directory, return "". | |
202 | ||
203 | --------------------- | |
204 | -- Get_Install_Dir -- | |
205 | --------------------- | |
206 | ||
207 | function Get_Install_Dir (S : String) return String is | |
208 | Exec : String := S; | |
209 | Path_Last : Integer := 0; | |
210 | ||
211 | begin | |
212 | for J in reverse Exec'Range loop | |
213 | if Exec (J) = Directory_Separator then | |
214 | Path_Last := J - 1; | |
215 | exit; | |
216 | end if; | |
217 | end loop; | |
218 | ||
219 | if Path_Last >= Exec'First + 2 then | |
220 | To_Lower (Exec (Path_Last - 2 .. Path_Last)); | |
221 | end if; | |
222 | ||
223 | if Path_Last < Exec'First + 2 | |
224 | or else Exec (Path_Last - 2 .. Path_Last) /= "bin" | |
225 | or else (Path_Last - 3 >= Exec'First | |
226 | and then Exec (Path_Last - 3) /= Directory_Separator) | |
227 | then | |
228 | return ""; | |
229 | end if; | |
230 | ||
231 | return Normalize_Pathname (Exec (Exec'First .. Path_Last - 4)); | |
232 | end Get_Install_Dir; | |
233 | ||
234 | -- Beginning of Executable_Prefix_Path | |
235 | ||
236 | begin | |
237 | -- First determine if a path prefix was placed in front of the | |
238 | -- executable name. | |
239 | ||
240 | for J in reverse Exec_Name'Range loop | |
241 | if Exec_Name (J) = Directory_Separator then | |
242 | return Get_Install_Dir (Exec_Name); | |
243 | end if; | |
244 | end loop; | |
245 | ||
246 | -- If we get here, the user has typed the executable name with no | |
247 | -- directory prefix. | |
248 | ||
67d7b0ab VC |
249 | declare |
250 | Path : constant String_Access := Locate_Exec_On_Path (Exec_Name); | |
67d7b0ab VC |
251 | begin |
252 | if Path = null then | |
253 | return ""; | |
67d7b0ab VC |
254 | else |
255 | return Get_Install_Dir (Path.all); | |
256 | end if; | |
257 | end; | |
958a816e VC |
258 | end Executable_Prefix_Path; |
259 | ||
aa720a54 AC |
260 | ---------- |
261 | -- Hash -- | |
262 | ---------- | |
263 | ||
264 | function Hash (Key : Mark_Key) return Mark_Num is | |
265 | begin | |
266 | return Union_Id (Key.File) mod Max_Mask_Num; | |
267 | end Hash; | |
268 | ||
2cd44f5a VC |
269 | ------------ |
270 | -- Inform -- | |
271 | ------------ | |
272 | ||
273 | procedure Inform (N : File_Name_Type; Msg : String) is | |
274 | begin | |
275 | Inform (Name_Id (N), Msg); | |
276 | end Inform; | |
277 | ||
278 | procedure Inform (N : Name_Id := No_Name; Msg : String) is | |
279 | begin | |
280 | Osint.Write_Program_Name; | |
281 | ||
282 | Write_Str (": "); | |
283 | ||
284 | if N /= No_Name then | |
285 | Write_Str (""""); | |
7d903840 AC |
286 | |
287 | declare | |
288 | Name : constant String := Get_Name_String (N); | |
289 | begin | |
290 | if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then | |
291 | Write_Str (File_Name (Name)); | |
292 | else | |
293 | Write_Str (Name); | |
294 | end if; | |
295 | end; | |
296 | ||
2cd44f5a VC |
297 | Write_Str (""" "); |
298 | end if; | |
299 | ||
300 | Write_Str (Msg); | |
301 | Write_Eol; | |
302 | end Inform; | |
303 | ||
8f9df7d8 VC |
304 | ---------------------------- |
305 | -- Is_External_Assignment -- | |
306 | ---------------------------- | |
307 | ||
308 | function Is_External_Assignment (Argv : String) return Boolean is | |
309 | Start : Positive := 3; | |
310 | Finish : Natural := Argv'Last; | |
311 | Equal_Pos : Natural; | |
312 | ||
bfc8aa81 RD |
313 | pragma Assert (Argv'First = 1); |
314 | pragma Assert (Argv (1 .. 2) = "-X"); | |
315 | ||
8f9df7d8 VC |
316 | begin |
317 | if Argv'Last < 5 then | |
318 | return False; | |
319 | ||
320 | elsif Argv (3) = '"' then | |
321 | if Argv (Argv'Last) /= '"' or else Argv'Last < 7 then | |
322 | return False; | |
323 | else | |
324 | Start := 4; | |
325 | Finish := Argv'Last - 1; | |
326 | end if; | |
327 | end if; | |
328 | ||
329 | Equal_Pos := Start; | |
330 | ||
331 | while Equal_Pos <= Finish and then Argv (Equal_Pos) /= '=' loop | |
332 | Equal_Pos := Equal_Pos + 1; | |
333 | end loop; | |
334 | ||
335 | if Equal_Pos = Start | |
39f4e199 | 336 | or else Equal_Pos > Finish |
8f9df7d8 VC |
337 | then |
338 | return False; | |
8f9df7d8 VC |
339 | else |
340 | Prj.Ext.Add | |
341 | (External_Name => Argv (Start .. Equal_Pos - 1), | |
342 | Value => Argv (Equal_Pos + 1 .. Finish)); | |
343 | return True; | |
344 | end if; | |
345 | end Is_External_Assignment; | |
346 | ||
aa720a54 AC |
347 | --------------- |
348 | -- Is_Marked -- | |
349 | --------------- | |
350 | ||
351 | function Is_Marked | |
352 | (Source_File : File_Name_Type; | |
5950a3ac | 353 | Index : Int := 0) return Boolean |
aa720a54 AC |
354 | is |
355 | begin | |
356 | return Marks.Get (K => (File => Source_File, Index => Index)); | |
357 | end Is_Marked; | |
358 | ||
8f9df7d8 VC |
359 | ----------------------------- |
360 | -- Linker_Options_Switches -- | |
361 | ----------------------------- | |
362 | ||
363 | function Linker_Options_Switches | |
7e98a4c6 VC |
364 | (Project : Project_Id; |
365 | In_Tree : Project_Tree_Ref) return String_List | |
8f9df7d8 | 366 | is |
5950a3ac AC |
367 | procedure Recursive_Add_Linker_Options (Proj : Project_Id); |
368 | -- The recursive routine used to add linker options | |
8f9df7d8 VC |
369 | |
370 | ---------------------------------- | |
371 | -- Recursive_Add_Linker_Options -- | |
372 | ---------------------------------- | |
373 | ||
8f9df7d8 | 374 | procedure Recursive_Add_Linker_Options (Proj : Project_Id) is |
5950a3ac | 375 | Data : Project_Data; |
8f9df7d8 | 376 | Linker_Package : Package_Id; |
5950a3ac AC |
377 | Options : Variable_Value; |
378 | Imported : Project_List; | |
379 | ||
8f9df7d8 VC |
380 | begin |
381 | if Proj /= No_Project then | |
7e98a4c6 | 382 | Data := In_Tree.Projects.Table (Proj); |
8f9df7d8 VC |
383 | |
384 | if not Data.Seen then | |
7e98a4c6 | 385 | In_Tree.Projects.Table (Proj).Seen := True; |
8f9df7d8 VC |
386 | Imported := Data.Imported_Projects; |
387 | ||
388 | while Imported /= Empty_Project_List loop | |
389 | Recursive_Add_Linker_Options | |
7e98a4c6 VC |
390 | (In_Tree.Project_Lists.Table |
391 | (Imported).Project); | |
392 | Imported := In_Tree.Project_Lists.Table | |
393 | (Imported).Next; | |
8f9df7d8 VC |
394 | end loop; |
395 | ||
396 | if Proj /= Project then | |
397 | Linker_Package := | |
398 | Prj.Util.Value_Of | |
7e98a4c6 VC |
399 | (Name => Name_Linker, |
400 | In_Packages => Data.Decl.Packages, | |
401 | In_Tree => In_Tree); | |
8f9df7d8 VC |
402 | Options := |
403 | Prj.Util.Value_Of | |
7e98a4c6 VC |
404 | (Name => Name_Ada, |
405 | Index => 0, | |
8f9df7d8 | 406 | Attribute_Or_Array_Name => Name_Linker_Options, |
7e98a4c6 VC |
407 | In_Package => Linker_Package, |
408 | In_Tree => In_Tree); | |
8f9df7d8 VC |
409 | |
410 | -- If attribute is present, add the project with | |
411 | -- the attribute to table Linker_Opts. | |
412 | ||
413 | if Options /= Nil_Variable_Value then | |
414 | Linker_Opts.Increment_Last; | |
415 | Linker_Opts.Table (Linker_Opts.Last) := | |
416 | (Project => Proj, Options => Options.Values); | |
417 | end if; | |
418 | end if; | |
419 | end if; | |
420 | end if; | |
421 | end Recursive_Add_Linker_Options; | |
422 | ||
5950a3ac AC |
423 | -- Start of processing for Linker_Options_Switches |
424 | ||
8f9df7d8 VC |
425 | begin |
426 | Linker_Opts.Init; | |
427 | ||
7e98a4c6 VC |
428 | for Index in Project_Table.First .. |
429 | Project_Table.Last (In_Tree.Projects) | |
430 | loop | |
431 | In_Tree.Projects.Table (Index).Seen := False; | |
8f9df7d8 VC |
432 | end loop; |
433 | ||
434 | Recursive_Add_Linker_Options (Project); | |
435 | ||
436 | Last_Linker_Option := 0; | |
437 | ||
438 | for Index in reverse 1 .. Linker_Opts.Last loop | |
439 | declare | |
440 | Options : String_List_Id := Linker_Opts.Table (Index).Options; | |
441 | Proj : constant Project_Id := | |
442 | Linker_Opts.Table (Index).Project; | |
443 | Option : Name_Id; | |
444 | ||
445 | begin | |
446 | -- If Dir_Path has not been computed for this project, do it now | |
447 | ||
7e98a4c6 VC |
448 | if In_Tree.Projects.Table (Proj).Dir_Path = null then |
449 | In_Tree.Projects.Table (Proj).Dir_Path := | |
8f9df7d8 | 450 | new String' |
7e98a4c6 VC |
451 | (Get_Name_String |
452 | (In_Tree.Projects.Table | |
3b3c0430 | 453 | (Proj).Directory.Name)); |
8f9df7d8 VC |
454 | end if; |
455 | ||
456 | while Options /= Nil_String loop | |
7e98a4c6 VC |
457 | Option := |
458 | In_Tree.String_Elements.Table (Options).Value; | |
f2c573b1 VC |
459 | Get_Name_String (Option); |
460 | ||
461 | -- Do not consider empty linker options | |
462 | ||
463 | if Name_Len /= 0 then | |
464 | Add_Linker_Option (Name_Buffer (1 .. Name_Len)); | |
465 | ||
466 | -- Object files and -L switches specified with relative | |
467 | -- paths must be converted to absolute paths. | |
468 | ||
469 | Test_If_Relative_Path | |
470 | (Switch => | |
471 | Linker_Options_Buffer (Last_Linker_Option), | |
472 | Parent => | |
473 | In_Tree.Projects.Table (Proj).Dir_Path, | |
474 | Including_L_Switch => True); | |
475 | end if; | |
476 | ||
7e98a4c6 VC |
477 | Options := |
478 | In_Tree.String_Elements.Table (Options).Next; | |
8f9df7d8 VC |
479 | end loop; |
480 | end; | |
481 | end loop; | |
482 | ||
483 | return Linker_Options_Buffer (1 .. Last_Linker_Option); | |
484 | end Linker_Options_Switches; | |
485 | ||
486 | ----------- | |
487 | -- Mains -- | |
488 | ----------- | |
489 | ||
490 | package body Mains is | |
491 | ||
1e887886 VC |
492 | type File_And_Loc is record |
493 | File_Name : File_Name_Type; | |
494 | Location : Source_Ptr := No_Location; | |
495 | end record; | |
496 | ||
8f9df7d8 | 497 | package Names is new Table.Table |
1e887886 | 498 | (Table_Component_Type => File_And_Loc, |
8f9df7d8 VC |
499 | Table_Index_Type => Integer, |
500 | Table_Low_Bound => 1, | |
501 | Table_Initial => 10, | |
502 | Table_Increment => 100, | |
503 | Table_Name => "Makeutl.Mains.Names"); | |
504 | -- The table that stores the mains | |
505 | ||
506 | Current : Natural := 0; | |
507 | -- The index of the last main retrieved from the table | |
508 | ||
509 | -------------- | |
510 | -- Add_Main -- | |
511 | -------------- | |
512 | ||
513 | procedure Add_Main (Name : String) is | |
514 | begin | |
515 | Name_Len := 0; | |
516 | Add_Str_To_Name_Buffer (Name); | |
517 | Names.Increment_Last; | |
1e887886 | 518 | Names.Table (Names.Last) := (Name_Find, No_Location); |
8f9df7d8 VC |
519 | end Add_Main; |
520 | ||
521 | ------------ | |
522 | -- Delete -- | |
523 | ------------ | |
524 | ||
525 | procedure Delete is | |
526 | begin | |
527 | Names.Set_Last (0); | |
7e98a4c6 | 528 | Mains.Reset; |
8f9df7d8 VC |
529 | end Delete; |
530 | ||
1e887886 VC |
531 | ------------------ |
532 | -- Get_Location -- | |
533 | ------------------ | |
534 | ||
535 | function Get_Location return Source_Ptr is | |
536 | begin | |
a573518c TQ |
537 | if Current in Names.First .. Names.Last then |
538 | return Names.Table (Current).Location; | |
1e887886 | 539 | else |
a573518c | 540 | return No_Location; |
1e887886 VC |
541 | end if; |
542 | end Get_Location; | |
543 | ||
8f9df7d8 VC |
544 | --------------- |
545 | -- Next_Main -- | |
546 | --------------- | |
547 | ||
548 | function Next_Main return String is | |
549 | begin | |
550 | if Current >= Names.Last then | |
551 | return ""; | |
8f9df7d8 VC |
552 | else |
553 | Current := Current + 1; | |
1e887886 | 554 | return Get_Name_String (Names.Table (Current).File_Name); |
8f9df7d8 VC |
555 | end if; |
556 | end Next_Main; | |
557 | ||
558 | --------------------- | |
559 | -- Number_Of_Mains -- | |
560 | --------------------- | |
561 | ||
562 | function Number_Of_Mains return Natural is | |
563 | begin | |
564 | return Names.Last; | |
565 | end Number_Of_Mains; | |
566 | ||
567 | ----------- | |
568 | -- Reset -- | |
569 | ----------- | |
570 | ||
571 | procedure Reset is | |
572 | begin | |
573 | Current := 0; | |
574 | end Reset; | |
575 | ||
1e887886 VC |
576 | ------------------ |
577 | -- Set_Location -- | |
578 | ------------------ | |
579 | ||
580 | procedure Set_Location (Location : Source_Ptr) is | |
581 | begin | |
582 | if Names.Last > 0 then | |
583 | Names.Table (Names.Last).Location := Location; | |
584 | end if; | |
585 | end Set_Location; | |
586 | ||
587 | ----------------- | |
588 | -- Update_Main -- | |
589 | ----------------- | |
590 | ||
591 | procedure Update_Main (Name : String) is | |
592 | begin | |
a573518c | 593 | if Current in Names.First .. Names.Last then |
1e887886 VC |
594 | Name_Len := 0; |
595 | Add_Str_To_Name_Buffer (Name); | |
596 | Names.Table (Current).File_Name := Name_Find; | |
597 | end if; | |
598 | end Update_Main; | |
8f9df7d8 VC |
599 | end Mains; |
600 | ||
aa720a54 AC |
601 | ---------- |
602 | -- Mark -- | |
603 | ---------- | |
604 | ||
605 | procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is | |
606 | begin | |
607 | Marks.Set (K => (File => Source_File, Index => Index), E => True); | |
608 | end Mark; | |
609 | ||
7d903840 AC |
610 | ----------------------- |
611 | -- Path_Or_File_Name -- | |
612 | ----------------------- | |
613 | ||
614 | function Path_Or_File_Name (Path : Path_Name_Type) return String is | |
615 | Path_Name : constant String := Get_Name_String (Path); | |
616 | begin | |
617 | if Debug.Debug_Flag_F then | |
618 | return File_Name (Path_Name); | |
619 | else | |
620 | return Path_Name; | |
621 | end if; | |
622 | end Path_Or_File_Name; | |
623 | ||
8f9df7d8 VC |
624 | --------------------------- |
625 | -- Test_If_Relative_Path -- | |
626 | --------------------------- | |
627 | ||
628 | procedure Test_If_Relative_Path | |
1086c39b VC |
629 | (Switch : in out String_Access; |
630 | Parent : String_Access; | |
631 | Including_L_Switch : Boolean := True; | |
632 | Including_Non_Switch : Boolean := True) | |
8f9df7d8 VC |
633 | is |
634 | begin | |
635 | if Switch /= null then | |
8f9df7d8 VC |
636 | declare |
637 | Sw : String (1 .. Switch'Length); | |
638 | Start : Positive; | |
639 | ||
640 | begin | |
641 | Sw := Switch.all; | |
642 | ||
643 | if Sw (1) = '-' then | |
644 | if Sw'Length >= 3 | |
645 | and then (Sw (2) = 'A' | |
646 | or else Sw (2) = 'I' | |
647 | or else (Including_L_Switch and then Sw (2) = 'L')) | |
648 | then | |
649 | Start := 3; | |
650 | ||
651 | if Sw = "-I-" then | |
652 | return; | |
653 | end if; | |
654 | ||
655 | elsif Sw'Length >= 4 | |
656 | and then (Sw (2 .. 3) = "aL" | |
657 | or else Sw (2 .. 3) = "aO" | |
658 | or else Sw (2 .. 3) = "aI") | |
659 | then | |
660 | Start := 4; | |
661 | ||
662 | else | |
663 | return; | |
664 | end if; | |
665 | ||
666 | -- Because relative path arguments to --RTS= may be relative | |
667 | -- to the search directory prefix, those relative path | |
668 | -- arguments are not converted. | |
669 | ||
670 | if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then | |
671 | if Parent = null or else Parent'Length = 0 then | |
672 | Do_Fail | |
673 | ("relative search path switches (""", | |
674 | Sw, | |
675 | """) are not allowed"); | |
676 | ||
677 | else | |
678 | Switch := | |
679 | new String' | |
680 | (Sw (1 .. Start - 1) & | |
681 | Parent.all & | |
682 | Directory_Separator & | |
683 | Sw (Start .. Sw'Last)); | |
684 | end if; | |
685 | end if; | |
686 | ||
1086c39b | 687 | elsif Including_Non_Switch then |
8f9df7d8 VC |
688 | if not Is_Absolute_Path (Sw) then |
689 | if Parent = null or else Parent'Length = 0 then | |
690 | Do_Fail | |
691 | ("relative paths (""", Sw, """) are not allowed"); | |
692 | ||
693 | else | |
694 | Switch := | |
695 | new String'(Parent.all & Directory_Separator & Sw); | |
696 | end if; | |
697 | end if; | |
698 | end if; | |
699 | end; | |
700 | end if; | |
701 | end Test_If_Relative_Path; | |
702 | ||
aa720a54 AC |
703 | ------------------- |
704 | -- Unit_Index_Of -- | |
705 | ------------------- | |
706 | ||
707 | function Unit_Index_Of (ALI_File : File_Name_Type) return Int is | |
708 | Start : Natural; | |
709 | Finish : Natural; | |
710 | Result : Int := 0; | |
5950a3ac | 711 | |
aa720a54 AC |
712 | begin |
713 | Get_Name_String (ALI_File); | |
714 | ||
715 | -- First, find the last dot | |
716 | ||
717 | Finish := Name_Len; | |
718 | ||
719 | while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop | |
720 | Finish := Finish - 1; | |
721 | end loop; | |
722 | ||
723 | if Finish = 1 then | |
724 | return 0; | |
725 | end if; | |
726 | ||
727 | -- Now check that the dot is preceded by digits | |
728 | ||
729 | Start := Finish; | |
730 | Finish := Finish - 1; | |
731 | ||
732 | while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop | |
733 | Start := Start - 1; | |
734 | end loop; | |
735 | ||
dec55d76 | 736 | -- If there are no digits, or if the digits are not preceded by |
aa720a54 AC |
737 | -- the character that precedes a unit index, this is not the ALI file |
738 | -- of a unit in a multi-unit source. | |
739 | ||
5950a3ac AC |
740 | if Start > Finish |
741 | or else Start = 1 | |
742 | or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character | |
aa720a54 AC |
743 | then |
744 | return 0; | |
745 | end if; | |
746 | ||
747 | -- Build the index from the digit(s) | |
748 | ||
749 | while Start <= Finish loop | |
5950a3ac AC |
750 | Result := Result * 10 + |
751 | Character'Pos (Name_Buffer (Start)) - Character'Pos ('0'); | |
aa720a54 AC |
752 | Start := Start + 1; |
753 | end loop; | |
754 | ||
755 | return Result; | |
756 | end Unit_Index_Of; | |
757 | ||
8f9df7d8 | 758 | end Makeutl; |