]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/ada/prj-nmsc.adb
[multiple changes]
[thirdparty/gcc.git] / gcc / ada / prj-nmsc.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . N M S C --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2000-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 Err_Vars; use Err_Vars;
27 with Opt; use Opt;
28 with Osint; use Osint;
29 with Output; use Output;
30 with Prj.Com;
31 with Prj.Env; use Prj.Env;
32 with Prj.Err; use Prj.Err;
33 with Prj.Tree; use Prj.Tree;
34 with Prj.Util; use Prj.Util;
35 with Sinput.P;
36 with Snames; use Snames;
37
38 with Ada; use Ada;
39 with Ada.Characters.Handling; use Ada.Characters.Handling;
40 with Ada.Directories; use Ada.Directories;
41 with Ada.Strings; use Ada.Strings;
42 with Ada.Strings.Fixed; use Ada.Strings.Fixed;
43 with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
44
45 with GNAT.Case_Util; use GNAT.Case_Util;
46 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
47 with GNAT.Dynamic_HTables;
48 with GNAT.Regexp; use GNAT.Regexp;
49 with GNAT.Table;
50
51 package body Prj.Nmsc is
52
53 No_Continuation_String : aliased String := "";
54 Continuation_String : aliased String := "\";
55 -- Used in Check_Library for continuation error messages at the same
56 -- location.
57
58 type Name_Location is record
59 Name : File_Name_Type;
60 -- Key is duplicated, so that it is known when using functions Get_First
61 -- and Get_Next, as these functions only return an Element.
62
63 Location : Source_Ptr;
64 Source : Source_Id := No_Source;
65 Listed : Boolean := False;
66 Found : Boolean := False;
67 end record;
68
69 No_Name_Location : constant Name_Location :=
70 (Name => No_File,
71 Location => No_Location,
72 Source => No_Source,
73 Listed => False,
74 Found => False);
75
76 package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
77 (Header_Num => Header_Num,
78 Element => Name_Location,
79 No_Element => No_Name_Location,
80 Key => File_Name_Type,
81 Hash => Hash,
82 Equal => "=");
83 -- File name information found in string list attribute (Source_Files or
84 -- Source_List_File). Used to check that all referenced files were indeed
85 -- found on the disk.
86
87 type Unit_Exception is record
88 Name : Name_Id;
89 -- Key is duplicated, so that it is known when using functions Get_First
90 -- and Get_Next, as these functions only return an Element.
91
92 Spec : File_Name_Type;
93 Impl : File_Name_Type;
94 end record;
95
96 No_Unit_Exception : constant Unit_Exception := (No_Name, No_File, No_File);
97
98 package Unit_Exceptions_Htable is new GNAT.Dynamic_HTables.Simple_HTable
99 (Header_Num => Header_Num,
100 Element => Unit_Exception,
101 No_Element => No_Unit_Exception,
102 Key => Name_Id,
103 Hash => Hash,
104 Equal => "=");
105 -- Record special naming schemes for Ada units (name of spec file and name
106 -- of implementation file). The elements in this list come from the naming
107 -- exceptions specified in the project files.
108
109 type File_Found is record
110 File : File_Name_Type := No_File;
111 Excl_File : File_Name_Type := No_File;
112 Excl_Line : Natural := 0;
113 Found : Boolean := False;
114 Location : Source_Ptr := No_Location;
115 end record;
116
117 No_File_Found : constant File_Found :=
118 (No_File, No_File, 0, False, No_Location);
119
120 package Excluded_Sources_Htable is new GNAT.Dynamic_HTables.Simple_HTable
121 (Header_Num => Header_Num,
122 Element => File_Found,
123 No_Element => No_File_Found,
124 Key => File_Name_Type,
125 Hash => Hash,
126 Equal => "=");
127 -- A hash table to store the base names of excluded files, if any
128
129 package Object_File_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
130 (Header_Num => Header_Num,
131 Element => Source_Id,
132 No_Element => No_Source,
133 Key => File_Name_Type,
134 Hash => Hash,
135 Equal => "=");
136 -- A hash table to store the object file names for a project, to check that
137 -- two different sources have different object file names.
138
139 type Project_Processing_Data is record
140 Project : Project_Id;
141 Source_Names : Source_Names_Htable.Instance;
142 Unit_Exceptions : Unit_Exceptions_Htable.Instance;
143 Excluded : Excluded_Sources_Htable.Instance;
144
145 Source_List_File_Location : Source_Ptr;
146 -- Location of the Source_List_File attribute, for error messages
147 end record;
148 -- This is similar to Tree_Processing_Data, but contains project-specific
149 -- information which is only useful while processing the project, and can
150 -- be discarded as soon as we have finished processing the project
151
152 type Tree_Processing_Data is record
153 Tree : Project_Tree_Ref;
154 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
155 Flags : Prj.Processing_Flags;
156 In_Aggregate_Lib : Boolean;
157 end record;
158 -- Temporary data which is needed while parsing a project. It does not need
159 -- to be kept in memory once a project has been fully loaded, but is
160 -- necessary while performing consistency checks (duplicate sources,...)
161 -- This data must be initialized before processing any project, and the
162 -- same data is used for processing all projects in the tree.
163
164 type Lib_Data is record
165 Name : Name_Id;
166 Proj : Project_Id;
167 Tree : Project_Tree_Ref;
168 end record;
169
170 package Lib_Data_Table is new GNAT.Table
171 (Table_Component_Type => Lib_Data,
172 Table_Index_Type => Natural,
173 Table_Low_Bound => 1,
174 Table_Initial => 10,
175 Table_Increment => 100);
176 -- A table to record library names in order to check that two library
177 -- projects do not have the same library names.
178
179 procedure Initialize
180 (Data : out Tree_Processing_Data;
181 Tree : Project_Tree_Ref;
182 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
183 Flags : Prj.Processing_Flags);
184 -- Initialize Data
185
186 procedure Free (Data : in out Tree_Processing_Data);
187 -- Free the memory occupied by Data
188
189 procedure Initialize
190 (Data : in out Project_Processing_Data;
191 Project : Project_Id);
192 procedure Free (Data : in out Project_Processing_Data);
193 -- Initialize or free memory for a project-specific data
194
195 procedure Find_Excluded_Sources
196 (Project : in out Project_Processing_Data;
197 Data : in out Tree_Processing_Data);
198 -- Find the list of files that should not be considered as source files
199 -- for this project. Sets the list in the Project.Excluded_Sources_Htable.
200
201 procedure Override_Kind (Source : Source_Id; Kind : Source_Kind);
202 -- Override the reference kind for a source file. This properly updates
203 -- the unit data if necessary.
204
205 procedure Load_Naming_Exceptions
206 (Project : in out Project_Processing_Data;
207 Data : in out Tree_Processing_Data);
208 -- All source files in Data.First_Source are considered as naming
209 -- exceptions, and copied into the Source_Names and Unit_Exceptions tables
210 -- as appropriate.
211
212 type Search_Type is (Search_Files, Search_Directories);
213
214 generic
215 with procedure Callback
216 (Path : Path_Information;
217 Pattern_Index : Natural);
218 procedure Expand_Subdirectory_Pattern
219 (Project : Project_Id;
220 Data : in out Tree_Processing_Data;
221 Patterns : String_List_Id;
222 Ignore : String_List_Id;
223 Search_For : Search_Type;
224 Resolve_Links : Boolean);
225 -- Search the subdirectories of Project's directory for files or
226 -- directories that match the globbing patterns found in Patterns (for
227 -- instance "**/*.adb"). Typically, Patterns will be the value of the
228 -- Source_Dirs or Excluded_Source_Dirs attributes.
229 --
230 -- Every time such a file or directory is found, the callback is called.
231 -- Resolve_Links indicates whether we should resolve links while
232 -- normalizing names.
233 --
234 -- In the callback, Pattern_Index is the index within Patterns where the
235 -- expanded pattern was found (1 for the first element of Patterns and
236 -- all its matching directories, then 2,...).
237 --
238 -- We use a generic and not an access-to-subprogram because in some cases
239 -- this code is compiled with the restriction No_Implicit_Dynamic_Code.
240 -- An error message is raised if a pattern does not match any file.
241
242 procedure Add_Source
243 (Id : out Source_Id;
244 Data : in out Tree_Processing_Data;
245 Project : Project_Id;
246 Source_Dir_Rank : Natural;
247 Lang_Id : Language_Ptr;
248 Kind : Source_Kind;
249 File_Name : File_Name_Type;
250 Display_File : File_Name_Type;
251 Naming_Exception : Naming_Exception_Type := No;
252 Path : Path_Information := No_Path_Information;
253 Alternate_Languages : Language_List := null;
254 Unit : Name_Id := No_Name;
255 Index : Int := 0;
256 Locally_Removed : Boolean := False;
257 Location : Source_Ptr := No_Location);
258 -- Add a new source to the different lists: list of all sources in the
259 -- project tree, list of source of a project and list of sources of a
260 -- language. If Path is specified, the file is also added to
261 -- Source_Paths_HT. Location is used for error messages
262
263 function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type;
264 -- Same as Osint.Canonical_Case_File_Name but applies to Name_Id.
265 -- This alters Name_Buffer.
266
267 function Suffix_Matches
268 (Filename : String;
269 Suffix : File_Name_Type) return Boolean;
270 -- True if the file name ends with the given suffix. Always returns False
271 -- if Suffix is No_Name.
272
273 procedure Replace_Into_Name_Buffer
274 (Str : String;
275 Pattern : String;
276 Replacement : Character);
277 -- Copy Str into Name_Buffer, replacing Pattern with Replacement. Str is
278 -- converted to lower-case at the same time.
279
280 procedure Check_Abstract_Project
281 (Project : Project_Id;
282 Data : in out Tree_Processing_Data);
283 -- Check abstract projects attributes
284
285 procedure Check_Configuration
286 (Project : Project_Id;
287 Data : in out Tree_Processing_Data);
288 -- Check the configuration attributes for the project
289
290 procedure Check_If_Externally_Built
291 (Project : Project_Id;
292 Data : in out Tree_Processing_Data);
293 -- Check attribute Externally_Built of project Project in project tree
294 -- Data.Tree and modify its data Data if it has the value "true".
295
296 procedure Check_Interfaces
297 (Project : Project_Id;
298 Data : in out Tree_Processing_Data);
299 -- If a list of sources is specified in attribute Interfaces, set
300 -- In_Interfaces only for the sources specified in the list.
301
302 procedure Check_Library_Attributes
303 (Project : Project_Id;
304 Data : in out Tree_Processing_Data);
305 -- Check the library attributes of project Project in project tree
306 -- and modify its data Data accordingly.
307
308 procedure Check_Package_Naming
309 (Project : Project_Id;
310 Data : in out Tree_Processing_Data);
311 -- Check the naming scheme part of Data, and initialize the naming scheme
312 -- data in the config of the various languages.
313
314 procedure Check_Programming_Languages
315 (Project : Project_Id;
316 Data : in out Tree_Processing_Data);
317 -- Check attribute Languages for the project with data Data in project
318 -- tree Data.Tree and set the components of Data for all the programming
319 -- languages indicated in attribute Languages, if any.
320
321 procedure Check_Stand_Alone_Library
322 (Project : Project_Id;
323 Data : in out Tree_Processing_Data);
324 -- Check if project Project in project tree Data.Tree is a Stand-Alone
325 -- Library project, and modify its data Data accordingly if it is one.
326
327 procedure Check_Unit_Name (Name : String; Unit : out Name_Id);
328 -- Check that a name is a valid unit name
329
330 function Compute_Directory_Last (Dir : String) return Natural;
331 -- Return the index of the last significant character in Dir. This is used
332 -- to avoid duplicate '/' (slash) characters at the end of directory names.
333
334 procedure Search_Directories
335 (Project : in out Project_Processing_Data;
336 Data : in out Tree_Processing_Data;
337 For_All_Sources : Boolean);
338 -- Search the source directories to find the sources. If For_All_Sources is
339 -- True, check each regular file name against the naming schemes of the
340 -- various languages. Otherwise consider only the file names in hash table
341 -- Source_Names. If Allow_Duplicate_Basenames then files with identical
342 -- base names are permitted within a project for source-based languages
343 -- (never for unit based languages).
344
345 procedure Check_File
346 (Project : in out Project_Processing_Data;
347 Data : in out Tree_Processing_Data;
348 Source_Dir_Rank : Natural;
349 Path : Path_Name_Type;
350 Display_Path : Path_Name_Type;
351 File_Name : File_Name_Type;
352 Display_File_Name : File_Name_Type;
353 Locally_Removed : Boolean;
354 For_All_Sources : Boolean);
355 -- Check if file File_Name is a valid source of the project. This is used
356 -- in multi-language mode only. When the file matches one of the naming
357 -- schemes, it is added to various htables through Add_Source and to
358 -- Source_Paths_Htable.
359 --
360 -- File_Name is the same as Display_File_Name, but has been normalized.
361 -- They do not include the directory information.
362 --
363 -- Path and Display_Path on the other hand are the full path to the file.
364 -- Path must have been normalized (canonical casing and possibly links
365 -- resolved).
366 --
367 -- Source_Directory is the directory in which the file was found. It is
368 -- neither normalized nor has had links resolved, and must not end with a
369 -- a directory separator, to avoid duplicates later on.
370 --
371 -- If For_All_Sources is True, then all possible file names are analyzed
372 -- otherwise only those currently set in the Source_Names hash table.
373
374 procedure Check_File_Naming_Schemes
375 (Project : Project_Processing_Data;
376 File_Name : File_Name_Type;
377 Alternate_Languages : out Language_List;
378 Language : out Language_Ptr;
379 Display_Language_Name : out Name_Id;
380 Unit : out Name_Id;
381 Lang_Kind : out Language_Kind;
382 Kind : out Source_Kind);
383 -- Check if the file name File_Name conforms to one of the naming schemes
384 -- of the project. If the file does not match one of the naming schemes,
385 -- set Language to No_Language_Index. Filename is the name of the file
386 -- being investigated. It has been normalized (case-folded). File_Name is
387 -- the same value.
388
389 procedure Get_Directories
390 (Project : Project_Id;
391 Data : in out Tree_Processing_Data);
392 -- Get the object directory, the exec directory and the source directories
393 -- of a project.
394
395 procedure Get_Mains
396 (Project : Project_Id;
397 Data : in out Tree_Processing_Data);
398 -- Get the mains of a project from attribute Main, if it exists, and put
399 -- them in the project data.
400
401 procedure Get_Sources_From_File
402 (Path : String;
403 Location : Source_Ptr;
404 Project : in out Project_Processing_Data;
405 Data : in out Tree_Processing_Data);
406 -- Get the list of sources from a text file and put them in hash table
407 -- Source_Names.
408
409 procedure Find_Sources
410 (Project : in out Project_Processing_Data;
411 Data : in out Tree_Processing_Data);
412 -- Process the Source_Files and Source_List_File attributes, and store the
413 -- list of source files into the Source_Names htable. When these attributes
414 -- are not defined, find all files matching the naming schemes in the
415 -- source directories. If Allow_Duplicate_Basenames, then files with the
416 -- same base names are authorized within a project for source-based
417 -- languages (never for unit based languages)
418
419 procedure Compute_Unit_Name
420 (File_Name : File_Name_Type;
421 Naming : Lang_Naming_Data;
422 Kind : out Source_Kind;
423 Unit : out Name_Id;
424 Project : Project_Processing_Data);
425 -- Check whether the file matches the naming scheme. If it does,
426 -- compute its unit name. If Unit is set to No_Name on exit, none of the
427 -- other out parameters are relevant.
428
429 procedure Check_Illegal_Suffix
430 (Project : Project_Id;
431 Suffix : File_Name_Type;
432 Dot_Replacement : File_Name_Type;
433 Attribute_Name : String;
434 Location : Source_Ptr;
435 Data : in out Tree_Processing_Data);
436 -- Display an error message if the given suffix is illegal for some reason.
437 -- The name of the attribute we are testing is specified in Attribute_Name,
438 -- which is used in the error message. Location is the location where the
439 -- suffix is defined.
440
441 procedure Locate_Directory
442 (Project : Project_Id;
443 Name : File_Name_Type;
444 Path : out Path_Information;
445 Dir_Exists : out Boolean;
446 Data : in out Tree_Processing_Data;
447 Create : String := "";
448 Location : Source_Ptr := No_Location;
449 Must_Exist : Boolean := True;
450 Externally_Built : Boolean := False);
451 -- Locate a directory. Name is the directory name. Relative paths are
452 -- resolved relative to the project's directory. If the directory does not
453 -- exist and Setup_Projects is True and Create is a non null string, an
454 -- attempt is made to create the directory. If the directory does not
455 -- exist, it is either created if Setup_Projects is False (and then
456 -- returned), or simply returned without checking for its existence (if
457 -- Must_Exist is False) or No_Path_Information is returned. In all cases,
458 -- Dir_Exists indicates whether the directory now exists. Create is also
459 -- used for debugging traces to show which path we are computing.
460
461 procedure Look_For_Sources
462 (Project : in out Project_Processing_Data;
463 Data : in out Tree_Processing_Data);
464 -- Find all the sources of project Project in project tree Data.Tree and
465 -- update its Data accordingly. This assumes that the special naming
466 -- exceptions have already been processed.
467
468 function Path_Name_Of
469 (File_Name : File_Name_Type;
470 Directory : Path_Name_Type) return String;
471 -- Returns the path name of a (non project) file. Returns an empty string
472 -- if file cannot be found.
473
474 procedure Remove_Source
475 (Tree : Project_Tree_Ref;
476 Id : Source_Id;
477 Replaced_By : Source_Id);
478 -- Remove a file from the list of sources of a project. This might be
479 -- because the file is replaced by another one in an extending project,
480 -- or because a file was added as a naming exception but was not found
481 -- in the end.
482
483 procedure Report_No_Sources
484 (Project : Project_Id;
485 Lang_Name : String;
486 Data : Tree_Processing_Data;
487 Location : Source_Ptr;
488 Continuation : Boolean := False);
489 -- Report an error or a warning depending on the value of When_No_Sources
490 -- when there are no sources for language Lang_Name.
491
492 procedure Show_Source_Dirs
493 (Project : Project_Id;
494 Shared : Shared_Project_Tree_Data_Access);
495 -- List all the source directories of a project
496
497 procedure Write_Attr (Name, Value : String);
498 -- Debug print a value for a specific property. Does nothing when not in
499 -- debug mode
500
501 procedure Error_Or_Warning
502 (Flags : Processing_Flags;
503 Kind : Error_Warning;
504 Msg : String;
505 Location : Source_Ptr;
506 Project : Project_Id);
507 -- Emits either an error or warning message (or nothing), depending on Kind
508
509 function No_Space_Img (N : Natural) return String;
510 -- Image of a Natural without the initial space
511
512 ----------------------
513 -- Error_Or_Warning --
514 ----------------------
515
516 procedure Error_Or_Warning
517 (Flags : Processing_Flags;
518 Kind : Error_Warning;
519 Msg : String;
520 Location : Source_Ptr;
521 Project : Project_Id) is
522 begin
523 case Kind is
524 when Error => Error_Msg (Flags, Msg, Location, Project);
525 when Warning => Error_Msg (Flags, "?" & Msg, Location, Project);
526 when Silent => null;
527 end case;
528 end Error_Or_Warning;
529
530 ------------------------------
531 -- Replace_Into_Name_Buffer --
532 ------------------------------
533
534 procedure Replace_Into_Name_Buffer
535 (Str : String;
536 Pattern : String;
537 Replacement : Character)
538 is
539 Max : constant Integer := Str'Last - Pattern'Length + 1;
540 J : Positive;
541
542 begin
543 Name_Len := 0;
544
545 J := Str'First;
546 while J <= Str'Last loop
547 Name_Len := Name_Len + 1;
548
549 if J <= Max and then Str (J .. J + Pattern'Length - 1) = Pattern then
550 Name_Buffer (Name_Len) := Replacement;
551 J := J + Pattern'Length;
552 else
553 Name_Buffer (Name_Len) := GNAT.Case_Util.To_Lower (Str (J));
554 J := J + 1;
555 end if;
556 end loop;
557 end Replace_Into_Name_Buffer;
558
559 --------------------
560 -- Suffix_Matches --
561 --------------------
562
563 function Suffix_Matches
564 (Filename : String;
565 Suffix : File_Name_Type) return Boolean
566 is
567 Min_Prefix_Length : Natural := 0;
568
569 begin
570 if Suffix = No_File or else Suffix = Empty_File then
571 return False;
572 end if;
573
574 declare
575 Suf : String := Get_Name_String (Suffix);
576
577 begin
578 -- On non case-sensitive systems, use proper suffix casing
579
580 Canonical_Case_File_Name (Suf);
581
582 -- The file name must end with the suffix (which is not an extension)
583 -- For instance a suffix "configure.in" must match a file with the
584 -- same name. To avoid dummy cases, though, a suffix starting with
585 -- '.' requires a file that is at least one character longer ('.cpp'
586 -- should not match a file with the same name).
587
588 if Suf (Suf'First) = '.' then
589 Min_Prefix_Length := 1;
590 end if;
591
592 return Filename'Length >= Suf'Length + Min_Prefix_Length
593 and then
594 Filename (Filename'Last - Suf'Length + 1 .. Filename'Last) = Suf;
595 end;
596 end Suffix_Matches;
597
598 ----------------
599 -- Write_Attr --
600 ----------------
601
602 procedure Write_Attr (Name, Value : String) is
603 begin
604 if Current_Verbosity = High then
605 Debug_Output (Name & " = """ & Value & '"');
606 end if;
607 end Write_Attr;
608
609 ----------------
610 -- Add_Source --
611 ----------------
612
613 procedure Add_Source
614 (Id : out Source_Id;
615 Data : in out Tree_Processing_Data;
616 Project : Project_Id;
617 Source_Dir_Rank : Natural;
618 Lang_Id : Language_Ptr;
619 Kind : Source_Kind;
620 File_Name : File_Name_Type;
621 Display_File : File_Name_Type;
622 Naming_Exception : Naming_Exception_Type := No;
623 Path : Path_Information := No_Path_Information;
624 Alternate_Languages : Language_List := null;
625 Unit : Name_Id := No_Name;
626 Index : Int := 0;
627 Locally_Removed : Boolean := False;
628 Location : Source_Ptr := No_Location)
629 is
630 Config : constant Language_Config := Lang_Id.Config;
631 UData : Unit_Index;
632 Add_Src : Boolean;
633 Source : Source_Id;
634 Prev_Unit : Unit_Index := No_Unit_Index;
635 Source_To_Replace : Source_Id := No_Source;
636
637 begin
638 -- Check if the same file name or unit is used in the prj tree
639
640 Add_Src := True;
641
642 if Unit /= No_Name then
643 Prev_Unit := Units_Htable.Get (Data.Tree.Units_HT, Unit);
644 end if;
645
646 if Prev_Unit /= No_Unit_Index
647 and then (Kind = Impl or else Kind = Spec)
648 and then Prev_Unit.File_Names (Kind) /= null
649 then
650 -- Suspicious, we need to check later whether this is authorized
651
652 Add_Src := False;
653 Source := Prev_Unit.File_Names (Kind);
654
655 else
656 Source := Source_Files_Htable.Get
657 (Data.Tree.Source_Files_HT, File_Name);
658
659 if Source /= No_Source and then Source.Index = Index then
660 Add_Src := False;
661 end if;
662 end if;
663
664 -- Always add the source if it is locally removed, to avoid incorrect
665 -- duplicate checks.
666
667 if Locally_Removed then
668 Add_Src := True;
669
670 -- A locally removed source may first replace a source in a project
671 -- being extended.
672
673 if Source /= No_Source
674 and then Is_Extending (Project, Source.Project)
675 and then Naming_Exception /= Inherited
676 then
677 Source_To_Replace := Source;
678 end if;
679
680 else
681 -- Duplication of file/unit in same project is allowed if order of
682 -- source directories is known, or if there is no compiler for the
683 -- language.
684
685 if Add_Src = False then
686 Add_Src := True;
687
688 if Project = Source.Project then
689 if Prev_Unit = No_Unit_Index then
690 if Data.Flags.Allow_Duplicate_Basenames then
691 Add_Src := True;
692
693 elsif Lang_Id.Config.Compiler_Driver = Empty_File then
694 Add_Src := True;
695
696 elsif Source_Dir_Rank /= Source.Source_Dir_Rank then
697 Add_Src := False;
698
699 else
700 Error_Msg_File_1 := File_Name;
701 Error_Msg
702 (Data.Flags, "duplicate source file name {",
703 Location, Project);
704 Add_Src := False;
705 end if;
706
707 else
708 if Source_Dir_Rank /= Source.Source_Dir_Rank then
709 Add_Src := False;
710
711 -- We might be seeing the same file through a different
712 -- path (for instance because of symbolic links).
713
714 elsif Source.Path.Name /= Path.Name then
715 if not Source.Duplicate_Unit then
716 Error_Msg_Name_1 := Unit;
717 Error_Msg
718 (Data.Flags,
719 "\duplicate unit %%",
720 Location,
721 Project);
722 Source.Duplicate_Unit := True;
723 end if;
724
725 Add_Src := False;
726 end if;
727 end if;
728
729 -- Do not allow the same unit name in different projects,
730 -- except if one is extending the other.
731
732 -- For a file based language, the same file name replaces a
733 -- file in a project being extended, but it is allowed to have
734 -- the same file name in unrelated projects.
735
736 elsif Is_Extending (Project, Source.Project) then
737 if not Locally_Removed and then Naming_Exception /= Inherited
738 then
739 Source_To_Replace := Source;
740 end if;
741
742 elsif Prev_Unit /= No_Unit_Index
743 and then Prev_Unit.File_Names (Kind) /= null
744 and then not Source.Locally_Removed
745 and then Source.Replaced_By = No_Source
746 and then not Data.In_Aggregate_Lib
747 then
748 -- Path is set if this is a source we found on the disk, in
749 -- which case we can provide more explicit error message. Path
750 -- is unset when the source is added from one of the naming
751 -- exceptions in the project.
752
753 if Path /= No_Path_Information then
754 Error_Msg_Name_1 := Unit;
755 Error_Msg
756 (Data.Flags,
757 "unit %% cannot belong to several projects",
758 Location, Project);
759
760 Error_Msg_Name_1 := Project.Name;
761 Error_Msg_Name_2 := Name_Id (Path.Display_Name);
762 Error_Msg
763 (Data.Flags, "\ project %%, %%", Location, Project);
764
765 Error_Msg_Name_1 := Source.Project.Name;
766 Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name);
767 Error_Msg
768 (Data.Flags, "\ project %%, %%", Location, Project);
769
770 else
771 Error_Msg_Name_1 := Unit;
772 Error_Msg_Name_2 := Source.Project.Name;
773 Error_Msg
774 (Data.Flags, "unit %% already belongs to project %%",
775 Location, Project);
776 end if;
777
778 Add_Src := False;
779
780 elsif not Source.Locally_Removed
781 and then Source.Replaced_By /= No_Source
782 and then not Data.Flags.Allow_Duplicate_Basenames
783 and then Lang_Id.Config.Kind = Unit_Based
784 and then Source.Language.Config.Kind = Unit_Based
785 and then not Data.In_Aggregate_Lib
786 then
787 Error_Msg_File_1 := File_Name;
788 Error_Msg_File_2 := File_Name_Type (Source.Project.Name);
789 Error_Msg
790 (Data.Flags,
791 "{ is already a source of project {", Location, Project);
792
793 -- Add the file anyway, to avoid further warnings like
794 -- "language unknown".
795
796 Add_Src := True;
797 end if;
798 end if;
799 end if;
800
801 if not Add_Src then
802 return;
803 end if;
804
805 -- Add the new file
806
807 Id := new Source_Data;
808
809 if Current_Verbosity = High then
810 Debug_Indent;
811 Write_Str ("adding source File: ");
812 Write_Str (Get_Name_String (Display_File));
813
814 if Index /= 0 then
815 Write_Str (" at" & Index'Img);
816 end if;
817
818 if Lang_Id.Config.Kind = Unit_Based then
819 Write_Str (" Unit: ");
820
821 -- ??? in gprclean, it seems we sometimes pass an empty Unit name
822 -- (see test extended_projects).
823
824 if Unit /= No_Name then
825 Write_Str (Get_Name_String (Unit));
826 end if;
827
828 Write_Str (" Kind: ");
829 Write_Str (Source_Kind'Image (Kind));
830 end if;
831
832 Write_Eol;
833 end if;
834
835 Id.Project := Project;
836 Id.Location := Location;
837 Id.Source_Dir_Rank := Source_Dir_Rank;
838 Id.Language := Lang_Id;
839 Id.Kind := Kind;
840 Id.Alternate_Languages := Alternate_Languages;
841 Id.Locally_Removed := Locally_Removed;
842 Id.Index := Index;
843 Id.File := File_Name;
844 Id.Display_File := Display_File;
845 Id.Dep_Name := Dependency_Name
846 (File_Name, Lang_Id.Config.Dependency_Kind);
847 Id.Naming_Exception := Naming_Exception;
848 Id.Object := Object_Name
849 (File_Name, Config.Object_File_Suffix);
850 Id.Switches := Switches_Name (File_Name);
851
852 -- Add the source id to the Unit_Sources_HT hash table, if the unit name
853 -- is not null.
854
855 if Unit /= No_Name then
856
857 -- Note: we might be creating a dummy unit here, when we in fact have
858 -- a separate. For instance, file file-bar.adb will initially be
859 -- assumed to be the IMPL of unit "file.bar". Only later on (in
860 -- Check_Object_Files) will we parse those units that only have an
861 -- impl and no spec to make sure whether we have a Separate in fact
862 -- (that significantly reduces the number of times we need to parse
863 -- the files, since we are then only interested in those with no
864 -- spec). We still need those dummy units in the table, since that's
865 -- the name we find in the ALI file
866
867 UData := Units_Htable.Get (Data.Tree.Units_HT, Unit);
868
869 if UData = No_Unit_Index then
870 UData := new Unit_Data;
871 UData.Name := Unit;
872
873 if Naming_Exception /= Inherited then
874 Units_Htable.Set (Data.Tree.Units_HT, Unit, UData);
875 end if;
876 end if;
877
878 Id.Unit := UData;
879
880 -- Note that this updates Unit information as well
881
882 if Naming_Exception /= Inherited and then not Locally_Removed then
883 Override_Kind (Id, Kind);
884 end if;
885 end if;
886
887 if Path /= No_Path_Information then
888 Id.Path := Path;
889 Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path.Name, Id);
890 end if;
891
892 Id.Next_With_File_Name :=
893 Source_Files_Htable.Get (Data.Tree.Source_Files_HT, File_Name);
894 Source_Files_Htable.Set (Data.Tree.Source_Files_HT, File_Name, Id);
895
896 if Index /= 0 then
897 Project.Has_Multi_Unit_Sources := True;
898 end if;
899
900 -- Add the source to the language list
901
902 Id.Next_In_Lang := Lang_Id.First_Source;
903 Lang_Id.First_Source := Id;
904
905 if Source_To_Replace /= No_Source then
906 Remove_Source (Data.Tree, Source_To_Replace, Id);
907 end if;
908
909 if Data.Tree.Replaced_Source_Number > 0
910 and then
911 Replaced_Source_HTable.Get
912 (Data.Tree.Replaced_Sources, Id.File) /= No_File
913 then
914 Replaced_Source_HTable.Remove (Data.Tree.Replaced_Sources, Id.File);
915 Data.Tree.Replaced_Source_Number :=
916 Data.Tree.Replaced_Source_Number - 1;
917 end if;
918 end Add_Source;
919
920 ------------------------------
921 -- Canonical_Case_File_Name --
922 ------------------------------
923
924 function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type is
925 begin
926 if Osint.File_Names_Case_Sensitive then
927 return File_Name_Type (Name);
928 else
929 Get_Name_String (Name);
930 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
931 return Name_Find;
932 end if;
933 end Canonical_Case_File_Name;
934
935 ---------------------------------
936 -- Process_Aggregated_Projects --
937 ---------------------------------
938
939 procedure Process_Aggregated_Projects
940 (Tree : Project_Tree_Ref;
941 Project : Project_Id;
942 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
943 Flags : Processing_Flags)
944 is
945 Data : Tree_Processing_Data :=
946 (Tree => Tree,
947 Node_Tree => Node_Tree,
948 Flags => Flags,
949 In_Aggregate_Lib => False);
950
951 Project_Files : constant Prj.Variable_Value :=
952 Prj.Util.Value_Of
953 (Snames.Name_Project_Files,
954 Project.Decl.Attributes,
955 Tree.Shared);
956
957 Project_Path_For_Aggregate : Prj.Env.Project_Search_Path;
958
959 procedure Found_Project_File (Path : Path_Information; Rank : Natural);
960 -- Called for each project file aggregated by Project
961
962 procedure Expand_Project_Files is
963 new Expand_Subdirectory_Pattern (Callback => Found_Project_File);
964 -- Search for all project files referenced by the patterns given in
965 -- parameter. Calls Found_Project_File for each of them.
966
967 ------------------------
968 -- Found_Project_File --
969 ------------------------
970
971 procedure Found_Project_File (Path : Path_Information; Rank : Natural) is
972 pragma Unreferenced (Rank);
973
974 begin
975 if Path.Name /= Project.Path.Name then
976 Debug_Output ("aggregates: ", Name_Id (Path.Display_Name));
977
978 -- For usual "with" statement, this phase will have been done when
979 -- parsing the project itself. However, for aggregate projects, we
980 -- can only do this when processing the aggregate project, since
981 -- the exact list of project files or project directories can
982 -- depend on scenario variables.
983 --
984 -- We only load the projects explicitly here, but do not process
985 -- them. For the processing, Prj.Proc will take care of processing
986 -- them, within the same call to Recursive_Process (thus avoiding
987 -- the processing of a given project multiple times).
988 --
989 -- ??? We might already have loaded the project
990
991 Add_Aggregated_Project (Project, Path => Path.Name);
992
993 else
994 Debug_Output ("pattern returned the aggregate itself, ignored");
995 end if;
996 end Found_Project_File;
997
998 -- Start of processing for Check_Aggregate_Project
999
1000 begin
1001 pragma Assert (Project.Qualifier in Aggregate_Project);
1002
1003 if Project_Files.Default then
1004 Error_Msg_Name_1 := Snames.Name_Project_Files;
1005 Error_Msg
1006 (Flags,
1007 "Attribute %% must be specified in aggregate project",
1008 Project.Location, Project);
1009 return;
1010 end if;
1011
1012 -- The aggregated projects are only searched relative to the directory
1013 -- of the aggregate project, not in the default project path.
1014
1015 Initialize_Empty (Project_Path_For_Aggregate);
1016
1017 Free (Project.Aggregated_Projects);
1018
1019 -- Look for aggregated projects. For similarity with source files and
1020 -- dirs, the aggregated project files are not searched for on the
1021 -- project path, and are only found through the path specified in
1022 -- the Project_Files attribute.
1023
1024 Expand_Project_Files
1025 (Project => Project,
1026 Data => Data,
1027 Patterns => Project_Files.Values,
1028 Ignore => Nil_String,
1029 Search_For => Search_Files,
1030 Resolve_Links => Opt.Follow_Links_For_Files);
1031
1032 Free (Project_Path_For_Aggregate);
1033 end Process_Aggregated_Projects;
1034
1035 ----------------------------
1036 -- Check_Abstract_Project --
1037 ----------------------------
1038
1039 procedure Check_Abstract_Project
1040 (Project : Project_Id;
1041 Data : in out Tree_Processing_Data)
1042 is
1043 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
1044
1045 Source_Dirs : constant Variable_Value :=
1046 Util.Value_Of
1047 (Name_Source_Dirs,
1048 Project.Decl.Attributes, Shared);
1049 Source_Files : constant Variable_Value :=
1050 Util.Value_Of
1051 (Name_Source_Files,
1052 Project.Decl.Attributes, Shared);
1053 Source_List_File : constant Variable_Value :=
1054 Util.Value_Of
1055 (Name_Source_List_File,
1056 Project.Decl.Attributes, Shared);
1057 Languages : constant Variable_Value :=
1058 Util.Value_Of
1059 (Name_Languages,
1060 Project.Decl.Attributes, Shared);
1061
1062 begin
1063 if Project.Source_Dirs /= Nil_String then
1064 if Source_Dirs.Values = Nil_String
1065 and then Source_Files.Values = Nil_String
1066 and then Languages.Values = Nil_String
1067 and then Source_List_File.Default
1068 then
1069 Project.Source_Dirs := Nil_String;
1070
1071 else
1072 Error_Msg
1073 (Data.Flags,
1074 "at least one of Source_Files, Source_Dirs or Languages "
1075 & "must be declared empty for an abstract project",
1076 Project.Location, Project);
1077 end if;
1078 end if;
1079 end Check_Abstract_Project;
1080
1081 -------------------------
1082 -- Check_Configuration --
1083 -------------------------
1084
1085 procedure Check_Configuration
1086 (Project : Project_Id;
1087 Data : in out Tree_Processing_Data)
1088 is
1089 Shared : constant Shared_Project_Tree_Data_Access :=
1090 Data.Tree.Shared;
1091
1092 Dot_Replacement : File_Name_Type := No_File;
1093 Casing : Casing_Type := All_Lower_Case;
1094 Separate_Suffix : File_Name_Type := No_File;
1095
1096 Lang_Index : Language_Ptr := No_Language_Index;
1097 -- The index of the language data being checked
1098
1099 Prev_Index : Language_Ptr := No_Language_Index;
1100 -- The index of the previous language
1101
1102 procedure Process_Project_Level_Simple_Attributes;
1103 -- Process the simple attributes at the project level
1104
1105 procedure Process_Project_Level_Array_Attributes;
1106 -- Process the associate array attributes at the project level
1107
1108 procedure Process_Packages;
1109 -- Read the packages of the project
1110
1111 ----------------------
1112 -- Process_Packages --
1113 ----------------------
1114
1115 procedure Process_Packages is
1116 Packages : Package_Id;
1117 Element : Package_Element;
1118
1119 procedure Process_Binder (Arrays : Array_Id);
1120 -- Process the associated array attributes of package Binder
1121
1122 procedure Process_Builder (Attributes : Variable_Id);
1123 -- Process the simple attributes of package Builder
1124
1125 procedure Process_Clean (Attributes : Variable_Id);
1126 -- Process the simple attributes of package Clean
1127
1128 procedure Process_Clean (Arrays : Array_Id);
1129 -- Process the associated array attributes of package Clean
1130
1131 procedure Process_Compiler (Arrays : Array_Id);
1132 -- Process the associated array attributes of package Compiler
1133
1134 procedure Process_Naming (Attributes : Variable_Id);
1135 -- Process the simple attributes of package Naming
1136
1137 procedure Process_Naming (Arrays : Array_Id);
1138 -- Process the associated array attributes of package Naming
1139
1140 procedure Process_Linker (Attributes : Variable_Id);
1141 -- Process the simple attributes of package Linker of a
1142 -- configuration project.
1143
1144 --------------------
1145 -- Process_Binder --
1146 --------------------
1147
1148 procedure Process_Binder (Arrays : Array_Id) is
1149 Current_Array_Id : Array_Id;
1150 Current_Array : Array_Data;
1151 Element_Id : Array_Element_Id;
1152 Element : Array_Element;
1153
1154 begin
1155 -- Process the associative array attribute of package Binder
1156
1157 Current_Array_Id := Arrays;
1158 while Current_Array_Id /= No_Array loop
1159 Current_Array := Shared.Arrays.Table (Current_Array_Id);
1160
1161 Element_Id := Current_Array.Value;
1162 while Element_Id /= No_Array_Element loop
1163 Element := Shared.Array_Elements.Table (Element_Id);
1164
1165 if Element.Index /= All_Other_Names then
1166
1167 -- Get the name of the language
1168
1169 Lang_Index :=
1170 Get_Language_From_Name
1171 (Project, Get_Name_String (Element.Index));
1172
1173 if Lang_Index /= No_Language_Index then
1174 case Current_Array.Name is
1175 when Name_Driver =>
1176
1177 -- Attribute Driver (<language>)
1178
1179 Lang_Index.Config.Binder_Driver :=
1180 File_Name_Type (Element.Value.Value);
1181
1182 when Name_Required_Switches =>
1183 Put
1184 (Into_List =>
1185 Lang_Index.Config.Binder_Required_Switches,
1186 From_List => Element.Value.Values,
1187 In_Tree => Data.Tree);
1188
1189 when Name_Prefix =>
1190
1191 -- Attribute Prefix (<language>)
1192
1193 Lang_Index.Config.Binder_Prefix :=
1194 Element.Value.Value;
1195
1196 when Name_Objects_Path =>
1197
1198 -- Attribute Objects_Path (<language>)
1199
1200 Lang_Index.Config.Objects_Path :=
1201 Element.Value.Value;
1202
1203 when Name_Objects_Path_File =>
1204
1205 -- Attribute Objects_Path (<language>)
1206
1207 Lang_Index.Config.Objects_Path_File :=
1208 Element.Value.Value;
1209
1210 when others =>
1211 null;
1212 end case;
1213 end if;
1214 end if;
1215
1216 Element_Id := Element.Next;
1217 end loop;
1218
1219 Current_Array_Id := Current_Array.Next;
1220 end loop;
1221 end Process_Binder;
1222
1223 ---------------------
1224 -- Process_Builder --
1225 ---------------------
1226
1227 procedure Process_Builder (Attributes : Variable_Id) is
1228 Attribute_Id : Variable_Id;
1229 Attribute : Variable;
1230
1231 begin
1232 -- Process non associated array attribute from package Builder
1233
1234 Attribute_Id := Attributes;
1235 while Attribute_Id /= No_Variable loop
1236 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
1237
1238 if not Attribute.Value.Default then
1239 if Attribute.Name = Name_Executable_Suffix then
1240
1241 -- Attribute Executable_Suffix: the suffix of the
1242 -- executables.
1243
1244 Project.Config.Executable_Suffix :=
1245 Attribute.Value.Value;
1246 end if;
1247 end if;
1248
1249 Attribute_Id := Attribute.Next;
1250 end loop;
1251 end Process_Builder;
1252
1253 -------------------
1254 -- Process_Clean --
1255 -------------------
1256
1257 procedure Process_Clean (Attributes : Variable_Id) is
1258 Attribute_Id : Variable_Id;
1259 Attribute : Variable;
1260 List : String_List_Id;
1261
1262 begin
1263 -- Process non associated array attributes from package Clean
1264
1265 Attribute_Id := Attributes;
1266 while Attribute_Id /= No_Variable loop
1267 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
1268
1269 if not Attribute.Value.Default then
1270 if Attribute.Name = Name_Artifacts_In_Exec_Dir then
1271
1272 -- Attribute Artifacts_In_Exec_Dir: the list of file
1273 -- names to be cleaned in the exec dir of the main
1274 -- project.
1275
1276 List := Attribute.Value.Values;
1277
1278 if List /= Nil_String then
1279 Put (Into_List =>
1280 Project.Config.Artifacts_In_Exec_Dir,
1281 From_List => List,
1282 In_Tree => Data.Tree);
1283 end if;
1284
1285 elsif Attribute.Name = Name_Artifacts_In_Object_Dir then
1286
1287 -- Attribute Artifacts_In_Exec_Dir: the list of file
1288 -- names to be cleaned in the object dir of every
1289 -- project.
1290
1291 List := Attribute.Value.Values;
1292
1293 if List /= Nil_String then
1294 Put (Into_List =>
1295 Project.Config.Artifacts_In_Object_Dir,
1296 From_List => List,
1297 In_Tree => Data.Tree);
1298 end if;
1299 end if;
1300 end if;
1301
1302 Attribute_Id := Attribute.Next;
1303 end loop;
1304 end Process_Clean;
1305
1306 procedure Process_Clean (Arrays : Array_Id) is
1307 Current_Array_Id : Array_Id;
1308 Current_Array : Array_Data;
1309 Element_Id : Array_Element_Id;
1310 Element : Array_Element;
1311 List : String_List_Id;
1312
1313 begin
1314 -- Process the associated array attributes of package Clean
1315
1316 Current_Array_Id := Arrays;
1317 while Current_Array_Id /= No_Array loop
1318 Current_Array := Shared.Arrays.Table (Current_Array_Id);
1319
1320 Element_Id := Current_Array.Value;
1321 while Element_Id /= No_Array_Element loop
1322 Element := Shared.Array_Elements.Table (Element_Id);
1323
1324 -- Get the name of the language
1325
1326 Lang_Index :=
1327 Get_Language_From_Name
1328 (Project, Get_Name_String (Element.Index));
1329
1330 if Lang_Index /= No_Language_Index then
1331 case Current_Array.Name is
1332
1333 -- Attribute Object_Artifact_Extensions (<language>)
1334
1335 when Name_Object_Artifact_Extensions =>
1336 List := Element.Value.Values;
1337
1338 if List /= Nil_String then
1339 Put (Into_List =>
1340 Lang_Index.Config.Clean_Object_Artifacts,
1341 From_List => List,
1342 In_Tree => Data.Tree);
1343 end if;
1344
1345 -- Attribute Source_Artifact_Extensions (<language>)
1346
1347 when Name_Source_Artifact_Extensions =>
1348 List := Element.Value.Values;
1349
1350 if List /= Nil_String then
1351 Put (Into_List =>
1352 Lang_Index.Config.Clean_Source_Artifacts,
1353 From_List => List,
1354 In_Tree => Data.Tree);
1355 end if;
1356
1357 when others =>
1358 null;
1359 end case;
1360 end if;
1361
1362 Element_Id := Element.Next;
1363 end loop;
1364
1365 Current_Array_Id := Current_Array.Next;
1366 end loop;
1367 end Process_Clean;
1368
1369 ----------------------
1370 -- Process_Compiler --
1371 ----------------------
1372
1373 procedure Process_Compiler (Arrays : Array_Id) is
1374 Current_Array_Id : Array_Id;
1375 Current_Array : Array_Data;
1376 Element_Id : Array_Element_Id;
1377 Element : Array_Element;
1378 List : String_List_Id;
1379
1380 begin
1381 -- Process the associative array attribute of package Compiler
1382
1383 Current_Array_Id := Arrays;
1384 while Current_Array_Id /= No_Array loop
1385 Current_Array := Shared.Arrays.Table (Current_Array_Id);
1386
1387 Element_Id := Current_Array.Value;
1388 while Element_Id /= No_Array_Element loop
1389 Element := Shared.Array_Elements.Table (Element_Id);
1390
1391 if Element.Index /= All_Other_Names then
1392
1393 -- Get the name of the language
1394
1395 Lang_Index := Get_Language_From_Name
1396 (Project, Get_Name_String (Element.Index));
1397
1398 if Lang_Index /= No_Language_Index then
1399 case Current_Array.Name is
1400
1401 -- Attribute Dependency_Kind (<language>)
1402
1403 when Name_Dependency_Kind =>
1404 Get_Name_String (Element.Value.Value);
1405
1406 begin
1407 Lang_Index.Config.Dependency_Kind :=
1408 Dependency_File_Kind'Value
1409 (Name_Buffer (1 .. Name_Len));
1410
1411 exception
1412 when Constraint_Error =>
1413 Error_Msg
1414 (Data.Flags,
1415 "illegal value for Dependency_Kind",
1416 Element.Value.Location,
1417 Project);
1418 end;
1419
1420 -- Attribute Dependency_Switches (<language>)
1421
1422 when Name_Dependency_Switches =>
1423 if Lang_Index.Config.Dependency_Kind = None then
1424 Lang_Index.Config.Dependency_Kind := Makefile;
1425 end if;
1426
1427 List := Element.Value.Values;
1428
1429 if List /= Nil_String then
1430 Put (Into_List =>
1431 Lang_Index.Config.Dependency_Option,
1432 From_List => List,
1433 In_Tree => Data.Tree);
1434 end if;
1435
1436 -- Attribute Dependency_Driver (<language>)
1437
1438 when Name_Dependency_Driver =>
1439 if Lang_Index.Config.Dependency_Kind = None then
1440 Lang_Index.Config.Dependency_Kind := Makefile;
1441 end if;
1442
1443 List := Element.Value.Values;
1444
1445 if List /= Nil_String then
1446 Put (Into_List =>
1447 Lang_Index.Config.Compute_Dependency,
1448 From_List => List,
1449 In_Tree => Data.Tree);
1450 end if;
1451
1452 -- Attribute Language_Kind (<language>)
1453
1454 when Name_Language_Kind =>
1455 Get_Name_String (Element.Value.Value);
1456
1457 begin
1458 Lang_Index.Config.Kind :=
1459 Language_Kind'Value
1460 (Name_Buffer (1 .. Name_Len));
1461
1462 exception
1463 when Constraint_Error =>
1464 Error_Msg
1465 (Data.Flags,
1466 "illegal value for Language_Kind",
1467 Element.Value.Location,
1468 Project);
1469 end;
1470
1471 -- Attribute Include_Switches (<language>)
1472
1473 when Name_Include_Switches =>
1474 List := Element.Value.Values;
1475
1476 if List = Nil_String then
1477 Error_Msg
1478 (Data.Flags, "include option cannot be null",
1479 Element.Value.Location, Project);
1480 end if;
1481
1482 Put (Into_List => Lang_Index.Config.Include_Option,
1483 From_List => List,
1484 In_Tree => Data.Tree);
1485
1486 -- Attribute Include_Path (<language>)
1487
1488 when Name_Include_Path =>
1489 Lang_Index.Config.Include_Path :=
1490 Element.Value.Value;
1491
1492 -- Attribute Include_Path_File (<language>)
1493
1494 when Name_Include_Path_File =>
1495 Lang_Index.Config.Include_Path_File :=
1496 Element.Value.Value;
1497
1498 -- Attribute Driver (<language>)
1499
1500 when Name_Driver =>
1501 Lang_Index.Config.Compiler_Driver :=
1502 File_Name_Type (Element.Value.Value);
1503
1504 when Name_Required_Switches
1505 | Name_Leading_Required_Switches
1506 =>
1507 Put (Into_List =>
1508 Lang_Index.Config.
1509 Compiler_Leading_Required_Switches,
1510 From_List => Element.Value.Values,
1511 In_Tree => Data.Tree);
1512
1513 when Name_Trailing_Required_Switches =>
1514 Put (Into_List =>
1515 Lang_Index.Config.
1516 Compiler_Trailing_Required_Switches,
1517 From_List => Element.Value.Values,
1518 In_Tree => Data.Tree);
1519
1520 when Name_Multi_Unit_Switches =>
1521 Put (Into_List =>
1522 Lang_Index.Config.Multi_Unit_Switches,
1523 From_List => Element.Value.Values,
1524 In_Tree => Data.Tree);
1525
1526 when Name_Multi_Unit_Object_Separator =>
1527 Get_Name_String (Element.Value.Value);
1528
1529 if Name_Len /= 1 then
1530 Error_Msg
1531 (Data.Flags,
1532 "multi-unit object separator must have " &
1533 "a single character",
1534 Element.Value.Location, Project);
1535
1536 elsif Name_Buffer (1) = ' ' then
1537 Error_Msg
1538 (Data.Flags,
1539 "multi-unit object separator cannot be " &
1540 "a space",
1541 Element.Value.Location, Project);
1542
1543 else
1544 Lang_Index.Config.Multi_Unit_Object_Separator :=
1545 Name_Buffer (1);
1546 end if;
1547
1548 when Name_Path_Syntax =>
1549 begin
1550 Lang_Index.Config.Path_Syntax :=
1551 Path_Syntax_Kind'Value
1552 (Get_Name_String (Element.Value.Value));
1553
1554 exception
1555 when Constraint_Error =>
1556 Error_Msg
1557 (Data.Flags,
1558 "invalid value for Path_Syntax",
1559 Element.Value.Location, Project);
1560 end;
1561
1562 when Name_Source_File_Switches =>
1563 Put (Into_List =>
1564 Lang_Index.Config.Source_File_Switches,
1565 From_List => Element.Value.Values,
1566 In_Tree => Data.Tree);
1567
1568 when Name_Object_File_Suffix =>
1569 if Get_Name_String (Element.Value.Value) = "" then
1570 Error_Msg
1571 (Data.Flags,
1572 "object file suffix cannot be empty",
1573 Element.Value.Location, Project);
1574
1575 else
1576 Lang_Index.Config.Object_File_Suffix :=
1577 Element.Value.Value;
1578 end if;
1579
1580 when Name_Object_File_Switches =>
1581 Put (Into_List =>
1582 Lang_Index.Config.Object_File_Switches,
1583 From_List => Element.Value.Values,
1584 In_Tree => Data.Tree);
1585
1586 when Name_Object_Path_Switches =>
1587 Put (Into_List =>
1588 Lang_Index.Config.Object_Path_Switches,
1589 From_List => Element.Value.Values,
1590 In_Tree => Data.Tree);
1591
1592 -- Attribute Compiler_Pic_Option (<language>)
1593
1594 when Name_Pic_Option =>
1595 List := Element.Value.Values;
1596
1597 if List = Nil_String then
1598 Error_Msg
1599 (Data.Flags,
1600 "compiler PIC option cannot be null",
1601 Element.Value.Location, Project);
1602 end if;
1603
1604 Put (Into_List =>
1605 Lang_Index.Config.Compilation_PIC_Option,
1606 From_List => List,
1607 In_Tree => Data.Tree);
1608
1609 -- Attribute Mapping_File_Switches (<language>)
1610
1611 when Name_Mapping_File_Switches =>
1612 List := Element.Value.Values;
1613
1614 if List = Nil_String then
1615 Error_Msg
1616 (Data.Flags,
1617 "mapping file switches cannot be null",
1618 Element.Value.Location, Project);
1619 end if;
1620
1621 Put (Into_List =>
1622 Lang_Index.Config.Mapping_File_Switches,
1623 From_List => List,
1624 In_Tree => Data.Tree);
1625
1626 -- Attribute Mapping_Spec_Suffix (<language>)
1627
1628 when Name_Mapping_Spec_Suffix =>
1629 Lang_Index.Config.Mapping_Spec_Suffix :=
1630 File_Name_Type (Element.Value.Value);
1631
1632 -- Attribute Mapping_Body_Suffix (<language>)
1633
1634 when Name_Mapping_Body_Suffix =>
1635 Lang_Index.Config.Mapping_Body_Suffix :=
1636 File_Name_Type (Element.Value.Value);
1637
1638 -- Attribute Config_File_Switches (<language>)
1639
1640 when Name_Config_File_Switches =>
1641 List := Element.Value.Values;
1642
1643 if List = Nil_String then
1644 Error_Msg
1645 (Data.Flags,
1646 "config file switches cannot be null",
1647 Element.Value.Location, Project);
1648 end if;
1649
1650 Put (Into_List =>
1651 Lang_Index.Config.Config_File_Switches,
1652 From_List => List,
1653 In_Tree => Data.Tree);
1654
1655 -- Attribute Objects_Path (<language>)
1656
1657 when Name_Objects_Path =>
1658 Lang_Index.Config.Objects_Path :=
1659 Element.Value.Value;
1660
1661 -- Attribute Objects_Path_File (<language>)
1662
1663 when Name_Objects_Path_File =>
1664 Lang_Index.Config.Objects_Path_File :=
1665 Element.Value.Value;
1666
1667 -- Attribute Config_Body_File_Name (<language>)
1668
1669 when Name_Config_Body_File_Name =>
1670 Lang_Index.Config.Config_Body :=
1671 Element.Value.Value;
1672
1673 -- Attribute Config_Body_File_Name_Index (< Language>)
1674
1675 when Name_Config_Body_File_Name_Index =>
1676 Lang_Index.Config.Config_Body_Index :=
1677 Element.Value.Value;
1678
1679 -- Attribute Config_Body_File_Name_Pattern(<language>)
1680
1681 when Name_Config_Body_File_Name_Pattern =>
1682 Lang_Index.Config.Config_Body_Pattern :=
1683 Element.Value.Value;
1684
1685 -- Attribute Config_Spec_File_Name (<language>)
1686
1687 when Name_Config_Spec_File_Name =>
1688 Lang_Index.Config.Config_Spec :=
1689 Element.Value.Value;
1690
1691 -- Attribute Config_Spec_File_Name_Index (<language>)
1692
1693 when Name_Config_Spec_File_Name_Index =>
1694 Lang_Index.Config.Config_Spec_Index :=
1695 Element.Value.Value;
1696
1697 -- Attribute Config_Spec_File_Name_Pattern(<language>)
1698
1699 when Name_Config_Spec_File_Name_Pattern =>
1700 Lang_Index.Config.Config_Spec_Pattern :=
1701 Element.Value.Value;
1702
1703 -- Attribute Config_File_Unique (<language>)
1704
1705 when Name_Config_File_Unique =>
1706 begin
1707 Lang_Index.Config.Config_File_Unique :=
1708 Boolean'Value
1709 (Get_Name_String (Element.Value.Value));
1710 exception
1711 when Constraint_Error =>
1712 Error_Msg
1713 (Data.Flags,
1714 "illegal value for Config_File_Unique",
1715 Element.Value.Location, Project);
1716 end;
1717
1718 when others =>
1719 null;
1720 end case;
1721 end if;
1722 end if;
1723
1724 Element_Id := Element.Next;
1725 end loop;
1726
1727 Current_Array_Id := Current_Array.Next;
1728 end loop;
1729 end Process_Compiler;
1730
1731 --------------------
1732 -- Process_Naming --
1733 --------------------
1734
1735 procedure Process_Naming (Attributes : Variable_Id) is
1736 Attribute_Id : Variable_Id;
1737 Attribute : Variable;
1738
1739 begin
1740 -- Process non associated array attribute from package Naming
1741
1742 Attribute_Id := Attributes;
1743 while Attribute_Id /= No_Variable loop
1744 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
1745
1746 if not Attribute.Value.Default then
1747 if Attribute.Name = Name_Separate_Suffix then
1748
1749 -- Attribute Separate_Suffix
1750
1751 Get_Name_String (Attribute.Value.Value);
1752 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1753 Separate_Suffix := Name_Find;
1754
1755 elsif Attribute.Name = Name_Casing then
1756
1757 -- Attribute Casing
1758
1759 begin
1760 Casing :=
1761 Value (Get_Name_String (Attribute.Value.Value));
1762
1763 exception
1764 when Constraint_Error =>
1765 Error_Msg
1766 (Data.Flags,
1767 "invalid value for Casing",
1768 Attribute.Value.Location, Project);
1769 end;
1770
1771 elsif Attribute.Name = Name_Dot_Replacement then
1772
1773 -- Attribute Dot_Replacement
1774
1775 Dot_Replacement := File_Name_Type (Attribute.Value.Value);
1776
1777 end if;
1778 end if;
1779
1780 Attribute_Id := Attribute.Next;
1781 end loop;
1782 end Process_Naming;
1783
1784 procedure Process_Naming (Arrays : Array_Id) is
1785 Current_Array_Id : Array_Id;
1786 Current_Array : Array_Data;
1787 Element_Id : Array_Element_Id;
1788 Element : Array_Element;
1789
1790 begin
1791 -- Process the associative array attribute of package Naming
1792
1793 Current_Array_Id := Arrays;
1794 while Current_Array_Id /= No_Array loop
1795 Current_Array := Shared.Arrays.Table (Current_Array_Id);
1796
1797 Element_Id := Current_Array.Value;
1798 while Element_Id /= No_Array_Element loop
1799 Element := Shared.Array_Elements.Table (Element_Id);
1800
1801 -- Get the name of the language
1802
1803 Lang_Index := Get_Language_From_Name
1804 (Project, Get_Name_String (Element.Index));
1805
1806 if Lang_Index /= No_Language_Index
1807 and then Element.Value.Kind = Single
1808 and then Element.Value.Value /= No_Name
1809 then
1810 case Current_Array.Name is
1811 when Name_Spec_Suffix | Name_Specification_Suffix =>
1812
1813 -- Attribute Spec_Suffix (<language>)
1814
1815 Get_Name_String (Element.Value.Value);
1816 Canonical_Case_File_Name
1817 (Name_Buffer (1 .. Name_Len));
1818 Lang_Index.Config.Naming_Data.Spec_Suffix :=
1819 Name_Find;
1820
1821 when Name_Implementation_Suffix | Name_Body_Suffix =>
1822
1823 Get_Name_String (Element.Value.Value);
1824 Canonical_Case_File_Name
1825 (Name_Buffer (1 .. Name_Len));
1826
1827 -- Attribute Body_Suffix (<language>)
1828
1829 Lang_Index.Config.Naming_Data.Body_Suffix :=
1830 Name_Find;
1831 Lang_Index.Config.Naming_Data.Separate_Suffix :=
1832 Lang_Index.Config.Naming_Data.Body_Suffix;
1833
1834 when others =>
1835 null;
1836 end case;
1837 end if;
1838
1839 Element_Id := Element.Next;
1840 end loop;
1841
1842 Current_Array_Id := Current_Array.Next;
1843 end loop;
1844 end Process_Naming;
1845
1846 --------------------
1847 -- Process_Linker --
1848 --------------------
1849
1850 procedure Process_Linker (Attributes : Variable_Id) is
1851 Attribute_Id : Variable_Id;
1852 Attribute : Variable;
1853
1854 begin
1855 -- Process non associated array attribute from package Linker
1856
1857 Attribute_Id := Attributes;
1858 while Attribute_Id /= No_Variable loop
1859 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
1860
1861 if not Attribute.Value.Default then
1862 if Attribute.Name = Name_Driver then
1863
1864 -- Attribute Linker'Driver: the default linker to use
1865
1866 Project.Config.Linker :=
1867 Path_Name_Type (Attribute.Value.Value);
1868
1869 -- Linker'Driver is also used to link shared libraries
1870 -- if the obsolescent attribute Library_GCC has not been
1871 -- specified.
1872
1873 if Project.Config.Shared_Lib_Driver = No_File then
1874 Project.Config.Shared_Lib_Driver :=
1875 File_Name_Type (Attribute.Value.Value);
1876 end if;
1877
1878 elsif Attribute.Name = Name_Required_Switches then
1879
1880 -- Attribute Required_Switches: the minimum trailing
1881 -- options to use when invoking the linker
1882
1883 Put (Into_List =>
1884 Project.Config.Trailing_Linker_Required_Switches,
1885 From_List => Attribute.Value.Values,
1886 In_Tree => Data.Tree);
1887
1888 elsif Attribute.Name = Name_Map_File_Option then
1889 Project.Config.Map_File_Option := Attribute.Value.Value;
1890
1891 elsif Attribute.Name = Name_Max_Command_Line_Length then
1892 begin
1893 Project.Config.Max_Command_Line_Length :=
1894 Natural'Value (Get_Name_String
1895 (Attribute.Value.Value));
1896
1897 exception
1898 when Constraint_Error =>
1899 Error_Msg
1900 (Data.Flags,
1901 "value must be positive or equal to 0",
1902 Attribute.Value.Location, Project);
1903 end;
1904
1905 elsif Attribute.Name = Name_Response_File_Format then
1906 declare
1907 Name : Name_Id;
1908
1909 begin
1910 Get_Name_String (Attribute.Value.Value);
1911 To_Lower (Name_Buffer (1 .. Name_Len));
1912 Name := Name_Find;
1913
1914 if Name = Name_None then
1915 Project.Config.Resp_File_Format := None;
1916
1917 elsif Name = Name_Gnu then
1918 Project.Config.Resp_File_Format := GNU;
1919
1920 elsif Name = Name_Object_List then
1921 Project.Config.Resp_File_Format := Object_List;
1922
1923 elsif Name = Name_Option_List then
1924 Project.Config.Resp_File_Format := Option_List;
1925
1926 elsif Name_Buffer (1 .. Name_Len) = "gcc" then
1927 Project.Config.Resp_File_Format := GCC;
1928
1929 elsif Name_Buffer (1 .. Name_Len) = "gcc_gnu" then
1930 Project.Config.Resp_File_Format := GCC_GNU;
1931
1932 elsif
1933 Name_Buffer (1 .. Name_Len) = "gcc_option_list"
1934 then
1935 Project.Config.Resp_File_Format := GCC_Option_List;
1936
1937 elsif
1938 Name_Buffer (1 .. Name_Len) = "gcc_object_list"
1939 then
1940 Project.Config.Resp_File_Format := GCC_Object_List;
1941
1942 else
1943 Error_Msg
1944 (Data.Flags,
1945 "illegal response file format",
1946 Attribute.Value.Location, Project);
1947 end if;
1948 end;
1949
1950 elsif Attribute.Name = Name_Response_File_Switches then
1951 Put (Into_List => Project.Config.Resp_File_Options,
1952 From_List => Attribute.Value.Values,
1953 In_Tree => Data.Tree);
1954 end if;
1955 end if;
1956
1957 Attribute_Id := Attribute.Next;
1958 end loop;
1959 end Process_Linker;
1960
1961 -- Start of processing for Process_Packages
1962
1963 begin
1964 Packages := Project.Decl.Packages;
1965 while Packages /= No_Package loop
1966 Element := Shared.Packages.Table (Packages);
1967
1968 case Element.Name is
1969 when Name_Binder =>
1970
1971 -- Process attributes of package Binder
1972
1973 Process_Binder (Element.Decl.Arrays);
1974
1975 when Name_Builder =>
1976
1977 -- Process attributes of package Builder
1978
1979 Process_Builder (Element.Decl.Attributes);
1980
1981 when Name_Clean =>
1982
1983 -- Process attributes of package Clean
1984
1985 Process_Clean (Element.Decl.Attributes);
1986 Process_Clean (Element.Decl.Arrays);
1987
1988 when Name_Compiler =>
1989
1990 -- Process attributes of package Compiler
1991
1992 Process_Compiler (Element.Decl.Arrays);
1993
1994 when Name_Linker =>
1995
1996 -- Process attributes of package Linker
1997
1998 Process_Linker (Element.Decl.Attributes);
1999
2000 when Name_Naming =>
2001
2002 -- Process attributes of package Naming
2003
2004 Process_Naming (Element.Decl.Attributes);
2005 Process_Naming (Element.Decl.Arrays);
2006
2007 when others =>
2008 null;
2009 end case;
2010
2011 Packages := Element.Next;
2012 end loop;
2013 end Process_Packages;
2014
2015 ---------------------------------------------
2016 -- Process_Project_Level_Simple_Attributes --
2017 ---------------------------------------------
2018
2019 procedure Process_Project_Level_Simple_Attributes is
2020 Attribute_Id : Variable_Id;
2021 Attribute : Variable;
2022 List : String_List_Id;
2023
2024 begin
2025 -- Process non associated array attribute at project level
2026
2027 Attribute_Id := Project.Decl.Attributes;
2028 while Attribute_Id /= No_Variable loop
2029 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
2030
2031 if not Attribute.Value.Default then
2032 if Attribute.Name = Name_Target then
2033
2034 -- Attribute Target: the target specified
2035
2036 Project.Config.Target := Attribute.Value.Value;
2037
2038 elsif Attribute.Name = Name_Library_Builder then
2039
2040 -- Attribute Library_Builder: the application to invoke
2041 -- to build libraries.
2042
2043 Project.Config.Library_Builder :=
2044 Path_Name_Type (Attribute.Value.Value);
2045
2046 elsif Attribute.Name = Name_Archive_Builder then
2047
2048 -- Attribute Archive_Builder: the archive builder
2049 -- (usually "ar") and its minimum options (usually "cr").
2050
2051 List := Attribute.Value.Values;
2052
2053 if List = Nil_String then
2054 Error_Msg
2055 (Data.Flags,
2056 "archive builder cannot be null",
2057 Attribute.Value.Location, Project);
2058 end if;
2059
2060 Put (Into_List => Project.Config.Archive_Builder,
2061 From_List => List,
2062 In_Tree => Data.Tree);
2063
2064 elsif Attribute.Name = Name_Archive_Builder_Append_Option then
2065
2066 -- Attribute Archive_Builder: the archive builder
2067 -- (usually "ar") and its minimum options (usually "cr").
2068
2069 List := Attribute.Value.Values;
2070
2071 if List /= Nil_String then
2072 Put
2073 (Into_List =>
2074 Project.Config.Archive_Builder_Append_Option,
2075 From_List => List,
2076 In_Tree => Data.Tree);
2077 end if;
2078
2079 elsif Attribute.Name = Name_Archive_Indexer then
2080
2081 -- Attribute Archive_Indexer: the optional archive
2082 -- indexer (usually "ranlib") with its minimum options
2083 -- (usually none).
2084
2085 List := Attribute.Value.Values;
2086
2087 if List = Nil_String then
2088 Error_Msg
2089 (Data.Flags,
2090 "archive indexer cannot be null",
2091 Attribute.Value.Location, Project);
2092 end if;
2093
2094 Put (Into_List => Project.Config.Archive_Indexer,
2095 From_List => List,
2096 In_Tree => Data.Tree);
2097
2098 elsif Attribute.Name = Name_Library_Partial_Linker then
2099
2100 -- Attribute Library_Partial_Linker: the optional linker
2101 -- driver with its minimum options, to partially link
2102 -- archives.
2103
2104 List := Attribute.Value.Values;
2105
2106 if List = Nil_String then
2107 Error_Msg
2108 (Data.Flags,
2109 "partial linker cannot be null",
2110 Attribute.Value.Location, Project);
2111 end if;
2112
2113 Put (Into_List => Project.Config.Lib_Partial_Linker,
2114 From_List => List,
2115 In_Tree => Data.Tree);
2116
2117 elsif Attribute.Name = Name_Library_GCC then
2118 Project.Config.Shared_Lib_Driver :=
2119 File_Name_Type (Attribute.Value.Value);
2120 Error_Msg
2121 (Data.Flags,
2122 "?Library_'G'C'C is an obsolescent attribute, " &
2123 "use Linker''Driver instead",
2124 Attribute.Value.Location, Project);
2125
2126 elsif Attribute.Name = Name_Archive_Suffix then
2127 Project.Config.Archive_Suffix :=
2128 File_Name_Type (Attribute.Value.Value);
2129
2130 elsif Attribute.Name = Name_Linker_Executable_Option then
2131
2132 -- Attribute Linker_Executable_Option: optional options
2133 -- to specify an executable name. Defaults to "-o".
2134
2135 List := Attribute.Value.Values;
2136
2137 if List = Nil_String then
2138 Error_Msg
2139 (Data.Flags,
2140 "linker executable option cannot be null",
2141 Attribute.Value.Location, Project);
2142 end if;
2143
2144 Put (Into_List => Project.Config.Linker_Executable_Option,
2145 From_List => List,
2146 In_Tree => Data.Tree);
2147
2148 elsif Attribute.Name = Name_Linker_Lib_Dir_Option then
2149
2150 -- Attribute Linker_Lib_Dir_Option: optional options
2151 -- to specify a library search directory. Defaults to
2152 -- "-L".
2153
2154 Get_Name_String (Attribute.Value.Value);
2155
2156 if Name_Len = 0 then
2157 Error_Msg
2158 (Data.Flags,
2159 "linker library directory option cannot be empty",
2160 Attribute.Value.Location, Project);
2161 end if;
2162
2163 Project.Config.Linker_Lib_Dir_Option :=
2164 Attribute.Value.Value;
2165
2166 elsif Attribute.Name = Name_Linker_Lib_Name_Option then
2167
2168 -- Attribute Linker_Lib_Name_Option: optional options
2169 -- to specify the name of a library to be linked in.
2170 -- Defaults to "-l".
2171
2172 Get_Name_String (Attribute.Value.Value);
2173
2174 if Name_Len = 0 then
2175 Error_Msg
2176 (Data.Flags,
2177 "linker library name option cannot be empty",
2178 Attribute.Value.Location, Project);
2179 end if;
2180
2181 Project.Config.Linker_Lib_Name_Option :=
2182 Attribute.Value.Value;
2183
2184 elsif Attribute.Name = Name_Run_Path_Option then
2185
2186 -- Attribute Run_Path_Option: optional options to
2187 -- specify a path for libraries.
2188
2189 List := Attribute.Value.Values;
2190
2191 if List /= Nil_String then
2192 Put (Into_List => Project.Config.Run_Path_Option,
2193 From_List => List,
2194 In_Tree => Data.Tree);
2195 end if;
2196
2197 elsif Attribute.Name = Name_Run_Path_Origin then
2198 Get_Name_String (Attribute.Value.Value);
2199
2200 if Name_Len = 0 then
2201 Error_Msg
2202 (Data.Flags,
2203 "run path origin cannot be empty",
2204 Attribute.Value.Location, Project);
2205 end if;
2206
2207 Project.Config.Run_Path_Origin := Attribute.Value.Value;
2208
2209 elsif Attribute.Name = Name_Library_Install_Name_Option then
2210 Project.Config.Library_Install_Name_Option :=
2211 Attribute.Value.Value;
2212
2213 elsif Attribute.Name = Name_Separate_Run_Path_Options then
2214 declare
2215 pragma Unsuppress (All_Checks);
2216 begin
2217 Project.Config.Separate_Run_Path_Options :=
2218 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2219 exception
2220 when Constraint_Error =>
2221 Error_Msg
2222 (Data.Flags,
2223 "invalid value """ &
2224 Get_Name_String (Attribute.Value.Value) &
2225 """ for Separate_Run_Path_Options",
2226 Attribute.Value.Location, Project);
2227 end;
2228
2229 elsif Attribute.Name = Name_Library_Support then
2230 declare
2231 pragma Unsuppress (All_Checks);
2232 begin
2233 Project.Config.Lib_Support :=
2234 Library_Support'Value (Get_Name_String
2235 (Attribute.Value.Value));
2236 exception
2237 when Constraint_Error =>
2238 Error_Msg
2239 (Data.Flags,
2240 "invalid value """ &
2241 Get_Name_String (Attribute.Value.Value) &
2242 """ for Library_Support",
2243 Attribute.Value.Location, Project);
2244 end;
2245
2246 elsif
2247 Attribute.Name = Name_Library_Encapsulated_Supported
2248 then
2249 declare
2250 pragma Unsuppress (All_Checks);
2251 begin
2252 Project.Config.Lib_Encapsulated_Supported :=
2253 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2254 exception
2255 when Constraint_Error =>
2256 Error_Msg
2257 (Data.Flags,
2258 "invalid value """
2259 & Get_Name_String (Attribute.Value.Value)
2260 & """ for Library_Encapsulated_Supported",
2261 Attribute.Value.Location, Project);
2262 end;
2263
2264 elsif Attribute.Name = Name_Shared_Library_Prefix then
2265 Project.Config.Shared_Lib_Prefix :=
2266 File_Name_Type (Attribute.Value.Value);
2267
2268 elsif Attribute.Name = Name_Shared_Library_Suffix then
2269 Project.Config.Shared_Lib_Suffix :=
2270 File_Name_Type (Attribute.Value.Value);
2271
2272 elsif Attribute.Name = Name_Symbolic_Link_Supported then
2273 declare
2274 pragma Unsuppress (All_Checks);
2275 begin
2276 Project.Config.Symbolic_Link_Supported :=
2277 Boolean'Value (Get_Name_String
2278 (Attribute.Value.Value));
2279 exception
2280 when Constraint_Error =>
2281 Error_Msg
2282 (Data.Flags,
2283 "invalid value """
2284 & Get_Name_String (Attribute.Value.Value)
2285 & """ for Symbolic_Link_Supported",
2286 Attribute.Value.Location, Project);
2287 end;
2288
2289 elsif
2290 Attribute.Name = Name_Library_Major_Minor_Id_Supported
2291 then
2292 declare
2293 pragma Unsuppress (All_Checks);
2294 begin
2295 Project.Config.Lib_Maj_Min_Id_Supported :=
2296 Boolean'Value (Get_Name_String
2297 (Attribute.Value.Value));
2298 exception
2299 when Constraint_Error =>
2300 Error_Msg
2301 (Data.Flags,
2302 "invalid value """ &
2303 Get_Name_String (Attribute.Value.Value) &
2304 """ for Library_Major_Minor_Id_Supported",
2305 Attribute.Value.Location, Project);
2306 end;
2307
2308 elsif Attribute.Name = Name_Library_Auto_Init_Supported then
2309 declare
2310 pragma Unsuppress (All_Checks);
2311 begin
2312 Project.Config.Auto_Init_Supported :=
2313 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2314 exception
2315 when Constraint_Error =>
2316 Error_Msg
2317 (Data.Flags,
2318 "invalid value """
2319 & Get_Name_String (Attribute.Value.Value)
2320 & """ for Library_Auto_Init_Supported",
2321 Attribute.Value.Location, Project);
2322 end;
2323
2324 elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then
2325 List := Attribute.Value.Values;
2326
2327 if List /= Nil_String then
2328 Put (Into_List => Project.Config.Shared_Lib_Min_Options,
2329 From_List => List,
2330 In_Tree => Data.Tree);
2331 end if;
2332
2333 elsif Attribute.Name = Name_Library_Version_Switches then
2334 List := Attribute.Value.Values;
2335
2336 if List /= Nil_String then
2337 Put (Into_List => Project.Config.Lib_Version_Options,
2338 From_List => List,
2339 In_Tree => Data.Tree);
2340 end if;
2341 end if;
2342 end if;
2343
2344 Attribute_Id := Attribute.Next;
2345 end loop;
2346 end Process_Project_Level_Simple_Attributes;
2347
2348 --------------------------------------------
2349 -- Process_Project_Level_Array_Attributes --
2350 --------------------------------------------
2351
2352 procedure Process_Project_Level_Array_Attributes is
2353 Current_Array_Id : Array_Id;
2354 Current_Array : Array_Data;
2355 Element_Id : Array_Element_Id;
2356 Element : Array_Element;
2357 List : String_List_Id;
2358
2359 begin
2360 -- Process the associative array attributes at project level
2361
2362 Current_Array_Id := Project.Decl.Arrays;
2363 while Current_Array_Id /= No_Array loop
2364 Current_Array := Shared.Arrays.Table (Current_Array_Id);
2365
2366 Element_Id := Current_Array.Value;
2367 while Element_Id /= No_Array_Element loop
2368 Element := Shared.Array_Elements.Table (Element_Id);
2369
2370 -- Get the name of the language
2371
2372 Lang_Index :=
2373 Get_Language_From_Name
2374 (Project, Get_Name_String (Element.Index));
2375
2376 if Lang_Index /= No_Language_Index then
2377 case Current_Array.Name is
2378 when Name_Inherit_Source_Path =>
2379 List := Element.Value.Values;
2380
2381 if List /= Nil_String then
2382 Put
2383 (Into_List =>
2384 Lang_Index.Config.Include_Compatible_Languages,
2385 From_List => List,
2386 In_Tree => Data.Tree,
2387 Lower_Case => True);
2388 end if;
2389
2390 when Name_Toolchain_Description =>
2391
2392 -- Attribute Toolchain_Description (<language>)
2393
2394 Lang_Index.Config.Toolchain_Description :=
2395 Element.Value.Value;
2396
2397 when Name_Toolchain_Version =>
2398
2399 -- Attribute Toolchain_Version (<language>)
2400
2401 Lang_Index.Config.Toolchain_Version :=
2402 Element.Value.Value;
2403
2404 -- For Ada, set proper checksum computation mode,
2405 -- which has changed from version to version.
2406
2407 if Lang_Index.Name = Name_Ada then
2408 declare
2409 Vers : constant String :=
2410 Get_Name_String (Element.Value.Value);
2411 pragma Assert (Vers'First = 1);
2412
2413 begin
2414 -- Version 6.3 or earlier
2415
2416 if Vers'Length >= 8
2417 and then Vers (1 .. 5) = "GNAT "
2418 and then Vers (7) = '.'
2419 and then
2420 (Vers (6) < '6'
2421 or else
2422 (Vers (6) = '6' and then Vers (8) < '4'))
2423 then
2424 Checksum_GNAT_6_3 := True;
2425
2426 -- Version 5.03 or earlier
2427
2428 if Vers (6) < '5'
2429 or else (Vers (6) = '5'
2430 and then Vers (Vers'Last) < '4')
2431 then
2432 Checksum_GNAT_5_03 := True;
2433
2434 -- Version 5.02 or earlier (no checksums)
2435
2436 if Vers (6) /= '5'
2437 or else Vers (Vers'Last) < '3'
2438 then
2439 Checksum_Accumulate_Token_Checksum :=
2440 False;
2441 end if;
2442 end if;
2443 end if;
2444 end;
2445 end if;
2446
2447 when Name_Runtime_Library_Dir =>
2448
2449 -- Attribute Runtime_Library_Dir (<language>)
2450
2451 Lang_Index.Config.Runtime_Library_Dir :=
2452 Element.Value.Value;
2453
2454 when Name_Runtime_Source_Dir =>
2455
2456 -- Attribute Runtime_Source_Dir (<language>)
2457
2458 Lang_Index.Config.Runtime_Source_Dir :=
2459 Element.Value.Value;
2460
2461 when Name_Object_Generated =>
2462 declare
2463 pragma Unsuppress (All_Checks);
2464 Value : Boolean;
2465
2466 begin
2467 Value :=
2468 Boolean'Value
2469 (Get_Name_String (Element.Value.Value));
2470
2471 Lang_Index.Config.Object_Generated := Value;
2472
2473 -- If no object is generated, no object may be
2474 -- linked.
2475
2476 if not Value then
2477 Lang_Index.Config.Objects_Linked := False;
2478 end if;
2479
2480 exception
2481 when Constraint_Error =>
2482 Error_Msg
2483 (Data.Flags,
2484 "invalid value """
2485 & Get_Name_String (Element.Value.Value)
2486 & """ for Object_Generated",
2487 Element.Value.Location, Project);
2488 end;
2489
2490 when Name_Objects_Linked =>
2491 declare
2492 pragma Unsuppress (All_Checks);
2493 Value : Boolean;
2494
2495 begin
2496 Value :=
2497 Boolean'Value
2498 (Get_Name_String (Element.Value.Value));
2499
2500 -- No change if Object_Generated is False, as this
2501 -- forces Objects_Linked to be False too.
2502
2503 if Lang_Index.Config.Object_Generated then
2504 Lang_Index.Config.Objects_Linked := Value;
2505 end if;
2506
2507 exception
2508 when Constraint_Error =>
2509 Error_Msg
2510 (Data.Flags,
2511 "invalid value """
2512 & Get_Name_String (Element.Value.Value)
2513 & """ for Objects_Linked",
2514 Element.Value.Location, Project);
2515 end;
2516 when others =>
2517 null;
2518 end case;
2519 end if;
2520
2521 Element_Id := Element.Next;
2522 end loop;
2523
2524 Current_Array_Id := Current_Array.Next;
2525 end loop;
2526 end Process_Project_Level_Array_Attributes;
2527
2528 -- Start of processing for Check_Configuration
2529
2530 begin
2531 Process_Project_Level_Simple_Attributes;
2532 Process_Project_Level_Array_Attributes;
2533 Process_Packages;
2534
2535 -- For unit based languages, set Casing, Dot_Replacement and
2536 -- Separate_Suffix in Naming_Data.
2537
2538 Lang_Index := Project.Languages;
2539 while Lang_Index /= No_Language_Index loop
2540 if Lang_Index.Config.Kind = Unit_Based then
2541 Lang_Index.Config.Naming_Data.Casing := Casing;
2542 Lang_Index.Config.Naming_Data.Dot_Replacement := Dot_Replacement;
2543
2544 if Separate_Suffix /= No_File then
2545 Lang_Index.Config.Naming_Data.Separate_Suffix :=
2546 Separate_Suffix;
2547 end if;
2548
2549 exit;
2550 end if;
2551
2552 Lang_Index := Lang_Index.Next;
2553 end loop;
2554
2555 -- Give empty names to various prefixes/suffixes, if they have not
2556 -- been specified in the configuration.
2557
2558 if Project.Config.Archive_Suffix = No_File then
2559 Project.Config.Archive_Suffix := Empty_File;
2560 end if;
2561
2562 if Project.Config.Shared_Lib_Prefix = No_File then
2563 Project.Config.Shared_Lib_Prefix := Empty_File;
2564 end if;
2565
2566 if Project.Config.Shared_Lib_Suffix = No_File then
2567 Project.Config.Shared_Lib_Suffix := Empty_File;
2568 end if;
2569
2570 Lang_Index := Project.Languages;
2571 while Lang_Index /= No_Language_Index loop
2572
2573 -- For all languages, Compiler_Driver needs to be specified. This is
2574 -- only needed if we do intend to compile (not in GPS for instance).
2575
2576 if Data.Flags.Compiler_Driver_Mandatory
2577 and then Lang_Index.Config.Compiler_Driver = No_File
2578 and then not Project.Externally_Built
2579 then
2580 Error_Msg_Name_1 := Lang_Index.Display_Name;
2581 Error_Msg
2582 (Data.Flags,
2583 "?\no compiler specified for language %%" &
2584 ", ignoring all its sources",
2585 No_Location, Project);
2586
2587 if Lang_Index = Project.Languages then
2588 Project.Languages := Lang_Index.Next;
2589 else
2590 Prev_Index.Next := Lang_Index.Next;
2591 end if;
2592
2593 elsif Lang_Index.Config.Kind = Unit_Based then
2594 Prev_Index := Lang_Index;
2595
2596 -- For unit based languages, Dot_Replacement, Spec_Suffix and
2597 -- Body_Suffix need to be specified.
2598
2599 if Lang_Index.Config.Naming_Data.Dot_Replacement = No_File then
2600 Error_Msg
2601 (Data.Flags,
2602 "Dot_Replacement not specified for " &
2603 Get_Name_String (Lang_Index.Name),
2604 No_Location, Project);
2605 end if;
2606
2607 if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then
2608 Error_Msg
2609 (Data.Flags,
2610 "\Spec_Suffix not specified for " &
2611 Get_Name_String (Lang_Index.Name),
2612 No_Location, Project);
2613 end if;
2614
2615 if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then
2616 Error_Msg
2617 (Data.Flags,
2618 "\Body_Suffix not specified for " &
2619 Get_Name_String (Lang_Index.Name),
2620 No_Location, Project);
2621 end if;
2622
2623 else
2624 Prev_Index := Lang_Index;
2625
2626 -- For file based languages, either Spec_Suffix or Body_Suffix
2627 -- need to be specified.
2628
2629 if Data.Flags.Require_Sources_Other_Lang
2630 and then Lang_Index.Config.Naming_Data.Spec_Suffix = No_File
2631 and then Lang_Index.Config.Naming_Data.Body_Suffix = No_File
2632 then
2633 Error_Msg_Name_1 := Lang_Index.Display_Name;
2634 Error_Msg
2635 (Data.Flags,
2636 "\no suffixes specified for %%",
2637 No_Location, Project);
2638 end if;
2639 end if;
2640
2641 Lang_Index := Lang_Index.Next;
2642 end loop;
2643 end Check_Configuration;
2644
2645 -------------------------------
2646 -- Check_If_Externally_Built --
2647 -------------------------------
2648
2649 procedure Check_If_Externally_Built
2650 (Project : Project_Id;
2651 Data : in out Tree_Processing_Data)
2652 is
2653 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
2654 Externally_Built : constant Variable_Value :=
2655 Util.Value_Of
2656 (Name_Externally_Built,
2657 Project.Decl.Attributes, Shared);
2658
2659 begin
2660 if not Externally_Built.Default then
2661 Get_Name_String (Externally_Built.Value);
2662 To_Lower (Name_Buffer (1 .. Name_Len));
2663
2664 if Name_Buffer (1 .. Name_Len) = "true" then
2665 Project.Externally_Built := True;
2666
2667 elsif Name_Buffer (1 .. Name_Len) /= "false" then
2668 Error_Msg (Data.Flags,
2669 "Externally_Built may only be true or false",
2670 Externally_Built.Location, Project);
2671 end if;
2672 end if;
2673
2674 -- A virtual project extending an externally built project is itself
2675 -- externally built.
2676
2677 if Project.Virtual and then Project.Extends /= No_Project then
2678 Project.Externally_Built := Project.Extends.Externally_Built;
2679 end if;
2680
2681 if Project.Externally_Built then
2682 Debug_Output ("project is externally built");
2683 else
2684 Debug_Output ("project is not externally built");
2685 end if;
2686 end Check_If_Externally_Built;
2687
2688 ----------------------
2689 -- Check_Interfaces --
2690 ----------------------
2691
2692 procedure Check_Interfaces
2693 (Project : Project_Id;
2694 Data : in out Tree_Processing_Data)
2695 is
2696 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
2697
2698 Interfaces : constant Prj.Variable_Value :=
2699 Prj.Util.Value_Of
2700 (Snames.Name_Interfaces,
2701 Project.Decl.Attributes,
2702 Shared);
2703
2704 Library_Interface : constant Prj.Variable_Value :=
2705 Prj.Util.Value_Of
2706 (Snames.Name_Library_Interface,
2707 Project.Decl.Attributes,
2708 Shared);
2709
2710 List : String_List_Id;
2711 Element : String_Element;
2712 Name : File_Name_Type;
2713 Iter : Source_Iterator;
2714 Source : Source_Id;
2715 Project_2 : Project_Id;
2716 Other : Source_Id;
2717 Unit_Found : Boolean;
2718
2719 Interface_ALIs : String_List_Id := Nil_String;
2720 Other_Interfaces : String_List_Id := Nil_String;
2721
2722 begin
2723 if not Interfaces.Default then
2724
2725 -- Set In_Interfaces to False for all sources. It will be set to True
2726 -- later for the sources in the Interfaces list.
2727
2728 Project_2 := Project;
2729 while Project_2 /= No_Project loop
2730 Iter := For_Each_Source (Data.Tree, Project_2);
2731 loop
2732 Source := Prj.Element (Iter);
2733 exit when Source = No_Source;
2734 Source.In_Interfaces := False;
2735 Next (Iter);
2736 end loop;
2737
2738 Project_2 := Project_2.Extends;
2739 end loop;
2740
2741 List := Interfaces.Values;
2742 while List /= Nil_String loop
2743 Element := Shared.String_Elements.Table (List);
2744 Name := Canonical_Case_File_Name (Element.Value);
2745
2746 Project_2 := Project;
2747 Big_Loop : while Project_2 /= No_Project loop
2748 if Project.Qualifier = Aggregate_Library then
2749
2750 -- For an aggregate library we want to consider sources of
2751 -- all aggregated projects.
2752
2753 Iter := For_Each_Source (Data.Tree);
2754
2755 else
2756 Iter := For_Each_Source (Data.Tree, Project_2);
2757 end if;
2758
2759 loop
2760 Source := Prj.Element (Iter);
2761 exit when Source = No_Source;
2762
2763 if Source.File = Name then
2764 if not Source.Locally_Removed then
2765 Source.In_Interfaces := True;
2766 Source.Declared_In_Interfaces := True;
2767
2768 Other := Other_Part (Source);
2769
2770 if Other /= No_Source then
2771 Other.In_Interfaces := True;
2772 Other.Declared_In_Interfaces := True;
2773 end if;
2774
2775 -- Unit based case
2776
2777 if Source.Language.Config.Kind = Unit_Based then
2778 if Source.Kind = Spec
2779 and then Other_Part (Source) /= No_Source
2780 then
2781 Source := Other_Part (Source);
2782 end if;
2783
2784 String_Element_Table.Increment_Last
2785 (Shared.String_Elements);
2786
2787 Shared.String_Elements.Table
2788 (String_Element_Table.Last
2789 (Shared.String_Elements)) :=
2790 (Value => Name_Id (Source.Dep_Name),
2791 Index => 0,
2792 Display_Value => Name_Id (Source.Dep_Name),
2793 Location => No_Location,
2794 Flag => False,
2795 Next => Interface_ALIs);
2796
2797 Interface_ALIs :=
2798 String_Element_Table.Last
2799 (Shared.String_Elements);
2800
2801 -- File based case
2802
2803 else
2804 String_Element_Table.Increment_Last
2805 (Shared.String_Elements);
2806
2807 Shared.String_Elements.Table
2808 (String_Element_Table.Last
2809 (Shared.String_Elements)) :=
2810 (Value => Name_Id (Source.File),
2811 Index => 0,
2812 Display_Value => Name_Id (Source.Display_File),
2813 Location => No_Location,
2814 Flag => False,
2815 Next => Other_Interfaces);
2816
2817 Other_Interfaces :=
2818 String_Element_Table.Last
2819 (Shared.String_Elements);
2820 end if;
2821
2822 Debug_Output
2823 ("interface: ", Name_Id (Source.Path.Name));
2824 end if;
2825
2826 exit Big_Loop;
2827 end if;
2828
2829 Next (Iter);
2830 end loop;
2831
2832 Project_2 := Project_2.Extends;
2833 end loop Big_Loop;
2834
2835 if Source = No_Source then
2836 Error_Msg_File_1 := File_Name_Type (Element.Value);
2837 Error_Msg_Name_1 := Project.Name;
2838
2839 Error_Msg
2840 (Data.Flags,
2841 "{ cannot be an interface of project %% "
2842 & "as it is not one of its sources",
2843 Element.Location, Project);
2844 end if;
2845
2846 List := Element.Next;
2847 end loop;
2848
2849 Project.Interfaces_Defined := True;
2850 Project.Lib_Interface_ALIs := Interface_ALIs;
2851 Project.Other_Interfaces := Other_Interfaces;
2852
2853 elsif Project.Library and then not Library_Interface.Default then
2854
2855 -- Set In_Interfaces to False for all sources. It will be set to True
2856 -- later for the sources in the Library_Interface list.
2857
2858 Project_2 := Project;
2859 while Project_2 /= No_Project loop
2860 Iter := For_Each_Source (Data.Tree, Project_2);
2861 loop
2862 Source := Prj.Element (Iter);
2863 exit when Source = No_Source;
2864 Source.In_Interfaces := False;
2865 Next (Iter);
2866 end loop;
2867
2868 Project_2 := Project_2.Extends;
2869 end loop;
2870
2871 List := Library_Interface.Values;
2872 while List /= Nil_String loop
2873 Element := Shared.String_Elements.Table (List);
2874 Get_Name_String (Element.Value);
2875 To_Lower (Name_Buffer (1 .. Name_Len));
2876 Name := Name_Find;
2877 Unit_Found := False;
2878
2879 Project_2 := Project;
2880 Big_Loop_2 : while Project_2 /= No_Project loop
2881 if Project.Qualifier = Aggregate_Library then
2882
2883 -- For an aggregate library we want to consider sources of
2884 -- all aggregated projects.
2885
2886 Iter := For_Each_Source (Data.Tree);
2887
2888 else
2889 Iter := For_Each_Source (Data.Tree, Project_2);
2890 end if;
2891
2892 loop
2893 Source := Prj.Element (Iter);
2894 exit when Source = No_Source;
2895
2896 if Source.Unit /= No_Unit_Index
2897 and then Source.Unit.Name = Name_Id (Name)
2898 then
2899 if not Source.Locally_Removed then
2900 Source.In_Interfaces := True;
2901 Source.Declared_In_Interfaces := True;
2902 Project.Interfaces_Defined := True;
2903
2904 Other := Other_Part (Source);
2905
2906 if Other /= No_Source then
2907 Other.In_Interfaces := True;
2908 Other.Declared_In_Interfaces := True;
2909 end if;
2910
2911 Debug_Output
2912 ("interface: ", Name_Id (Source.Path.Name));
2913
2914 if Source.Kind = Spec
2915 and then Other_Part (Source) /= No_Source
2916 then
2917 Source := Other_Part (Source);
2918 end if;
2919
2920 String_Element_Table.Increment_Last
2921 (Shared.String_Elements);
2922
2923 Shared.String_Elements.Table
2924 (String_Element_Table.Last
2925 (Shared.String_Elements)) :=
2926 (Value => Name_Id (Source.Dep_Name),
2927 Index => 0,
2928 Display_Value => Name_Id (Source.Dep_Name),
2929 Location => No_Location,
2930 Flag => False,
2931 Next => Interface_ALIs);
2932
2933 Interface_ALIs :=
2934 String_Element_Table.Last (Shared.String_Elements);
2935 end if;
2936
2937 Unit_Found := True;
2938 exit Big_Loop_2;
2939 end if;
2940
2941 Next (Iter);
2942 end loop;
2943
2944 Project_2 := Project_2.Extends;
2945 end loop Big_Loop_2;
2946
2947 if not Unit_Found then
2948 Error_Msg_Name_1 := Name_Id (Name);
2949
2950 Error_Msg
2951 (Data.Flags,
2952 "%% is not a unit of this project",
2953 Element.Location, Project);
2954 end if;
2955
2956 List := Element.Next;
2957 end loop;
2958
2959 Project.Lib_Interface_ALIs := Interface_ALIs;
2960
2961 elsif Project.Extends /= No_Project
2962 and then Project.Extends.Interfaces_Defined
2963 then
2964 Project.Interfaces_Defined := True;
2965
2966 Iter := For_Each_Source (Data.Tree, Project);
2967 loop
2968 Source := Prj.Element (Iter);
2969 exit when Source = No_Source;
2970
2971 if not Source.Declared_In_Interfaces then
2972 Source.In_Interfaces := False;
2973 end if;
2974
2975 Next (Iter);
2976 end loop;
2977
2978 Project.Lib_Interface_ALIs := Project.Extends.Lib_Interface_ALIs;
2979 end if;
2980 end Check_Interfaces;
2981
2982 ------------------------------
2983 -- Check_Library_Attributes --
2984 ------------------------------
2985
2986 -- This procedure is awfully long (over 700 lines) should be broken up???
2987
2988 procedure Check_Library_Attributes
2989 (Project : Project_Id;
2990 Data : in out Tree_Processing_Data)
2991 is
2992 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
2993
2994 Attributes : constant Prj.Variable_Id := Project.Decl.Attributes;
2995
2996 Lib_Dir : constant Prj.Variable_Value :=
2997 Prj.Util.Value_Of
2998 (Snames.Name_Library_Dir, Attributes, Shared);
2999
3000 Lib_Name : constant Prj.Variable_Value :=
3001 Prj.Util.Value_Of
3002 (Snames.Name_Library_Name, Attributes, Shared);
3003
3004 Lib_Standalone : constant Prj.Variable_Value :=
3005 Prj.Util.Value_Of
3006 (Snames.Name_Library_Standalone,
3007 Attributes, Shared);
3008
3009 Lib_Version : constant Prj.Variable_Value :=
3010 Prj.Util.Value_Of
3011 (Snames.Name_Library_Version, Attributes, Shared);
3012
3013 Lib_ALI_Dir : constant Prj.Variable_Value :=
3014 Prj.Util.Value_Of
3015 (Snames.Name_Library_Ali_Dir, Attributes, Shared);
3016
3017 Lib_GCC : constant Prj.Variable_Value :=
3018 Prj.Util.Value_Of
3019 (Snames.Name_Library_GCC, Attributes, Shared);
3020
3021 The_Lib_Kind : constant Prj.Variable_Value :=
3022 Prj.Util.Value_Of
3023 (Snames.Name_Library_Kind, Attributes, Shared);
3024
3025 Imported_Project_List : Project_List;
3026 Continuation : String_Access := No_Continuation_String'Access;
3027 Support_For_Libraries : Library_Support;
3028
3029 Library_Directory_Present : Boolean;
3030
3031 procedure Check_Library (Proj : Project_Id; Extends : Boolean);
3032 -- Check if an imported or extended project if also a library project
3033
3034 procedure Check_Aggregate_Library_Dirs;
3035 -- Check that the library directory and the library ALI directory of an
3036 -- aggregate library project are not the same as the object directory or
3037 -- the library directory of any of its aggregated projects.
3038
3039 ----------------------------------
3040 -- Check_Aggregate_Library_Dirs --
3041 ----------------------------------
3042
3043 procedure Check_Aggregate_Library_Dirs is
3044 procedure Process_Aggregate (Proj : Project_Id);
3045 -- Recursive procedure to check the aggregated projects, as they may
3046 -- also be aggregated library projects.
3047
3048 -----------------------
3049 -- Process_Aggregate --
3050 -----------------------
3051
3052 procedure Process_Aggregate (Proj : Project_Id) is
3053 Agg : Aggregated_Project_List;
3054
3055 begin
3056 Agg := Proj.Aggregated_Projects;
3057 while Agg /= null loop
3058 Error_Msg_Name_1 := Agg.Project.Name;
3059
3060 if Agg.Project.Qualifier /= Aggregate_Library
3061 and then Project.Library_ALI_Dir.Name =
3062 Agg.Project.Object_Directory.Name
3063 then
3064 Error_Msg
3065 (Data.Flags,
3066 "aggregate library 'A'L'I directory cannot be shared with"
3067 & " object directory of aggregated project %%",
3068 The_Lib_Kind.Location, Project);
3069
3070 elsif Project.Library_ALI_Dir.Name =
3071 Agg.Project.Library_Dir.Name
3072 then
3073 Error_Msg
3074 (Data.Flags,
3075 "aggregate library 'A'L'I directory cannot be shared with"
3076 & " library directory of aggregated project %%",
3077 The_Lib_Kind.Location, Project);
3078
3079 elsif Agg.Project.Qualifier /= Aggregate_Library
3080 and then Project.Library_Dir.Name =
3081 Agg.Project.Object_Directory.Name
3082 then
3083 Error_Msg
3084 (Data.Flags,
3085 "aggregate library directory cannot be shared with"
3086 & " object directory of aggregated project %%",
3087 The_Lib_Kind.Location, Project);
3088
3089 elsif Project.Library_Dir.Name =
3090 Agg.Project.Library_Dir.Name
3091 then
3092 Error_Msg
3093 (Data.Flags,
3094 "aggregate library directory cannot be shared with"
3095 & " library directory of aggregated project %%",
3096 The_Lib_Kind.Location, Project);
3097 end if;
3098
3099 if Agg.Project.Qualifier = Aggregate_Library then
3100 Process_Aggregate (Agg.Project);
3101 end if;
3102
3103 Agg := Agg.Next;
3104 end loop;
3105 end Process_Aggregate;
3106
3107 -- Start of processing for Check_Aggregate_Library_Dirs
3108
3109 begin
3110 if Project.Qualifier = Aggregate_Library then
3111 Process_Aggregate (Project);
3112 end if;
3113 end Check_Aggregate_Library_Dirs;
3114
3115 -------------------
3116 -- Check_Library --
3117 -------------------
3118
3119 procedure Check_Library (Proj : Project_Id; Extends : Boolean) is
3120 Src_Id : Source_Id;
3121 Iter : Source_Iterator;
3122
3123 begin
3124 if Proj /= No_Project then
3125 if not Proj.Library then
3126
3127 -- The only not library projects that are OK are those that
3128 -- have no sources. However, header files from non-Ada
3129 -- languages are OK, as there is nothing to compile.
3130
3131 Iter := For_Each_Source (Data.Tree, Proj);
3132 loop
3133 Src_Id := Prj.Element (Iter);
3134 exit when Src_Id = No_Source
3135 or else Src_Id.Language.Config.Kind /= File_Based
3136 or else Src_Id.Kind /= Spec;
3137 Next (Iter);
3138 end loop;
3139
3140 if Src_Id /= No_Source then
3141 Error_Msg_Name_1 := Project.Name;
3142 Error_Msg_Name_2 := Proj.Name;
3143
3144 if Extends then
3145 if Project.Library_Kind /= Static then
3146 Error_Msg
3147 (Data.Flags,
3148 Continuation.all &
3149 "shared library project %% cannot extend " &
3150 "project %% that is not a library project",
3151 Project.Location, Project);
3152 Continuation := Continuation_String'Access;
3153 end if;
3154
3155 elsif not Unchecked_Shared_Lib_Imports
3156 and then Project.Library_Kind /= Static
3157 then
3158 Error_Msg
3159 (Data.Flags,
3160 Continuation.all &
3161 "shared library project %% cannot import project %% " &
3162 "that is not a shared library project",
3163 Project.Location, Project);
3164 Continuation := Continuation_String'Access;
3165 end if;
3166 end if;
3167
3168 elsif Project.Library_Kind /= Static
3169 and then not Lib_Standalone.Default
3170 and then Get_Name_String (Lib_Standalone.Value) = "encapsulated"
3171 and then Proj.Library_Kind /= Static
3172 then
3173 -- An encapsulated library must depend only on static libraries
3174
3175 Error_Msg_Name_1 := Project.Name;
3176 Error_Msg_Name_2 := Proj.Name;
3177
3178 Error_Msg
3179 (Data.Flags,
3180 Continuation.all &
3181 "encapsulated library project %% cannot import shared " &
3182 "library project %%",
3183 Project.Location, Project);
3184 Continuation := Continuation_String'Access;
3185
3186 elsif Project.Library_Kind /= Static
3187 and then Proj.Library_Kind = Static
3188 and then
3189 (Lib_Standalone.Default
3190 or else
3191 Get_Name_String (Lib_Standalone.Value) /= "encapsulated")
3192 then
3193 Error_Msg_Name_1 := Project.Name;
3194 Error_Msg_Name_2 := Proj.Name;
3195
3196 if Extends then
3197 Error_Msg
3198 (Data.Flags,
3199 Continuation.all &
3200 "shared library project %% cannot extend static " &
3201 "library project %%",
3202 Project.Location, Project);
3203 Continuation := Continuation_String'Access;
3204
3205 elsif not Unchecked_Shared_Lib_Imports then
3206 Error_Msg
3207 (Data.Flags,
3208 Continuation.all &
3209 "shared library project %% cannot import static " &
3210 "library project %%",
3211 Project.Location, Project);
3212 Continuation := Continuation_String'Access;
3213 end if;
3214
3215 end if;
3216 end if;
3217 end Check_Library;
3218
3219 Dir_Exists : Boolean;
3220
3221 -- Start of processing for Check_Library_Attributes
3222
3223 begin
3224 Library_Directory_Present := Lib_Dir.Value /= Empty_String;
3225
3226 -- Special case of extending project
3227
3228 if Project.Extends /= No_Project then
3229
3230 -- If the project extended is a library project, we inherit the
3231 -- library name, if it is not redefined; we check that the library
3232 -- directory is specified.
3233
3234 if Project.Extends.Library then
3235 if Project.Qualifier = Standard then
3236 Error_Msg
3237 (Data.Flags,
3238 "a standard project cannot extend a library project",
3239 Project.Location, Project);
3240
3241 else
3242 if Lib_Name.Default then
3243 Project.Library_Name := Project.Extends.Library_Name;
3244 end if;
3245
3246 if Lib_Dir.Default then
3247 if not Project.Virtual then
3248 Error_Msg
3249 (Data.Flags,
3250 "a project extending a library project must " &
3251 "specify an attribute Library_Dir",
3252 Project.Location, Project);
3253
3254 else
3255 -- For a virtual project extending a library project,
3256 -- inherit library directory and library kind.
3257
3258 Project.Library_Dir := Project.Extends.Library_Dir;
3259 Library_Directory_Present := True;
3260 Project.Library_Kind := Project.Extends.Library_Kind;
3261 end if;
3262 end if;
3263 end if;
3264 end if;
3265 end if;
3266
3267 pragma Assert (Lib_Name.Kind = Single);
3268
3269 if Lib_Name.Value = Empty_String then
3270 if Current_Verbosity = High
3271 and then Project.Library_Name = No_Name
3272 then
3273 Debug_Indent;
3274 Write_Line ("no library name");
3275 end if;
3276
3277 else
3278 -- There is no restriction on the syntax of library names
3279
3280 Project.Library_Name := Lib_Name.Value;
3281 end if;
3282
3283 if Project.Library_Name /= No_Name then
3284 if Current_Verbosity = High then
3285 Write_Attr
3286 ("Library name: ", Get_Name_String (Project.Library_Name));
3287 end if;
3288
3289 pragma Assert (Lib_Dir.Kind = Single);
3290
3291 if not Library_Directory_Present then
3292 Debug_Output ("no library directory");
3293
3294 else
3295 -- Find path name (unless inherited), check that it is a directory
3296
3297 if Project.Library_Dir = No_Path_Information then
3298 Locate_Directory
3299 (Project,
3300 File_Name_Type (Lib_Dir.Value),
3301 Path => Project.Library_Dir,
3302 Dir_Exists => Dir_Exists,
3303 Data => Data,
3304 Create => "library",
3305 Must_Exist => False,
3306 Location => Lib_Dir.Location,
3307 Externally_Built => Project.Externally_Built);
3308
3309 else
3310 Dir_Exists :=
3311 Is_Directory
3312 (Get_Name_String (Project.Library_Dir.Display_Name));
3313 end if;
3314
3315 if not Dir_Exists then
3316 if Directories_Must_Exist_In_Projects then
3317
3318 -- Get the absolute name of the library directory that does
3319 -- not exist, to report an error.
3320
3321 Err_Vars.Error_Msg_File_1 :=
3322 File_Name_Type (Project.Library_Dir.Display_Name);
3323 Error_Msg
3324 (Data.Flags,
3325 "library directory { does not exist",
3326 Lib_Dir.Location, Project);
3327 end if;
3328
3329 -- Checks for object/source directories
3330
3331 elsif not Project.Externally_Built
3332
3333 -- An aggregate library does not have sources or objects, so
3334 -- these tests are not required in this case.
3335
3336 and then Project.Qualifier /= Aggregate_Library
3337 then
3338 -- Library directory cannot be the same as Object directory
3339
3340 if Project.Library_Dir.Name = Project.Object_Directory.Name then
3341 Error_Msg
3342 (Data.Flags,
3343 "library directory cannot be the same " &
3344 "as object directory",
3345 Lib_Dir.Location, Project);
3346 Project.Library_Dir := No_Path_Information;
3347
3348 else
3349 declare
3350 OK : Boolean := True;
3351 Dirs_Id : String_List_Id;
3352 Dir_Elem : String_Element;
3353 Pid : Project_List;
3354
3355 begin
3356 -- The library directory cannot be the same as a source
3357 -- directory of the current project.
3358
3359 Dirs_Id := Project.Source_Dirs;
3360 while Dirs_Id /= Nil_String loop
3361 Dir_Elem := Shared.String_Elements.Table (Dirs_Id);
3362 Dirs_Id := Dir_Elem.Next;
3363
3364 if Project.Library_Dir.Name =
3365 Path_Name_Type (Dir_Elem.Value)
3366 then
3367 Err_Vars.Error_Msg_File_1 :=
3368 File_Name_Type (Dir_Elem.Value);
3369 Error_Msg
3370 (Data.Flags,
3371 "library directory cannot be the same "
3372 & "as source directory {",
3373 Lib_Dir.Location, Project);
3374 OK := False;
3375 exit;
3376 end if;
3377 end loop;
3378
3379 if OK then
3380
3381 -- The library directory cannot be the same as a
3382 -- source directory of another project either.
3383
3384 Pid := Data.Tree.Projects;
3385 Project_Loop : loop
3386 exit Project_Loop when Pid = null;
3387
3388 if Pid.Project /= Project then
3389 Dirs_Id := Pid.Project.Source_Dirs;
3390
3391 Dir_Loop : while Dirs_Id /= Nil_String loop
3392 Dir_Elem :=
3393 Shared.String_Elements.Table (Dirs_Id);
3394 Dirs_Id := Dir_Elem.Next;
3395
3396 if Project.Library_Dir.Name =
3397 Path_Name_Type (Dir_Elem.Value)
3398 then
3399 Err_Vars.Error_Msg_File_1 :=
3400 File_Name_Type (Dir_Elem.Value);
3401 Err_Vars.Error_Msg_Name_1 :=
3402 Pid.Project.Name;
3403
3404 Error_Msg
3405 (Data.Flags,
3406 "library directory cannot be the same "
3407 & "as source directory { of project %%",
3408 Lib_Dir.Location, Project);
3409 OK := False;
3410 exit Project_Loop;
3411 end if;
3412 end loop Dir_Loop;
3413 end if;
3414
3415 Pid := Pid.Next;
3416 end loop Project_Loop;
3417 end if;
3418
3419 if not OK then
3420 Project.Library_Dir := No_Path_Information;
3421
3422 elsif Current_Verbosity = High then
3423
3424 -- Display the Library directory in high verbosity
3425
3426 Write_Attr
3427 ("Library directory",
3428 Get_Name_String (Project.Library_Dir.Display_Name));
3429 end if;
3430 end;
3431 end if;
3432 end if;
3433 end if;
3434
3435 end if;
3436
3437 Project.Library :=
3438 Project.Library_Dir /= No_Path_Information
3439 and then Project.Library_Name /= No_Name;
3440
3441 if Project.Extends = No_Project then
3442 case Project.Qualifier is
3443 when Standard =>
3444 if Project.Library then
3445 Error_Msg
3446 (Data.Flags,
3447 "a standard project cannot be a library project",
3448 Lib_Name.Location, Project);
3449 end if;
3450
3451 when Library | Aggregate_Library =>
3452 if not Project.Library then
3453 if Project.Library_Name = No_Name then
3454 Error_Msg
3455 (Data.Flags,
3456 "attribute Library_Name not declared",
3457 Project.Location, Project);
3458
3459 if not Library_Directory_Present then
3460 Error_Msg
3461 (Data.Flags,
3462 "\attribute Library_Dir not declared",
3463 Project.Location, Project);
3464 end if;
3465
3466 elsif Project.Library_Dir = No_Path_Information then
3467 Error_Msg
3468 (Data.Flags,
3469 "attribute Library_Dir not declared",
3470 Project.Location, Project);
3471 end if;
3472 end if;
3473
3474 when others =>
3475 null;
3476 end case;
3477 end if;
3478
3479 if Project.Library then
3480 Support_For_Libraries := Project.Config.Lib_Support;
3481
3482 if not Project.Externally_Built
3483 and then Support_For_Libraries = Prj.None
3484 then
3485 Error_Msg
3486 (Data.Flags,
3487 "?libraries are not supported on this platform",
3488 Lib_Name.Location, Project);
3489 Project.Library := False;
3490
3491 else
3492 if Lib_ALI_Dir.Value = Empty_String then
3493 Debug_Output ("no library ALI directory specified");
3494 Project.Library_ALI_Dir := Project.Library_Dir;
3495
3496 else
3497 -- Find path name, check that it is a directory
3498
3499 Locate_Directory
3500 (Project,
3501 File_Name_Type (Lib_ALI_Dir.Value),
3502 Path => Project.Library_ALI_Dir,
3503 Create => "library ALI",
3504 Dir_Exists => Dir_Exists,
3505 Data => Data,
3506 Must_Exist => False,
3507 Location => Lib_ALI_Dir.Location,
3508 Externally_Built => Project.Externally_Built);
3509
3510 if not Dir_Exists then
3511
3512 -- Get the absolute name of the library ALI directory that
3513 -- does not exist, to report an error.
3514
3515 Err_Vars.Error_Msg_File_1 :=
3516 File_Name_Type (Project.Library_ALI_Dir.Display_Name);
3517 Error_Msg
3518 (Data.Flags,
3519 "library 'A'L'I directory { does not exist",
3520 Lib_ALI_Dir.Location, Project);
3521 end if;
3522
3523 if not Project.Externally_Built
3524 and then Project.Library_ALI_Dir /= Project.Library_Dir
3525 then
3526 -- The library ALI directory cannot be the same as the
3527 -- Object directory.
3528
3529 if Project.Library_ALI_Dir = Project.Object_Directory then
3530 Error_Msg
3531 (Data.Flags,
3532 "library 'A'L'I directory cannot be the same " &
3533 "as object directory",
3534 Lib_ALI_Dir.Location, Project);
3535 Project.Library_ALI_Dir := No_Path_Information;
3536
3537 else
3538 declare
3539 OK : Boolean := True;
3540 Dirs_Id : String_List_Id;
3541 Dir_Elem : String_Element;
3542 Pid : Project_List;
3543
3544 begin
3545 -- The library ALI directory cannot be the same as
3546 -- a source directory of the current project.
3547
3548 Dirs_Id := Project.Source_Dirs;
3549 while Dirs_Id /= Nil_String loop
3550 Dir_Elem := Shared.String_Elements.Table (Dirs_Id);
3551 Dirs_Id := Dir_Elem.Next;
3552
3553 if Project.Library_ALI_Dir.Name =
3554 Path_Name_Type (Dir_Elem.Value)
3555 then
3556 Err_Vars.Error_Msg_File_1 :=
3557 File_Name_Type (Dir_Elem.Value);
3558 Error_Msg
3559 (Data.Flags,
3560 "library 'A'L'I directory cannot be " &
3561 "the same as source directory {",
3562 Lib_ALI_Dir.Location, Project);
3563 OK := False;
3564 exit;
3565 end if;
3566 end loop;
3567
3568 if OK then
3569
3570 -- The library ALI directory cannot be the same as
3571 -- a source directory of another project either.
3572
3573 Pid := Data.Tree.Projects;
3574 ALI_Project_Loop : loop
3575 exit ALI_Project_Loop when Pid = null;
3576
3577 if Pid.Project /= Project then
3578 Dirs_Id := Pid.Project.Source_Dirs;
3579
3580 ALI_Dir_Loop :
3581 while Dirs_Id /= Nil_String loop
3582 Dir_Elem :=
3583 Shared.String_Elements.Table (Dirs_Id);
3584 Dirs_Id := Dir_Elem.Next;
3585
3586 if Project.Library_ALI_Dir.Name =
3587 Path_Name_Type (Dir_Elem.Value)
3588 then
3589 Err_Vars.Error_Msg_File_1 :=
3590 File_Name_Type (Dir_Elem.Value);
3591 Err_Vars.Error_Msg_Name_1 :=
3592 Pid.Project.Name;
3593
3594 Error_Msg
3595 (Data.Flags,
3596 "library 'A'L'I directory cannot " &
3597 "be the same as source directory " &
3598 "{ of project %%",
3599 Lib_ALI_Dir.Location, Project);
3600 OK := False;
3601 exit ALI_Project_Loop;
3602 end if;
3603 end loop ALI_Dir_Loop;
3604 end if;
3605 Pid := Pid.Next;
3606 end loop ALI_Project_Loop;
3607 end if;
3608
3609 if not OK then
3610 Project.Library_ALI_Dir := No_Path_Information;
3611
3612 elsif Current_Verbosity = High then
3613
3614 -- Display Library ALI directory in high verbosity
3615
3616 Write_Attr
3617 ("Library ALI dir",
3618 Get_Name_String
3619 (Project.Library_ALI_Dir.Display_Name));
3620 end if;
3621 end;
3622 end if;
3623 end if;
3624 end if;
3625
3626 pragma Assert (Lib_Version.Kind = Single);
3627
3628 if Lib_Version.Value = Empty_String then
3629 Debug_Output ("no library version specified");
3630
3631 else
3632 Project.Lib_Internal_Name := Lib_Version.Value;
3633 end if;
3634
3635 pragma Assert (The_Lib_Kind.Kind = Single);
3636
3637 if The_Lib_Kind.Value = Empty_String then
3638 Debug_Output ("no library kind specified");
3639
3640 else
3641 Get_Name_String (The_Lib_Kind.Value);
3642
3643 declare
3644 Kind_Name : constant String :=
3645 To_Lower (Name_Buffer (1 .. Name_Len));
3646
3647 OK : Boolean := True;
3648
3649 begin
3650 if Kind_Name = "static" then
3651 Project.Library_Kind := Static;
3652
3653 elsif Kind_Name = "dynamic" then
3654 Project.Library_Kind := Dynamic;
3655
3656 elsif Kind_Name = "relocatable" then
3657 Project.Library_Kind := Relocatable;
3658
3659 else
3660 Error_Msg
3661 (Data.Flags,
3662 "illegal value for Library_Kind",
3663 The_Lib_Kind.Location, Project);
3664 OK := False;
3665 end if;
3666
3667 if Current_Verbosity = High and then OK then
3668 Write_Attr ("Library kind", Kind_Name);
3669 end if;
3670
3671 if Project.Library_Kind /= Static then
3672 if not Project.Externally_Built
3673 and then Support_For_Libraries = Prj.Static_Only
3674 then
3675 Error_Msg
3676 (Data.Flags,
3677 "only static libraries are supported " &
3678 "on this platform",
3679 The_Lib_Kind.Location, Project);
3680 Project.Library := False;
3681
3682 else
3683 -- Check if (obsolescent) attribute Library_GCC or
3684 -- Linker'Driver is declared.
3685
3686 if Lib_GCC.Value /= Empty_String then
3687 Error_Msg
3688 (Data.Flags,
3689 "?Library_'G'C'C is an obsolescent attribute, " &
3690 "use Linker''Driver instead",
3691 Lib_GCC.Location, Project);
3692 Project.Config.Shared_Lib_Driver :=
3693 File_Name_Type (Lib_GCC.Value);
3694
3695 else
3696 declare
3697 Linker : constant Package_Id :=
3698 Value_Of
3699 (Name_Linker,
3700 Project.Decl.Packages,
3701 Shared);
3702 Driver : constant Variable_Value :=
3703 Value_Of
3704 (Name => No_Name,
3705 Attribute_Or_Array_Name =>
3706 Name_Driver,
3707 In_Package => Linker,
3708 Shared => Shared);
3709
3710 begin
3711 if Driver /= Nil_Variable_Value
3712 and then Driver.Value /= Empty_String
3713 then
3714 Project.Config.Shared_Lib_Driver :=
3715 File_Name_Type (Driver.Value);
3716 end if;
3717 end;
3718 end if;
3719 end if;
3720 end if;
3721 end;
3722 end if;
3723
3724 if Project.Library
3725 and then Project.Qualifier /= Aggregate_Library
3726 then
3727 Debug_Output ("this is a library project file");
3728
3729 Check_Library (Project.Extends, Extends => True);
3730
3731 Imported_Project_List := Project.Imported_Projects;
3732 while Imported_Project_List /= null loop
3733 Check_Library
3734 (Imported_Project_List.Project,
3735 Extends => False);
3736 Imported_Project_List := Imported_Project_List.Next;
3737 end loop;
3738 end if;
3739 end if;
3740 end if;
3741
3742 -- Check if Linker'Switches or Linker'Default_Switches are declared.
3743 -- Warn if they are declared, as it is a common error to think that
3744 -- library are "linked" with Linker switches.
3745
3746 if Project.Library then
3747 declare
3748 Linker_Package_Id : constant Package_Id :=
3749 Util.Value_Of
3750 (Name_Linker,
3751 Project.Decl.Packages, Shared);
3752 Linker_Package : Package_Element;
3753 Switches : Array_Element_Id := No_Array_Element;
3754
3755 begin
3756 if Linker_Package_Id /= No_Package then
3757 Linker_Package := Shared.Packages.Table (Linker_Package_Id);
3758
3759 Switches :=
3760 Value_Of
3761 (Name => Name_Switches,
3762 In_Arrays => Linker_Package.Decl.Arrays,
3763 Shared => Shared);
3764
3765 if Switches = No_Array_Element then
3766 Switches :=
3767 Value_Of
3768 (Name => Name_Default_Switches,
3769 In_Arrays => Linker_Package.Decl.Arrays,
3770 Shared => Shared);
3771 end if;
3772
3773 if Switches /= No_Array_Element then
3774 Error_Msg
3775 (Data.Flags,
3776 "?\Linker switches not taken into account in library " &
3777 "projects",
3778 No_Location, Project);
3779 end if;
3780 end if;
3781 end;
3782 end if;
3783
3784 if Project.Extends /= No_Project and then Project.Extends.Library then
3785
3786 -- Remove the library name from Lib_Data_Table
3787
3788 for J in 1 .. Lib_Data_Table.Last loop
3789 if Lib_Data_Table.Table (J).Proj = Project.Extends then
3790 Lib_Data_Table.Table (J) :=
3791 Lib_Data_Table.Table (Lib_Data_Table.Last);
3792 Lib_Data_Table.Set_Last (Lib_Data_Table.Last - 1);
3793 exit;
3794 end if;
3795 end loop;
3796 end if;
3797
3798 if Project.Library and then not Lib_Name.Default then
3799
3800 -- Check if the same library name is used in an other library project
3801
3802 for J in 1 .. Lib_Data_Table.Last loop
3803 if Lib_Data_Table.Table (J).Name = Project.Library_Name
3804 and then Lib_Data_Table.Table (J).Tree = Data.Tree
3805 then
3806 Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name;
3807 Error_Msg
3808 (Data.Flags,
3809 "Library name cannot be the same as in project %%",
3810 Lib_Name.Location, Project);
3811 Project.Library := False;
3812 exit;
3813 end if;
3814 end loop;
3815 end if;
3816
3817 if not Lib_Standalone.Default
3818 and then Project.Library_Kind = Static
3819 then
3820 -- An standalone library must be a shared library
3821
3822 Error_Msg_Name_1 := Project.Name;
3823
3824 Error_Msg
3825 (Data.Flags,
3826 Continuation.all &
3827 "standalone library project %% must be a shared library",
3828 Project.Location, Project);
3829 Continuation := Continuation_String'Access;
3830 end if;
3831
3832 -- Check that aggregated libraries do not share the aggregate
3833 -- Library_ALI_Dir.
3834
3835 if Project.Qualifier = Aggregate_Library then
3836 Check_Aggregate_Library_Dirs;
3837 end if;
3838
3839 if Project.Library and not Data.In_Aggregate_Lib then
3840
3841 -- Record the library name
3842
3843 Lib_Data_Table.Append
3844 ((Name => Project.Library_Name,
3845 Proj => Project,
3846 Tree => Data.Tree));
3847 end if;
3848 end Check_Library_Attributes;
3849
3850 --------------------------
3851 -- Check_Package_Naming --
3852 --------------------------
3853
3854 procedure Check_Package_Naming
3855 (Project : Project_Id;
3856 Data : in out Tree_Processing_Data)
3857 is
3858 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
3859 Naming_Id : constant Package_Id :=
3860 Util.Value_Of
3861 (Name_Naming, Project.Decl.Packages, Shared);
3862 Naming : Package_Element;
3863
3864 Ada_Body_Suffix_Loc : Source_Ptr := No_Location;
3865
3866 procedure Check_Naming;
3867 -- Check the validity of the Naming package (suffixes valid, ...)
3868
3869 procedure Check_Common
3870 (Dot_Replacement : in out File_Name_Type;
3871 Casing : in out Casing_Type;
3872 Casing_Defined : out Boolean;
3873 Separate_Suffix : in out File_Name_Type;
3874 Sep_Suffix_Loc : out Source_Ptr);
3875 -- Check attributes common
3876
3877 procedure Process_Exceptions_File_Based
3878 (Lang_Id : Language_Ptr;
3879 Kind : Source_Kind);
3880 procedure Process_Exceptions_Unit_Based
3881 (Lang_Id : Language_Ptr;
3882 Kind : Source_Kind);
3883 -- Process the naming exceptions for the two types of languages
3884
3885 procedure Initialize_Naming_Data;
3886 -- Initialize internal naming data for the various languages
3887
3888 ------------------
3889 -- Check_Common --
3890 ------------------
3891
3892 procedure Check_Common
3893 (Dot_Replacement : in out File_Name_Type;
3894 Casing : in out Casing_Type;
3895 Casing_Defined : out Boolean;
3896 Separate_Suffix : in out File_Name_Type;
3897 Sep_Suffix_Loc : out Source_Ptr)
3898 is
3899 Dot_Repl : constant Variable_Value :=
3900 Util.Value_Of
3901 (Name_Dot_Replacement,
3902 Naming.Decl.Attributes,
3903 Shared);
3904 Casing_String : constant Variable_Value :=
3905 Util.Value_Of
3906 (Name_Casing,
3907 Naming.Decl.Attributes,
3908 Shared);
3909 Sep_Suffix : constant Variable_Value :=
3910 Util.Value_Of
3911 (Name_Separate_Suffix,
3912 Naming.Decl.Attributes,
3913 Shared);
3914 Dot_Repl_Loc : Source_Ptr;
3915
3916 begin
3917 Sep_Suffix_Loc := No_Location;
3918
3919 if not Dot_Repl.Default then
3920 pragma Assert
3921 (Dot_Repl.Kind = Single, "Dot_Replacement is not a string");
3922
3923 if Length_Of_Name (Dot_Repl.Value) = 0 then
3924 Error_Msg
3925 (Data.Flags, "Dot_Replacement cannot be empty",
3926 Dot_Repl.Location, Project);
3927 end if;
3928
3929 Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value);
3930 Dot_Repl_Loc := Dot_Repl.Location;
3931
3932 declare
3933 Repl : constant String := Get_Name_String (Dot_Replacement);
3934
3935 begin
3936 -- Dot_Replacement cannot
3937 -- - be empty
3938 -- - start or end with an alphanumeric
3939 -- - be a single '_'
3940 -- - start with an '_' followed by an alphanumeric
3941 -- - contain a '.' except if it is "."
3942
3943 if Repl'Length = 0
3944 or else Is_Alphanumeric (Repl (Repl'First))
3945 or else Is_Alphanumeric (Repl (Repl'Last))
3946 or else (Repl (Repl'First) = '_'
3947 and then
3948 (Repl'Length = 1
3949 or else
3950 Is_Alphanumeric (Repl (Repl'First + 1))))
3951 or else (Repl'Length > 1
3952 and then
3953 Index (Source => Repl, Pattern => ".") /= 0)
3954 then
3955 Error_Msg
3956 (Data.Flags,
3957 '"' & Repl &
3958 """ is illegal for Dot_Replacement.",
3959 Dot_Repl_Loc, Project);
3960 end if;
3961 end;
3962 end if;
3963
3964 if Dot_Replacement /= No_File then
3965 Write_Attr
3966 ("Dot_Replacement", Get_Name_String (Dot_Replacement));
3967 end if;
3968
3969 Casing_Defined := False;
3970
3971 if not Casing_String.Default then
3972 pragma Assert
3973 (Casing_String.Kind = Single, "Casing is not a string");
3974
3975 declare
3976 Casing_Image : constant String :=
3977 Get_Name_String (Casing_String.Value);
3978
3979 begin
3980 if Casing_Image'Length = 0 then
3981 Error_Msg
3982 (Data.Flags,
3983 "Casing cannot be an empty string",
3984 Casing_String.Location, Project);
3985 end if;
3986
3987 Casing := Value (Casing_Image);
3988 Casing_Defined := True;
3989
3990 exception
3991 when Constraint_Error =>
3992 Name_Len := Casing_Image'Length;
3993 Name_Buffer (1 .. Name_Len) := Casing_Image;
3994 Err_Vars.Error_Msg_Name_1 := Name_Find;
3995 Error_Msg
3996 (Data.Flags,
3997 "%% is not a correct Casing",
3998 Casing_String.Location, Project);
3999 end;
4000 end if;
4001
4002 Write_Attr ("Casing", Image (Casing));
4003
4004 if not Sep_Suffix.Default then
4005 if Length_Of_Name (Sep_Suffix.Value) = 0 then
4006 Error_Msg
4007 (Data.Flags,
4008 "Separate_Suffix cannot be empty",
4009 Sep_Suffix.Location, Project);
4010
4011 else
4012 Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value);
4013 Sep_Suffix_Loc := Sep_Suffix.Location;
4014
4015 Check_Illegal_Suffix
4016 (Project, Separate_Suffix,
4017 Dot_Replacement, "Separate_Suffix", Sep_Suffix.Location,
4018 Data);
4019 end if;
4020 end if;
4021
4022 if Separate_Suffix /= No_File then
4023 Write_Attr
4024 ("Separate_Suffix", Get_Name_String (Separate_Suffix));
4025 end if;
4026 end Check_Common;
4027
4028 -----------------------------------
4029 -- Process_Exceptions_File_Based --
4030 -----------------------------------
4031
4032 procedure Process_Exceptions_File_Based
4033 (Lang_Id : Language_Ptr;
4034 Kind : Source_Kind)
4035 is
4036 Lang : constant Name_Id := Lang_Id.Name;
4037 Exceptions : Array_Element_Id;
4038 Exception_List : Variable_Value;
4039 Element_Id : String_List_Id;
4040 Element : String_Element;
4041 File_Name : File_Name_Type;
4042 Source : Source_Id;
4043
4044 begin
4045 case Kind is
4046 when Impl | Sep =>
4047 Exceptions :=
4048 Value_Of
4049 (Name_Implementation_Exceptions,
4050 In_Arrays => Naming.Decl.Arrays,
4051 Shared => Shared);
4052
4053 when Spec =>
4054 Exceptions :=
4055 Value_Of
4056 (Name_Specification_Exceptions,
4057 In_Arrays => Naming.Decl.Arrays,
4058 Shared => Shared);
4059 end case;
4060
4061 Exception_List :=
4062 Value_Of
4063 (Index => Lang,
4064 In_Array => Exceptions,
4065 Shared => Shared);
4066
4067 if Exception_List /= Nil_Variable_Value then
4068 Element_Id := Exception_List.Values;
4069 while Element_Id /= Nil_String loop
4070 Element := Shared.String_Elements.Table (Element_Id);
4071 File_Name := Canonical_Case_File_Name (Element.Value);
4072
4073 Source :=
4074 Source_Files_Htable.Get
4075 (Data.Tree.Source_Files_HT, File_Name);
4076 while Source /= No_Source
4077 and then Source.Project /= Project
4078 loop
4079 Source := Source.Next_With_File_Name;
4080 end loop;
4081
4082 if Source = No_Source then
4083 Add_Source
4084 (Id => Source,
4085 Data => Data,
4086 Project => Project,
4087 Source_Dir_Rank => 0,
4088 Lang_Id => Lang_Id,
4089 Kind => Kind,
4090 File_Name => File_Name,
4091 Display_File => File_Name_Type (Element.Value),
4092 Naming_Exception => Yes,
4093 Location => Element.Location);
4094
4095 else
4096 -- Check if the file name is already recorded for another
4097 -- language or another kind.
4098
4099 if Source.Language /= Lang_Id then
4100 Error_Msg
4101 (Data.Flags,
4102 "the same file cannot be a source of two languages",
4103 Element.Location, Project);
4104
4105 elsif Source.Kind /= Kind then
4106 Error_Msg
4107 (Data.Flags,
4108 "the same file cannot be a source and a template",
4109 Element.Location, Project);
4110 end if;
4111
4112 -- If the file is already recorded for the same
4113 -- language and the same kind, it means that the file
4114 -- name appears several times in the *_Exceptions
4115 -- attribute; so there is nothing to do.
4116 end if;
4117
4118 Element_Id := Element.Next;
4119 end loop;
4120 end if;
4121 end Process_Exceptions_File_Based;
4122
4123 -----------------------------------
4124 -- Process_Exceptions_Unit_Based --
4125 -----------------------------------
4126
4127 procedure Process_Exceptions_Unit_Based
4128 (Lang_Id : Language_Ptr;
4129 Kind : Source_Kind)
4130 is
4131 Exceptions : Array_Element_Id;
4132 Element : Array_Element;
4133 Unit : Name_Id;
4134 Index : Int;
4135 File_Name : File_Name_Type;
4136 Source : Source_Id;
4137
4138 Naming_Exception : Naming_Exception_Type;
4139
4140 begin
4141 case Kind is
4142 when Impl | Sep =>
4143 Exceptions :=
4144 Value_Of
4145 (Name_Body,
4146 In_Arrays => Naming.Decl.Arrays,
4147 Shared => Shared);
4148
4149 if Exceptions = No_Array_Element then
4150 Exceptions :=
4151 Value_Of
4152 (Name_Implementation,
4153 In_Arrays => Naming.Decl.Arrays,
4154 Shared => Shared);
4155 end if;
4156
4157 when Spec =>
4158 Exceptions :=
4159 Value_Of
4160 (Name_Spec,
4161 In_Arrays => Naming.Decl.Arrays,
4162 Shared => Shared);
4163
4164 if Exceptions = No_Array_Element then
4165 Exceptions :=
4166 Value_Of
4167 (Name_Specification,
4168 In_Arrays => Naming.Decl.Arrays,
4169 Shared => Shared);
4170 end if;
4171 end case;
4172
4173 while Exceptions /= No_Array_Element loop
4174 Element := Shared.Array_Elements.Table (Exceptions);
4175
4176 if Element.Restricted then
4177 Naming_Exception := Inherited;
4178 else
4179 Naming_Exception := Yes;
4180 end if;
4181
4182 File_Name := Canonical_Case_File_Name (Element.Value.Value);
4183
4184 Get_Name_String (Element.Index);
4185 To_Lower (Name_Buffer (1 .. Name_Len));
4186 Index := Element.Value.Index;
4187
4188 -- Check if it is a valid unit name
4189
4190 Get_Name_String (Element.Index);
4191 Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit);
4192
4193 if Unit = No_Name then
4194 Err_Vars.Error_Msg_Name_1 := Element.Index;
4195 Error_Msg
4196 (Data.Flags,
4197 "%% is not a valid unit name.",
4198 Element.Value.Location, Project);
4199 end if;
4200
4201 if Unit /= No_Name then
4202 Add_Source
4203 (Id => Source,
4204 Data => Data,
4205 Project => Project,
4206 Source_Dir_Rank => 0,
4207 Lang_Id => Lang_Id,
4208 Kind => Kind,
4209 File_Name => File_Name,
4210 Display_File => File_Name_Type (Element.Value.Value),
4211 Unit => Unit,
4212 Index => Index,
4213 Location => Element.Value.Location,
4214 Naming_Exception => Naming_Exception);
4215 end if;
4216
4217 Exceptions := Element.Next;
4218 end loop;
4219 end Process_Exceptions_Unit_Based;
4220
4221 ------------------
4222 -- Check_Naming --
4223 ------------------
4224
4225 procedure Check_Naming is
4226 Dot_Replacement : File_Name_Type :=
4227 File_Name_Type
4228 (First_Name_Id + Character'Pos ('-'));
4229 Separate_Suffix : File_Name_Type := No_File;
4230 Casing : Casing_Type := All_Lower_Case;
4231 Casing_Defined : Boolean;
4232 Lang_Id : Language_Ptr;
4233 Sep_Suffix_Loc : Source_Ptr;
4234 Suffix : Variable_Value;
4235 Lang : Name_Id;
4236
4237 begin
4238 Check_Common
4239 (Dot_Replacement => Dot_Replacement,
4240 Casing => Casing,
4241 Casing_Defined => Casing_Defined,
4242 Separate_Suffix => Separate_Suffix,
4243 Sep_Suffix_Loc => Sep_Suffix_Loc);
4244
4245 -- For all unit based languages, if any, set the specified value
4246 -- of Dot_Replacement, Casing and/or Separate_Suffix. Do not
4247 -- systematically overwrite, since the defaults come from the
4248 -- configuration file.
4249
4250 if Dot_Replacement /= No_File
4251 or else Casing_Defined
4252 or else Separate_Suffix /= No_File
4253 then
4254 Lang_Id := Project.Languages;
4255 while Lang_Id /= No_Language_Index loop
4256 if Lang_Id.Config.Kind = Unit_Based then
4257 if Dot_Replacement /= No_File then
4258 Lang_Id.Config.Naming_Data.Dot_Replacement :=
4259 Dot_Replacement;
4260 end if;
4261
4262 if Casing_Defined then
4263 Lang_Id.Config.Naming_Data.Casing := Casing;
4264 end if;
4265 end if;
4266
4267 Lang_Id := Lang_Id.Next;
4268 end loop;
4269 end if;
4270
4271 -- Next, get the spec and body suffixes
4272
4273 Lang_Id := Project.Languages;
4274 while Lang_Id /= No_Language_Index loop
4275 Lang := Lang_Id.Name;
4276
4277 -- Spec_Suffix
4278
4279 Suffix := Value_Of
4280 (Name => Lang,
4281 Attribute_Or_Array_Name => Name_Spec_Suffix,
4282 In_Package => Naming_Id,
4283 Shared => Shared);
4284
4285 if Suffix = Nil_Variable_Value then
4286 Suffix := Value_Of
4287 (Name => Lang,
4288 Attribute_Or_Array_Name => Name_Specification_Suffix,
4289 In_Package => Naming_Id,
4290 Shared => Shared);
4291 end if;
4292
4293 if Suffix /= Nil_Variable_Value
4294 and then Suffix.Value /= No_Name
4295 then
4296 Lang_Id.Config.Naming_Data.Spec_Suffix :=
4297 File_Name_Type (Suffix.Value);
4298
4299 Check_Illegal_Suffix
4300 (Project,
4301 Lang_Id.Config.Naming_Data.Spec_Suffix,
4302 Lang_Id.Config.Naming_Data.Dot_Replacement,
4303 "Spec_Suffix", Suffix.Location, Data);
4304
4305 Write_Attr
4306 ("Spec_Suffix",
4307 Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix));
4308 end if;
4309
4310 -- Body_Suffix
4311
4312 Suffix :=
4313 Value_Of
4314 (Name => Lang,
4315 Attribute_Or_Array_Name => Name_Body_Suffix,
4316 In_Package => Naming_Id,
4317 Shared => Shared);
4318
4319 if Suffix = Nil_Variable_Value then
4320 Suffix :=
4321 Value_Of
4322 (Name => Lang,
4323 Attribute_Or_Array_Name => Name_Implementation_Suffix,
4324 In_Package => Naming_Id,
4325 Shared => Shared);
4326 end if;
4327
4328 if Suffix /= Nil_Variable_Value
4329 and then Suffix.Value /= No_Name
4330 then
4331 Lang_Id.Config.Naming_Data.Body_Suffix :=
4332 File_Name_Type (Suffix.Value);
4333
4334 -- The default value of separate suffix should be the same as
4335 -- the body suffix, so we need to compute that first.
4336
4337 if Separate_Suffix = No_File then
4338 Lang_Id.Config.Naming_Data.Separate_Suffix :=
4339 Lang_Id.Config.Naming_Data.Body_Suffix;
4340 Write_Attr
4341 ("Sep_Suffix",
4342 Get_Name_String
4343 (Lang_Id.Config.Naming_Data.Separate_Suffix));
4344 else
4345 Lang_Id.Config.Naming_Data.Separate_Suffix :=
4346 Separate_Suffix;
4347 end if;
4348
4349 Check_Illegal_Suffix
4350 (Project,
4351 Lang_Id.Config.Naming_Data.Body_Suffix,
4352 Lang_Id.Config.Naming_Data.Dot_Replacement,
4353 "Body_Suffix", Suffix.Location, Data);
4354
4355 Write_Attr
4356 ("Body_Suffix",
4357 Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix));
4358
4359 elsif Separate_Suffix /= No_File then
4360 Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix;
4361 end if;
4362
4363 -- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix,
4364 -- since that would cause a clear ambiguity. Note that we do allow
4365 -- a Spec_Suffix to have the same termination as one of these,
4366 -- which causes a potential ambiguity, but we resolve that by
4367 -- matching the longest possible suffix.
4368
4369 if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File
4370 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
4371 Lang_Id.Config.Naming_Data.Body_Suffix
4372 then
4373 Error_Msg
4374 (Data.Flags,
4375 "Body_Suffix ("""
4376 & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)
4377 & """) cannot be the same as Spec_Suffix.",
4378 Ada_Body_Suffix_Loc, Project);
4379 end if;
4380
4381 if Lang_Id.Config.Naming_Data.Body_Suffix /=
4382 Lang_Id.Config.Naming_Data.Separate_Suffix
4383 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
4384 Lang_Id.Config.Naming_Data.Separate_Suffix
4385 then
4386 Error_Msg
4387 (Data.Flags,
4388 "Separate_Suffix ("""
4389 & Get_Name_String
4390 (Lang_Id.Config.Naming_Data.Separate_Suffix)
4391 & """) cannot be the same as Spec_Suffix.",
4392 Sep_Suffix_Loc, Project);
4393 end if;
4394
4395 Lang_Id := Lang_Id.Next;
4396 end loop;
4397
4398 -- Get the naming exceptions for all languages, but not for virtual
4399 -- projects.
4400
4401 if not Project.Virtual then
4402 for Kind in Spec_Or_Body loop
4403 Lang_Id := Project.Languages;
4404 while Lang_Id /= No_Language_Index loop
4405 case Lang_Id.Config.Kind is
4406 when File_Based =>
4407 Process_Exceptions_File_Based (Lang_Id, Kind);
4408
4409 when Unit_Based =>
4410 Process_Exceptions_Unit_Based (Lang_Id, Kind);
4411 end case;
4412
4413 Lang_Id := Lang_Id.Next;
4414 end loop;
4415 end loop;
4416 end if;
4417 end Check_Naming;
4418
4419 ----------------------------
4420 -- Initialize_Naming_Data --
4421 ----------------------------
4422
4423 procedure Initialize_Naming_Data is
4424 Specs : Array_Element_Id :=
4425 Util.Value_Of
4426 (Name_Spec_Suffix,
4427 Naming.Decl.Arrays,
4428 Shared);
4429
4430 Impls : Array_Element_Id :=
4431 Util.Value_Of
4432 (Name_Body_Suffix,
4433 Naming.Decl.Arrays,
4434 Shared);
4435
4436 Lang : Language_Ptr;
4437 Lang_Name : Name_Id;
4438 Value : Variable_Value;
4439 Extended : Project_Id;
4440
4441 begin
4442 -- At this stage, the project already contains the default extensions
4443 -- for the various languages. We now merge those suffixes read in the
4444 -- user project, and they override the default.
4445
4446 while Specs /= No_Array_Element loop
4447 Lang_Name := Shared.Array_Elements.Table (Specs).Index;
4448 Lang :=
4449 Get_Language_From_Name
4450 (Project, Name => Get_Name_String (Lang_Name));
4451
4452 -- An extending project inherits its parent projects' languages
4453 -- so if needed we should create entries for those languages
4454
4455 if Lang = null then
4456 Extended := Project.Extends;
4457 while Extended /= null loop
4458 Lang := Get_Language_From_Name
4459 (Extended, Name => Get_Name_String (Lang_Name));
4460 exit when Lang /= null;
4461
4462 Extended := Extended.Extends;
4463 end loop;
4464
4465 if Lang /= null then
4466 Lang := new Language_Data'(Lang.all);
4467 Lang.First_Source := null;
4468 Lang.Next := Project.Languages;
4469 Project.Languages := Lang;
4470 end if;
4471 end if;
4472
4473 -- If language was not found in project or the projects it extends
4474
4475 if Lang = null then
4476 Debug_Output
4477 ("ignoring spec naming data (lang. not in project): ",
4478 Lang_Name);
4479
4480 else
4481 Value := Shared.Array_Elements.Table (Specs).Value;
4482
4483 if Value.Kind = Single then
4484 Lang.Config.Naming_Data.Spec_Suffix :=
4485 Canonical_Case_File_Name (Value.Value);
4486 end if;
4487 end if;
4488
4489 Specs := Shared.Array_Elements.Table (Specs).Next;
4490 end loop;
4491
4492 while Impls /= No_Array_Element loop
4493 Lang_Name := Shared.Array_Elements.Table (Impls).Index;
4494 Lang :=
4495 Get_Language_From_Name
4496 (Project, Name => Get_Name_String (Lang_Name));
4497
4498 if Lang = null then
4499 Debug_Output
4500 ("ignoring impl naming data (lang. not in project): ",
4501 Lang_Name);
4502 else
4503 Value := Shared.Array_Elements.Table (Impls).Value;
4504
4505 if Lang.Name = Name_Ada then
4506 Ada_Body_Suffix_Loc := Value.Location;
4507 end if;
4508
4509 if Value.Kind = Single then
4510 Lang.Config.Naming_Data.Body_Suffix :=
4511 Canonical_Case_File_Name (Value.Value);
4512 end if;
4513 end if;
4514
4515 Impls := Shared.Array_Elements.Table (Impls).Next;
4516 end loop;
4517 end Initialize_Naming_Data;
4518
4519 -- Start of processing for Check_Naming_Schemes
4520
4521 begin
4522 -- No Naming package or parsing a configuration file? nothing to do
4523
4524 if Naming_Id /= No_Package
4525 and then Project.Qualifier /= Configuration
4526 then
4527 Naming := Shared.Packages.Table (Naming_Id);
4528 Debug_Increase_Indent ("checking package Naming for ", Project.Name);
4529 Initialize_Naming_Data;
4530 Check_Naming;
4531 Debug_Decrease_Indent ("done checking package naming");
4532 end if;
4533 end Check_Package_Naming;
4534
4535 ---------------------------------
4536 -- Check_Programming_Languages --
4537 ---------------------------------
4538
4539 procedure Check_Programming_Languages
4540 (Project : Project_Id;
4541 Data : in out Tree_Processing_Data)
4542 is
4543 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
4544
4545 Languages : Variable_Value := Nil_Variable_Value;
4546 Def_Lang : Variable_Value := Nil_Variable_Value;
4547 Def_Lang_Id : Name_Id;
4548
4549 procedure Add_Language (Name, Display_Name : Name_Id);
4550 -- Add a new language to the list of languages for the project.
4551 -- Nothing is done if the language has already been defined
4552
4553 ------------------
4554 -- Add_Language --
4555 ------------------
4556
4557 procedure Add_Language (Name, Display_Name : Name_Id) is
4558 Lang : Language_Ptr;
4559
4560 begin
4561 Lang := Project.Languages;
4562 while Lang /= No_Language_Index loop
4563 if Name = Lang.Name then
4564 return;
4565 end if;
4566
4567 Lang := Lang.Next;
4568 end loop;
4569
4570 Lang := new Language_Data'(No_Language_Data);
4571 Lang.Next := Project.Languages;
4572 Project.Languages := Lang;
4573 Lang.Name := Name;
4574 Lang.Display_Name := Display_Name;
4575 end Add_Language;
4576
4577 -- Start of processing for Check_Programming_Languages
4578
4579 begin
4580 Project.Languages := null;
4581 Languages :=
4582 Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, Shared);
4583 Def_Lang :=
4584 Prj.Util.Value_Of
4585 (Name_Default_Language, Project.Decl.Attributes, Shared);
4586
4587 if Project.Source_Dirs /= Nil_String then
4588
4589 -- Check if languages are specified in this project
4590
4591 if Languages.Default then
4592
4593 -- Fail if there is no default language defined
4594
4595 if Def_Lang.Default then
4596 Error_Msg
4597 (Data.Flags,
4598 "no languages defined for this project",
4599 Project.Location, Project);
4600 Def_Lang_Id := No_Name;
4601
4602 else
4603 Get_Name_String (Def_Lang.Value);
4604 To_Lower (Name_Buffer (1 .. Name_Len));
4605 Def_Lang_Id := Name_Find;
4606 end if;
4607
4608 if Def_Lang_Id /= No_Name then
4609 Get_Name_String (Def_Lang_Id);
4610 Name_Buffer (1) := GNAT.Case_Util.To_Upper (Name_Buffer (1));
4611 Add_Language
4612 (Name => Def_Lang_Id,
4613 Display_Name => Name_Find);
4614 end if;
4615
4616 else
4617 declare
4618 Current : String_List_Id := Languages.Values;
4619 Element : String_Element;
4620
4621 begin
4622 -- If there are no languages declared, there are no sources
4623
4624 if Current = Nil_String then
4625 Project.Source_Dirs := Nil_String;
4626
4627 if Project.Qualifier = Standard then
4628 Error_Msg
4629 (Data.Flags,
4630 "a standard project must have at least one language",
4631 Languages.Location, Project);
4632 end if;
4633
4634 else
4635 -- Look through all the languages specified in attribute
4636 -- Languages.
4637
4638 while Current /= Nil_String loop
4639 Element := Shared.String_Elements.Table (Current);
4640 Get_Name_String (Element.Value);
4641 To_Lower (Name_Buffer (1 .. Name_Len));
4642
4643 Add_Language
4644 (Name => Name_Find,
4645 Display_Name => Element.Value);
4646
4647 Current := Element.Next;
4648 end loop;
4649 end if;
4650 end;
4651 end if;
4652 end if;
4653 end Check_Programming_Languages;
4654
4655 -------------------------------
4656 -- Check_Stand_Alone_Library --
4657 -------------------------------
4658
4659 procedure Check_Stand_Alone_Library
4660 (Project : Project_Id;
4661 Data : in out Tree_Processing_Data)
4662 is
4663 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
4664
4665 Lib_Name : constant Prj.Variable_Value :=
4666 Prj.Util.Value_Of
4667 (Snames.Name_Library_Name,
4668 Project.Decl.Attributes,
4669 Shared);
4670
4671 Lib_Standalone : constant Prj.Variable_Value :=
4672 Prj.Util.Value_Of
4673 (Snames.Name_Library_Standalone,
4674 Project.Decl.Attributes,
4675 Shared);
4676
4677 Lib_Auto_Init : constant Prj.Variable_Value :=
4678 Prj.Util.Value_Of
4679 (Snames.Name_Library_Auto_Init,
4680 Project.Decl.Attributes,
4681 Shared);
4682
4683 Lib_Src_Dir : constant Prj.Variable_Value :=
4684 Prj.Util.Value_Of
4685 (Snames.Name_Library_Src_Dir,
4686 Project.Decl.Attributes,
4687 Shared);
4688
4689 Lib_Symbol_File : constant Prj.Variable_Value :=
4690 Prj.Util.Value_Of
4691 (Snames.Name_Library_Symbol_File,
4692 Project.Decl.Attributes,
4693 Shared);
4694
4695 Lib_Symbol_Policy : constant Prj.Variable_Value :=
4696 Prj.Util.Value_Of
4697 (Snames.Name_Library_Symbol_Policy,
4698 Project.Decl.Attributes,
4699 Shared);
4700
4701 Lib_Ref_Symbol_File : constant Prj.Variable_Value :=
4702 Prj.Util.Value_Of
4703 (Snames.Name_Library_Reference_Symbol_File,
4704 Project.Decl.Attributes,
4705 Shared);
4706
4707 Auto_Init_Supported : Boolean;
4708 OK : Boolean := True;
4709
4710 begin
4711 Auto_Init_Supported := Project.Config.Auto_Init_Supported;
4712
4713 -- It is a stand-alone library project file if there is at least one
4714 -- unit in the declared or inherited interface.
4715
4716 if Project.Lib_Interface_ALIs = Nil_String then
4717 if not Lib_Standalone.Default
4718 and then Get_Name_String (Lib_Standalone.Value) /= "no"
4719 then
4720 Error_Msg
4721 (Data.Flags,
4722 "Library_Standalone valid only if library has Ada interfaces",
4723 Lib_Standalone.Location, Project);
4724 end if;
4725
4726 else
4727 if Project.Standalone_Library = No then
4728 Project.Standalone_Library := Standard;
4729 end if;
4730
4731 -- The name of a stand-alone library needs to have the syntax of an
4732 -- Ada identifier.
4733
4734 declare
4735 Name : constant String := Get_Name_String (Project.Library_Name);
4736 OK : Boolean := Is_Letter (Name (Name'First));
4737
4738 Underline : Boolean := False;
4739
4740 begin
4741 for J in Name'First + 1 .. Name'Last loop
4742 exit when not OK;
4743
4744 if Is_Alphanumeric (Name (J)) then
4745 Underline := False;
4746
4747 elsif Name (J) = '_' then
4748 if Underline then
4749 OK := False;
4750 else
4751 Underline := True;
4752 end if;
4753
4754 else
4755 OK := False;
4756 end if;
4757 end loop;
4758
4759 OK := OK and not Underline;
4760
4761 if not OK then
4762 Error_Msg
4763 (Data.Flags,
4764 "Incorrect library name for a Stand-Alone Library",
4765 Lib_Name.Location, Project);
4766 return;
4767 end if;
4768 end;
4769
4770 if Lib_Standalone.Default then
4771 Project.Standalone_Library := Standard;
4772
4773 else
4774 Get_Name_String (Lib_Standalone.Value);
4775 To_Lower (Name_Buffer (1 .. Name_Len));
4776
4777 if Name_Buffer (1 .. Name_Len) = "standard" then
4778 Project.Standalone_Library := Standard;
4779
4780 elsif Name_Buffer (1 .. Name_Len) = "encapsulated" then
4781 Project.Standalone_Library := Encapsulated;
4782
4783 elsif Name_Buffer (1 .. Name_Len) = "no" then
4784 Project.Standalone_Library := No;
4785 Error_Msg
4786 (Data.Flags,
4787 "wrong value for Library_Standalone "
4788 & "when Library_Interface defined",
4789 Lib_Standalone.Location, Project);
4790
4791 else
4792 Error_Msg
4793 (Data.Flags,
4794 "invalid value for attribute Library_Standalone",
4795 Lib_Standalone.Location, Project);
4796 end if;
4797 end if;
4798
4799 -- Check value of attribute Library_Auto_Init and set Lib_Auto_Init
4800 -- accordingly.
4801
4802 if Lib_Auto_Init.Default then
4803
4804 -- If no attribute Library_Auto_Init is declared, then set auto
4805 -- init only if it is supported.
4806
4807 Project.Lib_Auto_Init := Auto_Init_Supported;
4808
4809 else
4810 Get_Name_String (Lib_Auto_Init.Value);
4811 To_Lower (Name_Buffer (1 .. Name_Len));
4812
4813 if Name_Buffer (1 .. Name_Len) = "false" then
4814 Project.Lib_Auto_Init := False;
4815
4816 elsif Name_Buffer (1 .. Name_Len) = "true" then
4817 if Auto_Init_Supported then
4818 Project.Lib_Auto_Init := True;
4819
4820 else
4821 -- Library_Auto_Init cannot be "true" if auto init is not
4822 -- supported.
4823
4824 Error_Msg
4825 (Data.Flags,
4826 "library auto init not supported " &
4827 "on this platform",
4828 Lib_Auto_Init.Location, Project);
4829 end if;
4830
4831 else
4832 Error_Msg
4833 (Data.Flags,
4834 "invalid value for attribute Library_Auto_Init",
4835 Lib_Auto_Init.Location, Project);
4836 end if;
4837 end if;
4838
4839 -- If attribute Library_Src_Dir is defined and not the empty string,
4840 -- check if the directory exist and is not the object directory or
4841 -- one of the source directories. This is the directory where copies
4842 -- of the interface sources will be copied. Note that this directory
4843 -- may be the library directory.
4844
4845 if Lib_Src_Dir.Value /= Empty_String then
4846 declare
4847 Dir_Id : constant File_Name_Type :=
4848 File_Name_Type (Lib_Src_Dir.Value);
4849 Dir_Exists : Boolean;
4850
4851 begin
4852 Locate_Directory
4853 (Project,
4854 Dir_Id,
4855 Path => Project.Library_Src_Dir,
4856 Dir_Exists => Dir_Exists,
4857 Data => Data,
4858 Must_Exist => False,
4859 Create => "library source copy",
4860 Location => Lib_Src_Dir.Location,
4861 Externally_Built => Project.Externally_Built);
4862
4863 -- If directory does not exist, report an error
4864
4865 if not Dir_Exists then
4866
4867 -- Get the absolute name of the library directory that does
4868 -- not exist, to report an error.
4869
4870 Err_Vars.Error_Msg_File_1 :=
4871 File_Name_Type (Project.Library_Src_Dir.Display_Name);
4872 Error_Msg
4873 (Data.Flags,
4874 "Directory { does not exist",
4875 Lib_Src_Dir.Location, Project);
4876
4877 -- Report error if it is the same as the object directory
4878
4879 elsif Project.Library_Src_Dir = Project.Object_Directory then
4880 Error_Msg
4881 (Data.Flags,
4882 "directory to copy interfaces cannot be " &
4883 "the object directory",
4884 Lib_Src_Dir.Location, Project);
4885 Project.Library_Src_Dir := No_Path_Information;
4886
4887 else
4888 declare
4889 Src_Dirs : String_List_Id;
4890 Src_Dir : String_Element;
4891 Pid : Project_List;
4892
4893 begin
4894 -- Interface copy directory cannot be one of the source
4895 -- directory of the current project.
4896
4897 Src_Dirs := Project.Source_Dirs;
4898 while Src_Dirs /= Nil_String loop
4899 Src_Dir := Shared.String_Elements.Table (Src_Dirs);
4900
4901 -- Report error if it is one of the source directories
4902
4903 if Project.Library_Src_Dir.Name =
4904 Path_Name_Type (Src_Dir.Value)
4905 then
4906 Error_Msg
4907 (Data.Flags,
4908 "directory to copy interfaces cannot " &
4909 "be one of the source directories",
4910 Lib_Src_Dir.Location, Project);
4911 Project.Library_Src_Dir := No_Path_Information;
4912 exit;
4913 end if;
4914
4915 Src_Dirs := Src_Dir.Next;
4916 end loop;
4917
4918 if Project.Library_Src_Dir /= No_Path_Information then
4919
4920 -- It cannot be a source directory of any other
4921 -- project either.
4922
4923 Pid := Data.Tree.Projects;
4924 Project_Loop : loop
4925 exit Project_Loop when Pid = null;
4926
4927 Src_Dirs := Pid.Project.Source_Dirs;
4928 Dir_Loop : while Src_Dirs /= Nil_String loop
4929 Src_Dir :=
4930 Shared.String_Elements.Table (Src_Dirs);
4931
4932 -- Report error if it is one of the source
4933 -- directories.
4934
4935 if Project.Library_Src_Dir.Name =
4936 Path_Name_Type (Src_Dir.Value)
4937 then
4938 Error_Msg_File_1 :=
4939 File_Name_Type (Src_Dir.Value);
4940 Error_Msg_Name_1 := Pid.Project.Name;
4941 Error_Msg
4942 (Data.Flags,
4943 "directory to copy interfaces cannot " &
4944 "be the same as source directory { of " &
4945 "project %%",
4946 Lib_Src_Dir.Location, Project);
4947 Project.Library_Src_Dir :=
4948 No_Path_Information;
4949 exit Project_Loop;
4950 end if;
4951
4952 Src_Dirs := Src_Dir.Next;
4953 end loop Dir_Loop;
4954
4955 Pid := Pid.Next;
4956 end loop Project_Loop;
4957 end if;
4958 end;
4959
4960 -- In high verbosity, if there is a valid Library_Src_Dir,
4961 -- display its path name.
4962
4963 if Project.Library_Src_Dir /= No_Path_Information
4964 and then Current_Verbosity = High
4965 then
4966 Write_Attr
4967 ("Directory to copy interfaces",
4968 Get_Name_String (Project.Library_Src_Dir.Name));
4969 end if;
4970 end if;
4971 end;
4972 end if;
4973
4974 -- Check the symbol related attributes
4975
4976 -- First, the symbol policy
4977
4978 if not Lib_Symbol_Policy.Default then
4979 declare
4980 Value : constant String :=
4981 To_Lower
4982 (Get_Name_String (Lib_Symbol_Policy.Value));
4983
4984 begin
4985 -- Symbol policy must have one of a limited number of values
4986
4987 if Value = "autonomous" or else Value = "default" then
4988 Project.Symbol_Data.Symbol_Policy := Autonomous;
4989
4990 elsif Value = "compliant" then
4991 Project.Symbol_Data.Symbol_Policy := Compliant;
4992
4993 elsif Value = "controlled" then
4994 Project.Symbol_Data.Symbol_Policy := Controlled;
4995
4996 elsif Value = "restricted" then
4997 Project.Symbol_Data.Symbol_Policy := Restricted;
4998
4999 elsif Value = "direct" then
5000 Project.Symbol_Data.Symbol_Policy := Direct;
5001
5002 else
5003 Error_Msg
5004 (Data.Flags,
5005 "illegal value for Library_Symbol_Policy",
5006 Lib_Symbol_Policy.Location, Project);
5007 end if;
5008 end;
5009 end if;
5010
5011 -- If attribute Library_Symbol_File is not specified, symbol policy
5012 -- cannot be Restricted.
5013
5014 if Lib_Symbol_File.Default then
5015 if Project.Symbol_Data.Symbol_Policy = Restricted then
5016 Error_Msg
5017 (Data.Flags,
5018 "Library_Symbol_File needs to be defined when " &
5019 "symbol policy is Restricted",
5020 Lib_Symbol_Policy.Location, Project);
5021 end if;
5022
5023 else
5024 -- Library_Symbol_File is defined
5025
5026 Project.Symbol_Data.Symbol_File :=
5027 Path_Name_Type (Lib_Symbol_File.Value);
5028
5029 Get_Name_String (Lib_Symbol_File.Value);
5030
5031 if Name_Len = 0 then
5032 Error_Msg
5033 (Data.Flags,
5034 "symbol file name cannot be an empty string",
5035 Lib_Symbol_File.Location, Project);
5036
5037 else
5038 OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
5039
5040 if OK then
5041 for J in 1 .. Name_Len loop
5042 if Is_Directory_Separator (Name_Buffer (J)) then
5043 OK := False;
5044 exit;
5045 end if;
5046 end loop;
5047 end if;
5048
5049 if not OK then
5050 Error_Msg_File_1 := File_Name_Type (Lib_Symbol_File.Value);
5051 Error_Msg
5052 (Data.Flags,
5053 "symbol file name { is illegal. " &
5054 "Name cannot include directory info.",
5055 Lib_Symbol_File.Location, Project);
5056 end if;
5057 end if;
5058 end if;
5059
5060 -- If attribute Library_Reference_Symbol_File is not defined,
5061 -- symbol policy cannot be Compliant or Controlled.
5062
5063 if Lib_Ref_Symbol_File.Default then
5064 if Project.Symbol_Data.Symbol_Policy = Compliant
5065 or else Project.Symbol_Data.Symbol_Policy = Controlled
5066 then
5067 Error_Msg
5068 (Data.Flags,
5069 "a reference symbol file needs to be defined",
5070 Lib_Symbol_Policy.Location, Project);
5071 end if;
5072
5073 else
5074 -- Library_Reference_Symbol_File is defined, check file exists
5075
5076 Project.Symbol_Data.Reference :=
5077 Path_Name_Type (Lib_Ref_Symbol_File.Value);
5078
5079 Get_Name_String (Lib_Ref_Symbol_File.Value);
5080
5081 if Name_Len = 0 then
5082 Error_Msg
5083 (Data.Flags,
5084 "reference symbol file name cannot be an empty string",
5085 Lib_Symbol_File.Location, Project);
5086
5087 else
5088 if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then
5089 Name_Len := 0;
5090 Add_Str_To_Name_Buffer
5091 (Get_Name_String (Project.Directory.Name));
5092 Add_Str_To_Name_Buffer
5093 (Get_Name_String (Lib_Ref_Symbol_File.Value));
5094 Project.Symbol_Data.Reference := Name_Find;
5095 end if;
5096
5097 if not Is_Regular_File
5098 (Get_Name_String (Project.Symbol_Data.Reference))
5099 then
5100 Error_Msg_File_1 :=
5101 File_Name_Type (Lib_Ref_Symbol_File.Value);
5102
5103 -- For controlled and direct symbol policies, it is an error
5104 -- if the reference symbol file does not exist. For other
5105 -- symbol policies, this is just a warning
5106
5107 Error_Msg_Warn :=
5108 Project.Symbol_Data.Symbol_Policy /= Controlled
5109 and then Project.Symbol_Data.Symbol_Policy /= Direct;
5110
5111 Error_Msg
5112 (Data.Flags,
5113 "<library reference symbol file { does not exist",
5114 Lib_Ref_Symbol_File.Location, Project);
5115
5116 -- In addition in the non-controlled case, if symbol policy
5117 -- is Compliant, it is changed to Autonomous, because there
5118 -- is no reference to check against, and we don't want to
5119 -- fail in this case.
5120
5121 if Project.Symbol_Data.Symbol_Policy /= Controlled then
5122 if Project.Symbol_Data.Symbol_Policy = Compliant then
5123 Project.Symbol_Data.Symbol_Policy := Autonomous;
5124 end if;
5125 end if;
5126 end if;
5127
5128 -- If both the reference symbol file and the symbol file are
5129 -- defined, then check that they are not the same file.
5130
5131 if Project.Symbol_Data.Symbol_File /= No_Path then
5132 Get_Name_String (Project.Symbol_Data.Symbol_File);
5133
5134 if Name_Len > 0 then
5135 declare
5136 -- We do not need to pass a Directory to
5137 -- Normalize_Pathname, since the path_information
5138 -- already contains absolute information.
5139
5140 Symb_Path : constant String :=
5141 Normalize_Pathname
5142 (Get_Name_String
5143 (Project.Object_Directory.Name) &
5144 Name_Buffer (1 .. Name_Len),
5145 Directory => "/",
5146 Resolve_Links =>
5147 Opt.Follow_Links_For_Files);
5148 Ref_Path : constant String :=
5149 Normalize_Pathname
5150 (Get_Name_String
5151 (Project.Symbol_Data.Reference),
5152 Directory => "/",
5153 Resolve_Links =>
5154 Opt.Follow_Links_For_Files);
5155 begin
5156 if Symb_Path = Ref_Path then
5157 Error_Msg
5158 (Data.Flags,
5159 "library reference symbol file and library" &
5160 " symbol file cannot be the same file",
5161 Lib_Ref_Symbol_File.Location, Project);
5162 end if;
5163 end;
5164 end if;
5165 end if;
5166 end if;
5167 end if;
5168 end if;
5169 end Check_Stand_Alone_Library;
5170
5171 ---------------------
5172 -- Check_Unit_Name --
5173 ---------------------
5174
5175 procedure Check_Unit_Name (Name : String; Unit : out Name_Id) is
5176 The_Name : String := Name;
5177 Real_Name : Name_Id;
5178 Need_Letter : Boolean := True;
5179 Last_Underscore : Boolean := False;
5180 OK : Boolean := The_Name'Length > 0;
5181 First : Positive;
5182
5183 function Is_Reserved (Name : Name_Id) return Boolean;
5184 function Is_Reserved (S : String) return Boolean;
5185 -- Check that the given name is not an Ada 95 reserved word. The reason
5186 -- for the Ada 95 here is that we do not want to exclude the case of an
5187 -- Ada 95 unit called Interface (for example). In Ada 2005, such a unit
5188 -- name would be rejected anyway by the compiler. That means there is no
5189 -- requirement that the project file parser reject this.
5190
5191 -----------------
5192 -- Is_Reserved --
5193 -----------------
5194
5195 function Is_Reserved (S : String) return Boolean is
5196 begin
5197 Name_Len := 0;
5198 Add_Str_To_Name_Buffer (S);
5199 return Is_Reserved (Name_Find);
5200 end Is_Reserved;
5201
5202 -----------------
5203 -- Is_Reserved --
5204 -----------------
5205
5206 function Is_Reserved (Name : Name_Id) return Boolean is
5207 begin
5208 if Get_Name_Table_Byte (Name) /= 0
5209 and then
5210 not Nam_In (Name, Name_Project, Name_Extends, Name_External)
5211 and then Name not in Ada_2005_Reserved_Words
5212 then
5213 Unit := No_Name;
5214 Debug_Output ("Ada reserved word: ", Name);
5215 return True;
5216
5217 else
5218 return False;
5219 end if;
5220 end Is_Reserved;
5221
5222 -- Start of processing for Check_Unit_Name
5223
5224 begin
5225 To_Lower (The_Name);
5226
5227 Name_Len := The_Name'Length;
5228 Name_Buffer (1 .. Name_Len) := The_Name;
5229
5230 Real_Name := Name_Find;
5231
5232 if Is_Reserved (Real_Name) then
5233 return;
5234 end if;
5235
5236 First := The_Name'First;
5237
5238 for Index in The_Name'Range loop
5239 if Need_Letter then
5240
5241 -- We need a letter (at the beginning, and following a dot),
5242 -- but we don't have one.
5243
5244 if Is_Letter (The_Name (Index)) then
5245 Need_Letter := False;
5246
5247 else
5248 OK := False;
5249
5250 if Current_Verbosity = High then
5251 Debug_Indent;
5252 Write_Int (Types.Int (Index));
5253 Write_Str (": '");
5254 Write_Char (The_Name (Index));
5255 Write_Line ("' is not a letter.");
5256 end if;
5257
5258 exit;
5259 end if;
5260
5261 elsif Last_Underscore
5262 and then (The_Name (Index) = '_' or else The_Name (Index) = '.')
5263 then
5264 -- Two underscores are illegal, and a dot cannot follow
5265 -- an underscore.
5266
5267 OK := False;
5268
5269 if Current_Verbosity = High then
5270 Debug_Indent;
5271 Write_Int (Types.Int (Index));
5272 Write_Str (": '");
5273 Write_Char (The_Name (Index));
5274 Write_Line ("' is illegal here.");
5275 end if;
5276
5277 exit;
5278
5279 elsif The_Name (Index) = '.' then
5280
5281 -- First, check if the name before the dot is not a reserved word
5282
5283 if Is_Reserved (The_Name (First .. Index - 1)) then
5284 return;
5285 end if;
5286
5287 First := Index + 1;
5288
5289 -- We need a letter after a dot
5290
5291 Need_Letter := True;
5292
5293 elsif The_Name (Index) = '_' then
5294 Last_Underscore := True;
5295
5296 else
5297 -- We need an letter or a digit
5298
5299 Last_Underscore := False;
5300
5301 if not Is_Alphanumeric (The_Name (Index)) then
5302 OK := False;
5303
5304 if Current_Verbosity = High then
5305 Debug_Indent;
5306 Write_Int (Types.Int (Index));
5307 Write_Str (": '");
5308 Write_Char (The_Name (Index));
5309 Write_Line ("' is not alphanumeric.");
5310 end if;
5311
5312 exit;
5313 end if;
5314 end if;
5315 end loop;
5316
5317 -- Cannot end with an underscore or a dot
5318
5319 OK := OK and then not Need_Letter and then not Last_Underscore;
5320
5321 if OK then
5322 if First /= Name'First
5323 and then Is_Reserved (The_Name (First .. The_Name'Last))
5324 then
5325 return;
5326 end if;
5327
5328 Unit := Real_Name;
5329
5330 else
5331 -- Signal a problem with No_Name
5332
5333 Unit := No_Name;
5334 end if;
5335 end Check_Unit_Name;
5336
5337 ----------------------------
5338 -- Compute_Directory_Last --
5339 ----------------------------
5340
5341 function Compute_Directory_Last (Dir : String) return Natural is
5342 begin
5343 if Dir'Length > 1
5344 and then Is_Directory_Separator (Dir (Dir'Last - 1))
5345 then
5346 return Dir'Last - 1;
5347 else
5348 return Dir'Last;
5349 end if;
5350 end Compute_Directory_Last;
5351
5352 ---------------------
5353 -- Get_Directories --
5354 ---------------------
5355
5356 procedure Get_Directories
5357 (Project : Project_Id;
5358 Data : in out Tree_Processing_Data)
5359 is
5360 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
5361
5362 Object_Dir : constant Variable_Value :=
5363 Util.Value_Of
5364 (Name_Object_Dir, Project.Decl.Attributes, Shared);
5365
5366 Exec_Dir : constant Variable_Value :=
5367 Util.Value_Of
5368 (Name_Exec_Dir, Project.Decl.Attributes, Shared);
5369
5370 Source_Dirs : constant Variable_Value :=
5371 Util.Value_Of
5372 (Name_Source_Dirs, Project.Decl.Attributes, Shared);
5373
5374 Ignore_Source_Sub_Dirs : constant Variable_Value :=
5375 Util.Value_Of
5376 (Name_Ignore_Source_Sub_Dirs,
5377 Project.Decl.Attributes,
5378 Shared);
5379
5380 Excluded_Source_Dirs : constant Variable_Value :=
5381 Util.Value_Of
5382 (Name_Excluded_Source_Dirs,
5383 Project.Decl.Attributes,
5384 Shared);
5385
5386 Source_Files : constant Variable_Value :=
5387 Util.Value_Of
5388 (Name_Source_Files,
5389 Project.Decl.Attributes, Shared);
5390
5391 Last_Source_Dir : String_List_Id := Nil_String;
5392 Last_Src_Dir_Rank : Number_List_Index := No_Number_List;
5393
5394 Languages : constant Variable_Value :=
5395 Prj.Util.Value_Of
5396 (Name_Languages, Project.Decl.Attributes, Shared);
5397
5398 Remove_Source_Dirs : Boolean := False;
5399
5400 procedure Add_To_Or_Remove_From_Source_Dirs
5401 (Path : Path_Information;
5402 Rank : Natural);
5403 -- When Removed = False, the directory Path_Id to the list of
5404 -- source_dirs if not already in the list. When Removed = True,
5405 -- removed directory Path_Id if in the list.
5406
5407 procedure Find_Source_Dirs is new Expand_Subdirectory_Pattern
5408 (Add_To_Or_Remove_From_Source_Dirs);
5409
5410 ---------------------------------------
5411 -- Add_To_Or_Remove_From_Source_Dirs --
5412 ---------------------------------------
5413
5414 procedure Add_To_Or_Remove_From_Source_Dirs
5415 (Path : Path_Information;
5416 Rank : Natural)
5417 is
5418 List : String_List_Id;
5419 Prev : String_List_Id;
5420 Rank_List : Number_List_Index;
5421 Prev_Rank : Number_List_Index;
5422 Element : String_Element;
5423
5424 begin
5425 Prev := Nil_String;
5426 Prev_Rank := No_Number_List;
5427 List := Project.Source_Dirs;
5428 Rank_List := Project.Source_Dir_Ranks;
5429 while List /= Nil_String loop
5430 Element := Shared.String_Elements.Table (List);
5431 exit when Element.Value = Name_Id (Path.Name);
5432 Prev := List;
5433 List := Element.Next;
5434 Prev_Rank := Rank_List;
5435 Rank_List := Shared.Number_Lists.Table (Prev_Rank).Next;
5436 end loop;
5437
5438 -- The directory is in the list if List is not Nil_String
5439
5440 if not Remove_Source_Dirs and then List = Nil_String then
5441 Debug_Output ("adding source dir=", Name_Id (Path.Display_Name));
5442
5443 String_Element_Table.Increment_Last (Shared.String_Elements);
5444 Element :=
5445 (Value => Name_Id (Path.Name),
5446 Index => 0,
5447 Display_Value => Name_Id (Path.Display_Name),
5448 Location => No_Location,
5449 Flag => False,
5450 Next => Nil_String);
5451
5452 Number_List_Table.Increment_Last (Shared.Number_Lists);
5453
5454 if Last_Source_Dir = Nil_String then
5455
5456 -- This is the first source directory
5457
5458 Project.Source_Dirs :=
5459 String_Element_Table.Last (Shared.String_Elements);
5460 Project.Source_Dir_Ranks :=
5461 Number_List_Table.Last (Shared.Number_Lists);
5462
5463 else
5464 -- We already have source directories, link the previous
5465 -- last to the new one.
5466
5467 Shared.String_Elements.Table (Last_Source_Dir).Next :=
5468 String_Element_Table.Last (Shared.String_Elements);
5469 Shared.Number_Lists.Table (Last_Src_Dir_Rank).Next :=
5470 Number_List_Table.Last (Shared.Number_Lists);
5471 end if;
5472
5473 -- And register this source directory as the new last
5474
5475 Last_Source_Dir :=
5476 String_Element_Table.Last (Shared.String_Elements);
5477 Shared.String_Elements.Table (Last_Source_Dir) := Element;
5478 Last_Src_Dir_Rank := Number_List_Table.Last (Shared.Number_Lists);
5479 Shared.Number_Lists.Table (Last_Src_Dir_Rank) :=
5480 (Number => Rank, Next => No_Number_List);
5481
5482 elsif Remove_Source_Dirs and then List /= Nil_String then
5483
5484 -- Remove source dir if present
5485
5486 if Prev = Nil_String then
5487 Project.Source_Dirs := Shared.String_Elements.Table (List).Next;
5488 Project.Source_Dir_Ranks :=
5489 Shared.Number_Lists.Table (Rank_List).Next;
5490
5491 else
5492 Shared.String_Elements.Table (Prev).Next :=
5493 Shared.String_Elements.Table (List).Next;
5494 Shared.Number_Lists.Table (Prev_Rank).Next :=
5495 Shared.Number_Lists.Table (Rank_List).Next;
5496 end if;
5497 end if;
5498 end Add_To_Or_Remove_From_Source_Dirs;
5499
5500 -- Local declarations
5501
5502 Dir_Exists : Boolean;
5503
5504 No_Sources : constant Boolean :=
5505 Project.Qualifier = Abstract_Project
5506 or else (((not Source_Files.Default
5507 and then Source_Files.Values = Nil_String)
5508 or else
5509 (not Source_Dirs.Default
5510 and then Source_Dirs.Values = Nil_String)
5511 or else
5512 (not Languages.Default
5513 and then Languages.Values = Nil_String))
5514 and then Project.Extends = No_Project);
5515
5516 -- Start of processing for Get_Directories
5517
5518 begin
5519 Debug_Output ("starting to look for directories");
5520
5521 -- Set the object directory to its default which may be nil, if there
5522 -- is no sources in the project.
5523
5524 if No_Sources then
5525 Project.Object_Directory := No_Path_Information;
5526 else
5527 Project.Object_Directory := Project.Directory;
5528 end if;
5529
5530 -- Check the object directory
5531
5532 if Object_Dir.Value /= Empty_String then
5533 Get_Name_String (Object_Dir.Value);
5534
5535 if Name_Len = 0 then
5536 Error_Msg
5537 (Data.Flags,
5538 "Object_Dir cannot be empty",
5539 Object_Dir.Location, Project);
5540
5541 elsif Setup_Projects
5542 and then No_Sources
5543 and then Project.Extends = No_Project
5544 then
5545 -- Do not create an object directory for a non extending project
5546 -- with no sources.
5547
5548 Locate_Directory
5549 (Project,
5550 File_Name_Type (Object_Dir.Value),
5551 Path => Project.Object_Directory,
5552 Dir_Exists => Dir_Exists,
5553 Data => Data,
5554 Location => Object_Dir.Location,
5555 Must_Exist => False,
5556 Externally_Built => Project.Externally_Built);
5557
5558 else
5559 -- We check that the specified object directory does exist.
5560 -- However, even when it doesn't exist, we set it to a default
5561 -- value. This is for the benefit of tools that recover from
5562 -- errors; for example, these tools could create the non existent
5563 -- directory. We always return an absolute directory name though.
5564
5565 Locate_Directory
5566 (Project,
5567 File_Name_Type (Object_Dir.Value),
5568 Path => Project.Object_Directory,
5569 Create => "object",
5570 Dir_Exists => Dir_Exists,
5571 Data => Data,
5572 Location => Object_Dir.Location,
5573 Must_Exist => False,
5574 Externally_Built => Project.Externally_Built);
5575
5576 if not Dir_Exists and then not Project.Externally_Built then
5577 if Opt.Directories_Must_Exist_In_Projects then
5578
5579 -- The object directory does not exist, report an error if
5580 -- the project is not externally built.
5581
5582 Err_Vars.Error_Msg_File_1 :=
5583 File_Name_Type (Object_Dir.Value);
5584 Error_Or_Warning
5585 (Data.Flags, Data.Flags.Require_Obj_Dirs,
5586 "object directory { not found",
5587 Project.Location, Project);
5588 end if;
5589 end if;
5590 end if;
5591
5592 elsif not No_Sources and then
5593 (Subdirs /= null or else Build_Tree_Dir /= null)
5594 then
5595 Name_Len := 1;
5596 Name_Buffer (1) := '.';
5597 Locate_Directory
5598 (Project,
5599 Name_Find,
5600 Path => Project.Object_Directory,
5601 Create => "object",
5602 Dir_Exists => Dir_Exists,
5603 Data => Data,
5604 Location => Object_Dir.Location,
5605 Externally_Built => Project.Externally_Built);
5606 end if;
5607
5608 if Current_Verbosity = High then
5609 if Project.Object_Directory = No_Path_Information then
5610 Debug_Output ("no object directory");
5611 else
5612 Write_Attr
5613 ("Object directory",
5614 Get_Name_String (Project.Object_Directory.Display_Name));
5615 end if;
5616 end if;
5617
5618 -- Check the exec directory
5619
5620 -- We set the object directory to its default
5621
5622 Project.Exec_Directory := Project.Object_Directory;
5623
5624 if Exec_Dir.Value /= Empty_String then
5625 Get_Name_String (Exec_Dir.Value);
5626
5627 if Name_Len = 0 then
5628 Error_Msg
5629 (Data.Flags,
5630 "Exec_Dir cannot be empty",
5631 Exec_Dir.Location, Project);
5632
5633 elsif Setup_Projects
5634 and then No_Sources
5635 and then Project.Extends = No_Project
5636 then
5637 -- Do not create an exec directory for a non extending project
5638 -- with no sources.
5639
5640 Locate_Directory
5641 (Project,
5642 File_Name_Type (Exec_Dir.Value),
5643 Path => Project.Exec_Directory,
5644 Dir_Exists => Dir_Exists,
5645 Data => Data,
5646 Location => Exec_Dir.Location,
5647 Externally_Built => Project.Externally_Built);
5648
5649 else
5650 -- We check that the specified exec directory does exist
5651
5652 Locate_Directory
5653 (Project,
5654 File_Name_Type (Exec_Dir.Value),
5655 Path => Project.Exec_Directory,
5656 Dir_Exists => Dir_Exists,
5657 Data => Data,
5658 Create => "exec",
5659 Location => Exec_Dir.Location,
5660 Externally_Built => Project.Externally_Built);
5661
5662 if not Dir_Exists then
5663 if Opt.Directories_Must_Exist_In_Projects then
5664 Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value);
5665 Error_Or_Warning
5666 (Data.Flags, Data.Flags.Missing_Source_Files,
5667 "exec directory { not found", Project.Location, Project);
5668
5669 else
5670 Project.Exec_Directory := No_Path_Information;
5671 end if;
5672 end if;
5673 end if;
5674 end if;
5675
5676 if Current_Verbosity = High then
5677 if Project.Exec_Directory = No_Path_Information then
5678 Debug_Output ("no exec directory");
5679 else
5680 Debug_Output
5681 ("exec directory: ",
5682 Name_Id (Project.Exec_Directory.Display_Name));
5683 end if;
5684 end if;
5685
5686 -- Look for the source directories
5687
5688 Debug_Output ("starting to look for source directories");
5689
5690 pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list");
5691
5692 if not Source_Files.Default and then Source_Files.Values = Nil_String
5693 then
5694 Project.Source_Dirs := Nil_String;
5695
5696 if Project.Qualifier = Standard then
5697 Error_Msg
5698 (Data.Flags,
5699 "a standard project cannot have no sources",
5700 Source_Files.Location, Project);
5701 end if;
5702
5703 elsif Source_Dirs.Default then
5704
5705 -- No Source_Dirs specified: the single source directory is the one
5706 -- containing the project file.
5707
5708 Remove_Source_Dirs := False;
5709 Add_To_Or_Remove_From_Source_Dirs
5710 (Path => (Name => Project.Directory.Name,
5711 Display_Name => Project.Directory.Display_Name),
5712 Rank => 1);
5713
5714 else
5715 Remove_Source_Dirs := False;
5716 Find_Source_Dirs
5717 (Project => Project,
5718 Data => Data,
5719 Patterns => Source_Dirs.Values,
5720 Ignore => Ignore_Source_Sub_Dirs.Values,
5721 Search_For => Search_Directories,
5722 Resolve_Links => Opt.Follow_Links_For_Dirs);
5723
5724 if Project.Source_Dirs = Nil_String
5725 and then Project.Qualifier = Standard
5726 then
5727 Error_Msg
5728 (Data.Flags,
5729 "a standard project cannot have no source directories",
5730 Source_Dirs.Location, Project);
5731 end if;
5732 end if;
5733
5734 if not Excluded_Source_Dirs.Default
5735 and then Excluded_Source_Dirs.Values /= Nil_String
5736 then
5737 Remove_Source_Dirs := True;
5738 Find_Source_Dirs
5739 (Project => Project,
5740 Data => Data,
5741 Patterns => Excluded_Source_Dirs.Values,
5742 Ignore => Nil_String,
5743 Search_For => Search_Directories,
5744 Resolve_Links => Opt.Follow_Links_For_Dirs);
5745 end if;
5746
5747 Debug_Output ("putting source directories in canonical cases");
5748
5749 declare
5750 Current : String_List_Id := Project.Source_Dirs;
5751 Element : String_Element;
5752
5753 begin
5754 while Current /= Nil_String loop
5755 Element := Shared.String_Elements.Table (Current);
5756 if Element.Value /= No_Name then
5757 Element.Value :=
5758 Name_Id (Canonical_Case_File_Name (Element.Value));
5759 Shared.String_Elements.Table (Current) := Element;
5760 end if;
5761
5762 Current := Element.Next;
5763 end loop;
5764 end;
5765 end Get_Directories;
5766
5767 ---------------
5768 -- Get_Mains --
5769 ---------------
5770
5771 procedure Get_Mains
5772 (Project : Project_Id;
5773 Data : in out Tree_Processing_Data)
5774 is
5775 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
5776
5777 Mains : constant Variable_Value :=
5778 Prj.Util.Value_Of
5779 (Name_Main, Project.Decl.Attributes, Shared);
5780 List : String_List_Id;
5781 Elem : String_Element;
5782
5783 begin
5784 Project.Mains := Mains.Values;
5785
5786 -- If no Mains were specified, and if we are an extending project,
5787 -- inherit the Mains from the project we are extending.
5788
5789 if Mains.Default then
5790 if not Project.Library and then Project.Extends /= No_Project then
5791 Project.Mains := Project.Extends.Mains;
5792 end if;
5793
5794 -- In a library project file, Main cannot be specified
5795
5796 elsif Project.Library then
5797 Error_Msg
5798 (Data.Flags,
5799 "a library project file cannot have Main specified",
5800 Mains.Location, Project);
5801
5802 else
5803 List := Mains.Values;
5804 while List /= Nil_String loop
5805 Elem := Shared.String_Elements.Table (List);
5806
5807 if Length_Of_Name (Elem.Value) = 0 then
5808 Error_Msg
5809 (Data.Flags,
5810 "?a main cannot have an empty name",
5811 Elem.Location, Project);
5812 exit;
5813 end if;
5814
5815 List := Elem.Next;
5816 end loop;
5817 end if;
5818 end Get_Mains;
5819
5820 ---------------------------
5821 -- Get_Sources_From_File --
5822 ---------------------------
5823
5824 procedure Get_Sources_From_File
5825 (Path : String;
5826 Location : Source_Ptr;
5827 Project : in out Project_Processing_Data;
5828 Data : in out Tree_Processing_Data)
5829 is
5830 File : Prj.Util.Text_File;
5831 Line : String (1 .. 250);
5832 Last : Natural;
5833 Source_Name : File_Name_Type;
5834 Name_Loc : Name_Location;
5835
5836 begin
5837 if Current_Verbosity = High then
5838 Debug_Output ("opening """ & Path & '"');
5839 end if;
5840
5841 -- Open the file
5842
5843 Prj.Util.Open (File, Path);
5844
5845 if not Prj.Util.Is_Valid (File) then
5846 Error_Msg
5847 (Data.Flags, "file does not exist", Location, Project.Project);
5848
5849 else
5850 -- Read the lines one by one
5851
5852 while not Prj.Util.End_Of_File (File) loop
5853 Prj.Util.Get_Line (File, Line, Last);
5854
5855 -- A non empty, non comment line should contain a file name
5856
5857 if Last /= 0 and then (Last = 1 or else Line (1 .. 2) /= "--") then
5858 Name_Len := Last;
5859 Name_Buffer (1 .. Name_Len) := Line (1 .. Last);
5860 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
5861 Source_Name := Name_Find;
5862
5863 -- Check that there is no directory information
5864
5865 for J in 1 .. Last loop
5866 if Is_Directory_Separator (Line (J)) then
5867 Error_Msg_File_1 := Source_Name;
5868 Error_Msg
5869 (Data.Flags,
5870 "file name cannot include directory information ({)",
5871 Location, Project.Project);
5872 exit;
5873 end if;
5874 end loop;
5875
5876 Name_Loc := Source_Names_Htable.Get
5877 (Project.Source_Names, Source_Name);
5878
5879 if Name_Loc = No_Name_Location then
5880 Name_Loc :=
5881 (Name => Source_Name,
5882 Location => Location,
5883 Source => No_Source,
5884 Listed => True,
5885 Found => False);
5886
5887 else
5888 Name_Loc.Listed := True;
5889 end if;
5890
5891 Source_Names_Htable.Set
5892 (Project.Source_Names, Source_Name, Name_Loc);
5893 end if;
5894 end loop;
5895
5896 Prj.Util.Close (File);
5897
5898 end if;
5899 end Get_Sources_From_File;
5900
5901 ------------------
5902 -- No_Space_Img --
5903 ------------------
5904
5905 function No_Space_Img (N : Natural) return String is
5906 Image : constant String := N'Img;
5907 begin
5908 return Image (2 .. Image'Last);
5909 end No_Space_Img;
5910
5911 -----------------------
5912 -- Compute_Unit_Name --
5913 -----------------------
5914
5915 procedure Compute_Unit_Name
5916 (File_Name : File_Name_Type;
5917 Naming : Lang_Naming_Data;
5918 Kind : out Source_Kind;
5919 Unit : out Name_Id;
5920 Project : Project_Processing_Data)
5921 is
5922 Filename : constant String := Get_Name_String (File_Name);
5923 Last : Integer := Filename'Last;
5924 Sep_Len : Integer;
5925 Body_Len : Integer;
5926 Spec_Len : Integer;
5927
5928 Unit_Except : Unit_Exception;
5929 Masked : Boolean := False;
5930
5931 begin
5932 Unit := No_Name;
5933 Kind := Spec;
5934
5935 if Naming.Separate_Suffix = No_File
5936 or else Naming.Body_Suffix = No_File
5937 or else Naming.Spec_Suffix = No_File
5938 then
5939 return;
5940 end if;
5941
5942 if Naming.Dot_Replacement = No_File then
5943 Debug_Output ("no dot_replacement specified");
5944 return;
5945 end if;
5946
5947 Sep_Len := Integer (Length_Of_Name (Naming.Separate_Suffix));
5948 Spec_Len := Integer (Length_Of_Name (Naming.Spec_Suffix));
5949 Body_Len := Integer (Length_Of_Name (Naming.Body_Suffix));
5950
5951 -- Choose the longest suffix that matches. If there are several matches,
5952 -- give priority to specs, then bodies, then separates.
5953
5954 if Naming.Separate_Suffix /= Naming.Body_Suffix
5955 and then Suffix_Matches (Filename, Naming.Separate_Suffix)
5956 then
5957 Last := Filename'Last - Sep_Len;
5958 Kind := Sep;
5959 end if;
5960
5961 if Filename'Last - Body_Len <= Last
5962 and then Suffix_Matches (Filename, Naming.Body_Suffix)
5963 then
5964 Last := Natural'Min (Last, Filename'Last - Body_Len);
5965 Kind := Impl;
5966 end if;
5967
5968 if Filename'Last - Spec_Len <= Last
5969 and then Suffix_Matches (Filename, Naming.Spec_Suffix)
5970 then
5971 Last := Natural'Min (Last, Filename'Last - Spec_Len);
5972 Kind := Spec;
5973 end if;
5974
5975 if Last = Filename'Last then
5976 Debug_Output ("no matching suffix");
5977 return;
5978 end if;
5979
5980 -- Check that the casing matches
5981
5982 if File_Names_Case_Sensitive then
5983 case Naming.Casing is
5984 when All_Lower_Case =>
5985 for J in Filename'First .. Last loop
5986 if Is_Letter (Filename (J))
5987 and then not Is_Lower (Filename (J))
5988 then
5989 Debug_Output ("invalid casing");
5990 return;
5991 end if;
5992 end loop;
5993
5994 when All_Upper_Case =>
5995 for J in Filename'First .. Last loop
5996 if Is_Letter (Filename (J))
5997 and then not Is_Upper (Filename (J))
5998 then
5999 Debug_Output ("invalid casing");
6000 return;
6001 end if;
6002 end loop;
6003
6004 when Mixed_Case | Unknown =>
6005 null;
6006 end case;
6007 end if;
6008
6009 -- If Dot_Replacement is not a single dot, then there should not
6010 -- be any dot in the name.
6011
6012 declare
6013 Dot_Repl : constant String :=
6014 Get_Name_String (Naming.Dot_Replacement);
6015
6016 begin
6017 if Dot_Repl /= "." then
6018 for Index in Filename'First .. Last loop
6019 if Filename (Index) = '.' then
6020 Debug_Output ("invalid name, contains dot");
6021 return;
6022 end if;
6023 end loop;
6024
6025 Replace_Into_Name_Buffer
6026 (Filename (Filename'First .. Last), Dot_Repl, '.');
6027
6028 else
6029 Name_Len := Last - Filename'First + 1;
6030 Name_Buffer (1 .. Name_Len) := Filename (Filename'First .. Last);
6031 Fixed.Translate
6032 (Source => Name_Buffer (1 .. Name_Len),
6033 Mapping => Lower_Case_Map);
6034 end if;
6035 end;
6036
6037 -- In the standard GNAT naming scheme, check for special cases: children
6038 -- or separates of A, G, I or S, and run time sources.
6039
6040 if Is_Standard_GNAT_Naming (Naming) and then Name_Len >= 3 then
6041 declare
6042 S1 : constant Character := Name_Buffer (1);
6043 S2 : constant Character := Name_Buffer (2);
6044 S3 : constant Character := Name_Buffer (3);
6045
6046 begin
6047 if S1 = 'a' or else S1 = 'g' or else S1 = 'i' or else S1 = 's' then
6048
6049 -- Children or separates of packages A, G, I or S. These names
6050 -- are x__ ... or x~... (where x is a, g, i, or s). Both
6051 -- versions (x__... and x~...) are allowed in all platforms,
6052 -- because it is not possible to know the platform before
6053 -- processing of the project files.
6054
6055 if S2 = '_' and then S3 = '_' then
6056 Name_Buffer (2) := '.';
6057 Name_Buffer (3 .. Name_Len - 1) :=
6058 Name_Buffer (4 .. Name_Len);
6059 Name_Len := Name_Len - 1;
6060
6061 elsif S2 = '~' then
6062 Name_Buffer (2) := '.';
6063
6064 elsif S2 = '.' then
6065
6066 -- If it is potentially a run time source
6067
6068 null;
6069 end if;
6070 end if;
6071 end;
6072 end if;
6073
6074 -- Name_Buffer contains the name of the unit in lower-cases. Check
6075 -- that this is a valid unit name
6076
6077 Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit);
6078
6079 -- If there is a naming exception for the same unit, the file is not
6080 -- a source for the unit.
6081
6082 if Unit /= No_Name then
6083 Unit_Except :=
6084 Unit_Exceptions_Htable.Get (Project.Unit_Exceptions, Unit);
6085
6086 if Kind = Spec then
6087 Masked := Unit_Except.Spec /= No_File
6088 and then
6089 Unit_Except.Spec /= File_Name;
6090 else
6091 Masked := Unit_Except.Impl /= No_File
6092 and then
6093 Unit_Except.Impl /= File_Name;
6094 end if;
6095
6096 if Masked then
6097 if Current_Verbosity = High then
6098 Debug_Indent;
6099 Write_Str (" """ & Filename & """ contains the ");
6100
6101 if Kind = Spec then
6102 Write_Str ("spec of a unit found in """);
6103 Write_Str (Get_Name_String (Unit_Except.Spec));
6104 else
6105 Write_Str ("body of a unit found in """);
6106 Write_Str (Get_Name_String (Unit_Except.Impl));
6107 end if;
6108
6109 Write_Line (""" (ignored)");
6110 end if;
6111
6112 Unit := No_Name;
6113 end if;
6114 end if;
6115
6116 if Unit /= No_Name and then Current_Verbosity = High then
6117 case Kind is
6118 when Spec => Debug_Output ("spec of", Unit);
6119 when Impl => Debug_Output ("body of", Unit);
6120 when Sep => Debug_Output ("sep of", Unit);
6121 end case;
6122 end if;
6123 end Compute_Unit_Name;
6124
6125 --------------------------
6126 -- Check_Illegal_Suffix --
6127 --------------------------
6128
6129 procedure Check_Illegal_Suffix
6130 (Project : Project_Id;
6131 Suffix : File_Name_Type;
6132 Dot_Replacement : File_Name_Type;
6133 Attribute_Name : String;
6134 Location : Source_Ptr;
6135 Data : in out Tree_Processing_Data)
6136 is
6137 Suffix_Str : constant String := Get_Name_String (Suffix);
6138
6139 begin
6140 if Suffix_Str'Length = 0 then
6141
6142 -- Always valid
6143
6144 return;
6145
6146 elsif Index (Suffix_Str, ".") = 0 then
6147 Err_Vars.Error_Msg_File_1 := Suffix;
6148 Error_Msg
6149 (Data.Flags,
6150 "{ is illegal for " & Attribute_Name & ": must have a dot",
6151 Location, Project);
6152 return;
6153 end if;
6154
6155 -- Case of dot replacement is a single dot, and first character of
6156 -- suffix is also a dot.
6157
6158 if Dot_Replacement /= No_File
6159 and then Get_Name_String (Dot_Replacement) = "."
6160 and then Suffix_Str (Suffix_Str'First) = '.'
6161 then
6162 for Index in Suffix_Str'First + 1 .. Suffix_Str'Last loop
6163
6164 -- If there are multiple dots in the name
6165
6166 if Suffix_Str (Index) = '.' then
6167
6168 -- It is illegal to have a letter following the initial dot
6169
6170 if Is_Letter (Suffix_Str (Suffix_Str'First + 1)) then
6171 Err_Vars.Error_Msg_File_1 := Suffix;
6172 Error_Msg
6173 (Data.Flags,
6174 "{ is illegal for " & Attribute_Name
6175 & ": ambiguous prefix when Dot_Replacement is a dot",
6176 Location, Project);
6177 end if;
6178 return;
6179 end if;
6180 end loop;
6181 end if;
6182 end Check_Illegal_Suffix;
6183
6184 ----------------------
6185 -- Locate_Directory --
6186 ----------------------
6187
6188 procedure Locate_Directory
6189 (Project : Project_Id;
6190 Name : File_Name_Type;
6191 Path : out Path_Information;
6192 Dir_Exists : out Boolean;
6193 Data : in out Tree_Processing_Data;
6194 Create : String := "";
6195 Location : Source_Ptr := No_Location;
6196 Must_Exist : Boolean := True;
6197 Externally_Built : Boolean := False)
6198 is
6199 Parent : constant Path_Name_Type :=
6200 Project.Directory.Display_Name;
6201 The_Parent : constant String :=
6202 Get_Name_String (Parent);
6203 The_Parent_Last : constant Natural :=
6204 Compute_Directory_Last (The_Parent);
6205 Full_Name : File_Name_Type;
6206 The_Name : File_Name_Type;
6207
6208 begin
6209 -- Check if we have a root-object dir specified, if so relocate all
6210 -- artefact directories to it.
6211
6212 if Build_Tree_Dir /= null
6213 and then Create /= ""
6214 and then not Is_Absolute_Path (Get_Name_String (Name))
6215 then
6216 Name_Len := 0;
6217 Add_Str_To_Name_Buffer (Build_Tree_Dir.all);
6218
6219 if The_Parent_Last - The_Parent'First + 1 < Root_Dir'Length then
6220 Err_Vars.Error_Msg_File_1 := Name;
6221 Error_Or_Warning
6222 (Data.Flags, Error,
6223 "{ cannot relocate deeper than " & Create & " directory",
6224 No_Location, Project);
6225 end if;
6226
6227 Add_Str_To_Name_Buffer
6228 (Relative_Path
6229 (The_Parent (The_Parent'First .. The_Parent_Last),
6230 Root_Dir.all));
6231 Add_Str_To_Name_Buffer (Get_Name_String (Name));
6232
6233 else
6234 if Build_Tree_Dir /= null and then Create /= "" then
6235 -- Issue a warning that we cannot relocate absolute obj dir
6236
6237 Err_Vars.Error_Msg_File_1 := Name;
6238 Error_Or_Warning
6239 (Data.Flags, Warning,
6240 "{ cannot relocate absolute object directory",
6241 No_Location, Project);
6242 end if;
6243
6244 Get_Name_String (Name);
6245 end if;
6246
6247 -- Add Subdirs.all if it is a directory that may be created and
6248 -- Subdirs is not null;
6249
6250 if Create /= "" and then Subdirs /= null then
6251 if Name_Buffer (Name_Len) /= Directory_Separator then
6252 Add_Char_To_Name_Buffer (Directory_Separator);
6253 end if;
6254
6255 Add_Str_To_Name_Buffer (Subdirs.all);
6256 end if;
6257
6258 -- Convert '/' to directory separator (for Windows)
6259
6260 for J in 1 .. Name_Len loop
6261 if Name_Buffer (J) = '/' then
6262 Name_Buffer (J) := Directory_Separator;
6263 end if;
6264 end loop;
6265
6266 The_Name := Name_Find;
6267
6268 if Current_Verbosity = High then
6269 Debug_Indent;
6270 Write_Str ("Locate_Directory (""");
6271 Write_Str (Get_Name_String (The_Name));
6272 Write_Str (""", in """);
6273 Write_Str (The_Parent);
6274 Write_Line (""")");
6275 end if;
6276
6277 Path := No_Path_Information;
6278 Dir_Exists := False;
6279
6280 if Is_Absolute_Path (Get_Name_String (The_Name)) then
6281 Full_Name := The_Name;
6282
6283 else
6284 Name_Len := 0;
6285 Add_Str_To_Name_Buffer
6286 (The_Parent (The_Parent'First .. The_Parent_Last));
6287 Add_Str_To_Name_Buffer (Get_Name_String (The_Name));
6288 Full_Name := Name_Find;
6289 end if;
6290
6291 declare
6292 Full_Path_Name : String_Access :=
6293 new String'(Get_Name_String (Full_Name));
6294
6295 begin
6296 if (Setup_Projects or else Subdirs /= null)
6297 and then Create'Length > 0
6298 then
6299 if not Is_Directory (Full_Path_Name.all) then
6300
6301 -- If project is externally built, do not create a subdir,
6302 -- use the specified directory, without the subdir.
6303
6304 if Externally_Built then
6305 if Is_Absolute_Path (Get_Name_String (Name)) then
6306 Get_Name_String (Name);
6307
6308 else
6309 Name_Len := 0;
6310 Add_Str_To_Name_Buffer
6311 (The_Parent (The_Parent'First .. The_Parent_Last));
6312 Add_Str_To_Name_Buffer (Get_Name_String (Name));
6313 end if;
6314
6315 Full_Path_Name := new String'(Name_Buffer (1 .. Name_Len));
6316
6317 else
6318 begin
6319 Create_Path (Full_Path_Name.all);
6320
6321 if not Quiet_Output then
6322 Write_Str (Create);
6323 Write_Str (" directory """);
6324 Write_Str (Full_Path_Name.all);
6325 Write_Str (""" created for project ");
6326 Write_Line (Get_Name_String (Project.Name));
6327 end if;
6328
6329 exception
6330 when Use_Error =>
6331
6332 -- Output message with name of directory. Note that we
6333 -- use the ~ insertion method here in case the name
6334 -- has special characters in it.
6335
6336 Error_Msg_Strlen := Full_Path_Name'Length;
6337 Error_Msg_String (1 .. Error_Msg_Strlen) :=
6338 Full_Path_Name.all;
6339 Error_Msg
6340 (Data.Flags,
6341 "could not create " & Create & " directory ~",
6342 Location,
6343 Project);
6344 end;
6345 end if;
6346 end if;
6347 end if;
6348
6349 Dir_Exists := Is_Directory (Full_Path_Name.all);
6350
6351 if not Must_Exist or Dir_Exists then
6352 declare
6353 Normed : constant String :=
6354 Normalize_Pathname
6355 (Full_Path_Name.all,
6356 Directory =>
6357 The_Parent (The_Parent'First .. The_Parent_Last),
6358 Resolve_Links => False,
6359 Case_Sensitive => True);
6360
6361 Canonical_Path : constant String :=
6362 Normalize_Pathname
6363 (Normed,
6364 Directory =>
6365 The_Parent
6366 (The_Parent'First .. The_Parent_Last),
6367 Resolve_Links =>
6368 Opt.Follow_Links_For_Dirs,
6369 Case_Sensitive => False);
6370
6371 begin
6372 Name_Len := Normed'Length;
6373 Name_Buffer (1 .. Name_Len) := Normed;
6374
6375 -- Directories should always end with a directory separator
6376
6377 if Name_Buffer (Name_Len) /= Directory_Separator then
6378 Add_Char_To_Name_Buffer (Directory_Separator);
6379 end if;
6380
6381 Path.Display_Name := Name_Find;
6382
6383 Name_Len := Canonical_Path'Length;
6384 Name_Buffer (1 .. Name_Len) := Canonical_Path;
6385
6386 if Name_Buffer (Name_Len) /= Directory_Separator then
6387 Add_Char_To_Name_Buffer (Directory_Separator);
6388 end if;
6389
6390 Path.Name := Name_Find;
6391 end;
6392 end if;
6393
6394 Free (Full_Path_Name);
6395 end;
6396 end Locate_Directory;
6397
6398 ---------------------------
6399 -- Find_Excluded_Sources --
6400 ---------------------------
6401
6402 procedure Find_Excluded_Sources
6403 (Project : in out Project_Processing_Data;
6404 Data : in out Tree_Processing_Data)
6405 is
6406 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
6407
6408 Excluded_Source_List_File : constant Variable_Value :=
6409 Util.Value_Of
6410 (Name_Excluded_Source_List_File,
6411 Project.Project.Decl.Attributes,
6412 Shared);
6413 Excluded_Sources : Variable_Value := Util.Value_Of
6414 (Name_Excluded_Source_Files,
6415 Project.Project.Decl.Attributes,
6416 Shared);
6417
6418 Current : String_List_Id;
6419 Element : String_Element;
6420 Location : Source_Ptr;
6421 Name : File_Name_Type;
6422 File : Prj.Util.Text_File;
6423 Line : String (1 .. 300);
6424 Last : Natural;
6425 Locally_Removed : Boolean := False;
6426
6427 begin
6428 -- If Excluded_Source_Files is not declared, check Locally_Removed_Files
6429
6430 if Excluded_Sources.Default then
6431 Locally_Removed := True;
6432 Excluded_Sources :=
6433 Util.Value_Of
6434 (Name_Locally_Removed_Files,
6435 Project.Project.Decl.Attributes, Shared);
6436 end if;
6437
6438 -- If there are excluded sources, put them in the table
6439
6440 if not Excluded_Sources.Default then
6441 if not Excluded_Source_List_File.Default then
6442 if Locally_Removed then
6443 Error_Msg
6444 (Data.Flags,
6445 "?both attributes Locally_Removed_Files and " &
6446 "Excluded_Source_List_File are present",
6447 Excluded_Source_List_File.Location, Project.Project);
6448 else
6449 Error_Msg
6450 (Data.Flags,
6451 "?both attributes Excluded_Source_Files and " &
6452 "Excluded_Source_List_File are present",
6453 Excluded_Source_List_File.Location, Project.Project);
6454 end if;
6455 end if;
6456
6457 Current := Excluded_Sources.Values;
6458 while Current /= Nil_String loop
6459 Element := Shared.String_Elements.Table (Current);
6460 Name := Canonical_Case_File_Name (Element.Value);
6461
6462 -- If the element has no location, then use the location of
6463 -- Excluded_Sources to report possible errors.
6464
6465 if Element.Location = No_Location then
6466 Location := Excluded_Sources.Location;
6467 else
6468 Location := Element.Location;
6469 end if;
6470
6471 Excluded_Sources_Htable.Set
6472 (Project.Excluded, Name,
6473 (Name, No_File, 0, False, Location));
6474 Current := Element.Next;
6475 end loop;
6476
6477 elsif not Excluded_Source_List_File.Default then
6478 Location := Excluded_Source_List_File.Location;
6479
6480 declare
6481 Source_File_Name : constant File_Name_Type :=
6482 File_Name_Type
6483 (Excluded_Source_List_File.Value);
6484 Source_File_Line : Natural := 0;
6485
6486 Source_File_Path_Name : constant String :=
6487 Path_Name_Of
6488 (Source_File_Name,
6489 Project.Project.Directory.Name);
6490
6491 begin
6492 if Source_File_Path_Name'Length = 0 then
6493 Err_Vars.Error_Msg_File_1 :=
6494 File_Name_Type (Excluded_Source_List_File.Value);
6495 Error_Msg
6496 (Data.Flags,
6497 "file with excluded sources { does not exist",
6498 Excluded_Source_List_File.Location, Project.Project);
6499
6500 else
6501 -- Open the file
6502
6503 Prj.Util.Open (File, Source_File_Path_Name);
6504
6505 if not Prj.Util.Is_Valid (File) then
6506 Error_Msg
6507 (Data.Flags, "file does not exist",
6508 Location, Project.Project);
6509 else
6510 -- Read the lines one by one
6511
6512 while not Prj.Util.End_Of_File (File) loop
6513 Prj.Util.Get_Line (File, Line, Last);
6514 Source_File_Line := Source_File_Line + 1;
6515
6516 -- Non empty, non comment line should contain a file name
6517
6518 if Last /= 0
6519 and then (Last = 1 or else Line (1 .. 2) /= "--")
6520 then
6521 Name_Len := Last;
6522 Name_Buffer (1 .. Name_Len) := Line (1 .. Last);
6523 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
6524 Name := Name_Find;
6525
6526 -- Check that there is no directory information
6527
6528 for J in 1 .. Last loop
6529 if Is_Directory_Separator (Line (J)) then
6530 Error_Msg_File_1 := Name;
6531 Error_Msg
6532 (Data.Flags,
6533 "file name cannot include "
6534 & "directory information ({)",
6535 Location, Project.Project);
6536 exit;
6537 end if;
6538 end loop;
6539
6540 Excluded_Sources_Htable.Set
6541 (Project.Excluded,
6542 Name,
6543 (Name, Source_File_Name, Source_File_Line,
6544 False, Location));
6545 end if;
6546 end loop;
6547
6548 Prj.Util.Close (File);
6549 end if;
6550 end if;
6551 end;
6552 end if;
6553 end Find_Excluded_Sources;
6554
6555 ------------------
6556 -- Find_Sources --
6557 ------------------
6558
6559 procedure Find_Sources
6560 (Project : in out Project_Processing_Data;
6561 Data : in out Tree_Processing_Data)
6562 is
6563 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
6564
6565 Sources : constant Variable_Value :=
6566 Util.Value_Of
6567 (Name_Source_Files,
6568 Project.Project.Decl.Attributes,
6569 Shared);
6570
6571 Source_List_File : constant Variable_Value :=
6572 Util.Value_Of
6573 (Name_Source_List_File,
6574 Project.Project.Decl.Attributes,
6575 Shared);
6576
6577 Name_Loc : Name_Location;
6578 Has_Explicit_Sources : Boolean;
6579
6580 begin
6581 pragma Assert (Sources.Kind = List, "Source_Files is not a list");
6582 pragma Assert
6583 (Source_List_File.Kind = Single,
6584 "Source_List_File is not a single string");
6585
6586 Project.Source_List_File_Location := Source_List_File.Location;
6587
6588 -- If the user has specified a Source_Files attribute
6589
6590 if not Sources.Default then
6591 if not Source_List_File.Default then
6592 Error_Msg
6593 (Data.Flags,
6594 "?both attributes source_files and " &
6595 "source_list_file are present",
6596 Source_List_File.Location, Project.Project);
6597 end if;
6598
6599 -- Sources is a list of file names
6600
6601 declare
6602 Current : String_List_Id := Sources.Values;
6603 Element : String_Element;
6604 Location : Source_Ptr;
6605 Name : File_Name_Type;
6606
6607 begin
6608 if Current = Nil_String then
6609 Project.Project.Languages := No_Language_Index;
6610
6611 -- This project contains no source. For projects that don't
6612 -- extend other projects, this also means that there is no
6613 -- need for an object directory, if not specified.
6614
6615 if Project.Project.Extends = No_Project
6616 and then
6617 Project.Project.Object_Directory = Project.Project.Directory
6618 and then not (Project.Project.Qualifier = Aggregate_Library)
6619 then
6620 Project.Project.Object_Directory := No_Path_Information;
6621 end if;
6622 end if;
6623
6624 while Current /= Nil_String loop
6625 Element := Shared.String_Elements.Table (Current);
6626 Name := Canonical_Case_File_Name (Element.Value);
6627 Get_Name_String (Element.Value);
6628
6629 -- If the element has no location, then use the location of
6630 -- Sources to report possible errors.
6631
6632 if Element.Location = No_Location then
6633 Location := Sources.Location;
6634 else
6635 Location := Element.Location;
6636 end if;
6637
6638 -- Check that there is no directory information
6639
6640 for J in 1 .. Name_Len loop
6641 if Is_Directory_Separator (Name_Buffer (J)) then
6642 Error_Msg_File_1 := Name;
6643 Error_Msg
6644 (Data.Flags,
6645 "file name cannot include directory " &
6646 "information ({)",
6647 Location, Project.Project);
6648 exit;
6649 end if;
6650 end loop;
6651
6652 -- Check whether the file is already there: the same file name
6653 -- may be in the list. If the source is missing, the error will
6654 -- be on the first mention of the source file name.
6655
6656 Name_Loc := Source_Names_Htable.Get
6657 (Project.Source_Names, Name);
6658
6659 if Name_Loc = No_Name_Location then
6660 Name_Loc :=
6661 (Name => Name,
6662 Location => Location,
6663 Source => No_Source,
6664 Listed => True,
6665 Found => False);
6666
6667 else
6668 Name_Loc.Listed := True;
6669 end if;
6670
6671 Source_Names_Htable.Set
6672 (Project.Source_Names, Name, Name_Loc);
6673
6674 Current := Element.Next;
6675 end loop;
6676
6677 Has_Explicit_Sources := True;
6678 end;
6679
6680 -- If we have no Source_Files attribute, check the Source_List_File
6681 -- attribute.
6682
6683 elsif not Source_List_File.Default then
6684
6685 -- Source_List_File is the name of the file that contains the source
6686 -- file names.
6687
6688 declare
6689 Source_File_Path_Name : constant String :=
6690 Path_Name_Of
6691 (File_Name_Type
6692 (Source_List_File.Value),
6693 Project.Project.
6694 Directory.Display_Name);
6695
6696 begin
6697 Has_Explicit_Sources := True;
6698
6699 if Source_File_Path_Name'Length = 0 then
6700 Err_Vars.Error_Msg_File_1 :=
6701 File_Name_Type (Source_List_File.Value);
6702 Error_Msg
6703 (Data.Flags,
6704 "file with sources { does not exist",
6705 Source_List_File.Location, Project.Project);
6706
6707 else
6708 Get_Sources_From_File
6709 (Source_File_Path_Name, Source_List_File.Location,
6710 Project, Data);
6711 end if;
6712 end;
6713
6714 else
6715 -- Neither Source_Files nor Source_List_File has been specified. Find
6716 -- all the files that satisfy the naming scheme in all the source
6717 -- directories.
6718
6719 Has_Explicit_Sources := False;
6720 end if;
6721
6722 -- Remove any exception that is not in the specified list of sources
6723
6724 if Has_Explicit_Sources then
6725 declare
6726 Source : Source_Id;
6727 Iter : Source_Iterator;
6728 NL : Name_Location;
6729 Again : Boolean;
6730 begin
6731 Iter_Loop :
6732 loop
6733 Again := False;
6734 Iter := For_Each_Source (Data.Tree, Project.Project);
6735
6736 Source_Loop :
6737 loop
6738 Source := Prj.Element (Iter);
6739 exit Source_Loop when Source = No_Source;
6740
6741 if Source.Naming_Exception /= No then
6742 NL := Source_Names_Htable.Get
6743 (Project.Source_Names, Source.File);
6744
6745 if NL /= No_Name_Location and then not NL.Listed then
6746
6747 -- Remove the exception
6748
6749 Source_Names_Htable.Set
6750 (Project.Source_Names,
6751 Source.File,
6752 No_Name_Location);
6753 Remove_Source (Data.Tree, Source, No_Source);
6754
6755 if Source.Naming_Exception = Yes then
6756 Error_Msg_Name_1 := Name_Id (Source.File);
6757 Error_Msg
6758 (Data.Flags,
6759 "? unknown source file %%",
6760 NL.Location,
6761 Project.Project);
6762 end if;
6763
6764 Again := True;
6765 exit Source_Loop;
6766 end if;
6767 end if;
6768
6769 Next (Iter);
6770 end loop Source_Loop;
6771
6772 exit Iter_Loop when not Again;
6773 end loop Iter_Loop;
6774 end;
6775 end if;
6776
6777 Search_Directories
6778 (Project,
6779 Data => Data,
6780 For_All_Sources => Sources.Default and then Source_List_File.Default);
6781
6782 -- Check if all exceptions have been found
6783
6784 declare
6785 Source : Source_Id;
6786 Iter : Source_Iterator;
6787 Found : Boolean := False;
6788
6789 begin
6790 Iter := For_Each_Source (Data.Tree, Project.Project);
6791 loop
6792 Source := Prj.Element (Iter);
6793 exit when Source = No_Source;
6794
6795 -- If the full source path is unknown for this source_id, there
6796 -- could be several reasons:
6797 -- * we simply did not find the file itself, this is an error
6798 -- * we have a multi-unit source file. Another Source_Id from
6799 -- the same file has received the full path, so we need to
6800 -- propagate it.
6801
6802 if Source.Path = No_Path_Information then
6803 if Source.Naming_Exception = Yes then
6804 if Source.Unit /= No_Unit_Index then
6805 Found := False;
6806
6807 if Source.Index /= 0 then -- Only multi-unit files
6808 declare
6809 S : Source_Id :=
6810 Source_Files_Htable.Get
6811 (Data.Tree.Source_Files_HT, Source.File);
6812
6813 begin
6814 while S /= null loop
6815 if S.Path /= No_Path_Information then
6816 Source.Path := S.Path;
6817 Found := True;
6818
6819 if Current_Verbosity = High then
6820 Debug_Output
6821 ("setting full path for "
6822 & Get_Name_String (Source.File)
6823 & " at" & Source.Index'Img
6824 & " to "
6825 & Get_Name_String (Source.Path.Name));
6826 end if;
6827
6828 exit;
6829 end if;
6830
6831 S := S.Next_With_File_Name;
6832 end loop;
6833 end;
6834 end if;
6835
6836 if not Found then
6837 Error_Msg_Name_1 := Name_Id (Source.Display_File);
6838 Error_Msg_Name_2 := Source.Unit.Name;
6839 Error_Or_Warning
6840 (Data.Flags, Data.Flags.Missing_Source_Files,
6841 "\source file %% for unit %% not found",
6842 No_Location, Project.Project);
6843 end if;
6844 end if;
6845
6846 if Source.Path = No_Path_Information then
6847 Remove_Source (Data.Tree, Source, No_Source);
6848 end if;
6849
6850 elsif Source.Naming_Exception = Inherited then
6851 Remove_Source (Data.Tree, Source, No_Source);
6852 end if;
6853 end if;
6854
6855 Next (Iter);
6856 end loop;
6857 end;
6858
6859 -- It is an error if a source file name in a source list or in a source
6860 -- list file is not found.
6861
6862 if Has_Explicit_Sources then
6863 declare
6864 NL : Name_Location;
6865 First_Error : Boolean;
6866
6867 begin
6868 NL := Source_Names_Htable.Get_First (Project.Source_Names);
6869 First_Error := True;
6870 while NL /= No_Name_Location loop
6871 if not NL.Found then
6872 Err_Vars.Error_Msg_File_1 := NL.Name;
6873 if First_Error then
6874 Error_Or_Warning
6875 (Data.Flags, Data.Flags.Missing_Source_Files,
6876 "source file { not found",
6877 NL.Location, Project.Project);
6878 First_Error := False;
6879 else
6880 Error_Or_Warning
6881 (Data.Flags, Data.Flags.Missing_Source_Files,
6882 "\source file { not found",
6883 NL.Location, Project.Project);
6884 end if;
6885 end if;
6886
6887 NL := Source_Names_Htable.Get_Next (Project.Source_Names);
6888 end loop;
6889 end;
6890 end if;
6891 end Find_Sources;
6892
6893 ----------------
6894 -- Initialize --
6895 ----------------
6896
6897 procedure Initialize
6898 (Data : out Tree_Processing_Data;
6899 Tree : Project_Tree_Ref;
6900 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
6901 Flags : Prj.Processing_Flags)
6902 is
6903 begin
6904 Data.Tree := Tree;
6905 Data.Node_Tree := Node_Tree;
6906 Data.Flags := Flags;
6907 end Initialize;
6908
6909 ----------
6910 -- Free --
6911 ----------
6912
6913 procedure Free (Data : in out Tree_Processing_Data) is
6914 pragma Unreferenced (Data);
6915 begin
6916 null;
6917 end Free;
6918
6919 ----------------
6920 -- Initialize --
6921 ----------------
6922
6923 procedure Initialize
6924 (Data : in out Project_Processing_Data;
6925 Project : Project_Id)
6926 is
6927 begin
6928 Data.Project := Project;
6929 end Initialize;
6930
6931 ----------
6932 -- Free --
6933 ----------
6934
6935 procedure Free (Data : in out Project_Processing_Data) is
6936 begin
6937 Source_Names_Htable.Reset (Data.Source_Names);
6938 Unit_Exceptions_Htable.Reset (Data.Unit_Exceptions);
6939 Excluded_Sources_Htable.Reset (Data.Excluded);
6940 end Free;
6941
6942 -------------------------------
6943 -- Check_File_Naming_Schemes --
6944 -------------------------------
6945
6946 procedure Check_File_Naming_Schemes
6947 (Project : Project_Processing_Data;
6948 File_Name : File_Name_Type;
6949 Alternate_Languages : out Language_List;
6950 Language : out Language_Ptr;
6951 Display_Language_Name : out Name_Id;
6952 Unit : out Name_Id;
6953 Lang_Kind : out Language_Kind;
6954 Kind : out Source_Kind)
6955 is
6956 Filename : constant String := Get_Name_String (File_Name);
6957 Config : Language_Config;
6958 Tmp_Lang : Language_Ptr;
6959
6960 Header_File : Boolean := False;
6961 -- True if we found at least one language for which the file is a header
6962 -- In such a case, we search for all possible languages where this is
6963 -- also a header (C and C++ for instance), since the file might be used
6964 -- for several such languages.
6965
6966 procedure Check_File_Based_Lang;
6967 -- Does the naming scheme test for file-based languages. For those,
6968 -- there is no Unit. Just check if the file name has the implementation
6969 -- or, if it is specified, the template suffix of the language.
6970 --
6971 -- Returns True if the file belongs to the current language and we
6972 -- should stop searching for matching languages. Not that a given header
6973 -- file could belong to several languages (C and C++ for instance). Thus
6974 -- if we found a header we'll check whether it matches other languages.
6975
6976 ---------------------------
6977 -- Check_File_Based_Lang --
6978 ---------------------------
6979
6980 procedure Check_File_Based_Lang is
6981 begin
6982 if not Header_File
6983 and then Suffix_Matches (Filename, Config.Naming_Data.Body_Suffix)
6984 then
6985 Unit := No_Name;
6986 Kind := Impl;
6987 Language := Tmp_Lang;
6988
6989 Debug_Output
6990 ("implementation of language ", Display_Language_Name);
6991
6992 elsif Suffix_Matches (Filename, Config.Naming_Data.Spec_Suffix) then
6993 Debug_Output
6994 ("header of language ", Display_Language_Name);
6995
6996 if Header_File then
6997 Alternate_Languages := new Language_List_Element'
6998 (Language => Language,
6999 Next => Alternate_Languages);
7000
7001 else
7002 Header_File := True;
7003 Kind := Spec;
7004 Unit := No_Name;
7005 Language := Tmp_Lang;
7006 end if;
7007 end if;
7008 end Check_File_Based_Lang;
7009
7010 -- Start of processing for Check_File_Naming_Schemes
7011
7012 begin
7013 Language := No_Language_Index;
7014 Alternate_Languages := null;
7015 Display_Language_Name := No_Name;
7016 Unit := No_Name;
7017 Lang_Kind := File_Based;
7018 Kind := Spec;
7019
7020 Tmp_Lang := Project.Project.Languages;
7021 while Tmp_Lang /= No_Language_Index loop
7022 if Current_Verbosity = High then
7023 Debug_Output
7024 ("testing language "
7025 & Get_Name_String (Tmp_Lang.Name)
7026 & " Header_File=" & Header_File'Img);
7027 end if;
7028
7029 Display_Language_Name := Tmp_Lang.Display_Name;
7030 Config := Tmp_Lang.Config;
7031 Lang_Kind := Config.Kind;
7032
7033 case Config.Kind is
7034 when File_Based =>
7035 Check_File_Based_Lang;
7036 exit when Kind = Impl;
7037
7038 when Unit_Based =>
7039
7040 -- We know it belongs to a least a file_based language, no
7041 -- need to check unit-based ones.
7042
7043 if not Header_File then
7044 Compute_Unit_Name
7045 (File_Name => File_Name,
7046 Naming => Config.Naming_Data,
7047 Kind => Kind,
7048 Unit => Unit,
7049 Project => Project);
7050
7051 if Unit /= No_Name then
7052 Language := Tmp_Lang;
7053 exit;
7054 end if;
7055 end if;
7056 end case;
7057
7058 Tmp_Lang := Tmp_Lang.Next;
7059 end loop;
7060
7061 if Language = No_Language_Index then
7062 Debug_Output ("not a source of any language");
7063 end if;
7064 end Check_File_Naming_Schemes;
7065
7066 -------------------
7067 -- Override_Kind --
7068 -------------------
7069
7070 procedure Override_Kind (Source : Source_Id; Kind : Source_Kind) is
7071 begin
7072 -- If the file was previously already associated with a unit, change it
7073
7074 if Source.Unit /= null
7075 and then Source.Kind in Spec_Or_Body
7076 and then Source.Unit.File_Names (Source.Kind) /= null
7077 then
7078 -- If we had another file referencing the same unit (for instance it
7079 -- was in an extended project), that source file is in fact invisible
7080 -- from now on, and in particular doesn't belong to the same unit.
7081 -- If the source is an inherited naming exception, then it may not
7082 -- really exist: the source potentially replaced is left untouched.
7083
7084 if Source.Unit.File_Names (Source.Kind) /= Source then
7085 Source.Unit.File_Names (Source.Kind).Unit := No_Unit_Index;
7086 end if;
7087
7088 Source.Unit.File_Names (Source.Kind) := null;
7089 end if;
7090
7091 Source.Kind := Kind;
7092
7093 if Current_Verbosity = High and then Source.File /= No_File then
7094 Debug_Output ("override kind for "
7095 & Get_Name_String (Source.File)
7096 & " idx=" & Source.Index'Img
7097 & " kind=" & Source.Kind'Img);
7098 end if;
7099
7100 if Source.Unit /= null then
7101 if Source.Kind = Spec then
7102 Source.Unit.File_Names (Spec) := Source;
7103 else
7104 Source.Unit.File_Names (Impl) := Source;
7105 end if;
7106 end if;
7107 end Override_Kind;
7108
7109 ----------------
7110 -- Check_File --
7111 ----------------
7112
7113 procedure Check_File
7114 (Project : in out Project_Processing_Data;
7115 Data : in out Tree_Processing_Data;
7116 Source_Dir_Rank : Natural;
7117 Path : Path_Name_Type;
7118 Display_Path : Path_Name_Type;
7119 File_Name : File_Name_Type;
7120 Display_File_Name : File_Name_Type;
7121 Locally_Removed : Boolean;
7122 For_All_Sources : Boolean)
7123 is
7124 Name_Loc : Name_Location :=
7125 Source_Names_Htable.Get
7126 (Project.Source_Names, File_Name);
7127 Check_Name : Boolean := False;
7128 Alternate_Languages : Language_List;
7129 Language : Language_Ptr;
7130 Source : Source_Id;
7131 Src_Ind : Source_File_Index;
7132 Unit : Name_Id;
7133 Display_Language_Name : Name_Id;
7134 Lang_Kind : Language_Kind;
7135 Kind : Source_Kind := Spec;
7136
7137 begin
7138 if Current_Verbosity = High then
7139 Debug_Increase_Indent
7140 ("checking file (rank=" & Source_Dir_Rank'Img & ")",
7141 Name_Id (Display_Path));
7142 end if;
7143
7144 if Name_Loc = No_Name_Location then
7145 Check_Name := For_All_Sources;
7146
7147 else
7148 if Name_Loc.Found then
7149
7150 -- Check if it is OK to have the same file name in several
7151 -- source directories.
7152
7153 if Name_Loc.Source /= No_Source
7154 and then Source_Dir_Rank = Name_Loc.Source.Source_Dir_Rank
7155 then
7156 Error_Msg_File_1 := File_Name;
7157 Error_Msg
7158 (Data.Flags,
7159 "{ is found in several source directories",
7160 Name_Loc.Location, Project.Project);
7161 end if;
7162
7163 else
7164 Name_Loc.Found := True;
7165
7166 Source_Names_Htable.Set
7167 (Project.Source_Names, File_Name, Name_Loc);
7168
7169 if Name_Loc.Source = No_Source then
7170 Check_Name := True;
7171
7172 else
7173 -- Set the full path for the source_id (which might have been
7174 -- created when parsing the naming exceptions, and therefore
7175 -- might not have the full path).
7176 -- We only set this for this source_id, but not for other
7177 -- source_id in the same file (case of multi-unit source files)
7178 -- For the latter, they will be set in Find_Sources when we
7179 -- check that all source_id have known full paths.
7180 -- Doing this later saves one htable lookup per file in the
7181 -- common case where the user is not using multi-unit files.
7182
7183 Name_Loc.Source.Path := (Path, Display_Path);
7184
7185 Source_Paths_Htable.Set
7186 (Data.Tree.Source_Paths_HT, Path, Name_Loc.Source);
7187
7188 -- Check if this is a subunit
7189
7190 if Name_Loc.Source.Unit /= No_Unit_Index
7191 and then Name_Loc.Source.Kind = Impl
7192 then
7193 Src_Ind := Sinput.P.Load_Project_File
7194 (Get_Name_String (Display_Path));
7195
7196 if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
7197 Override_Kind (Name_Loc.Source, Sep);
7198 end if;
7199 end if;
7200
7201 -- If this is an inherited naming exception, make sure that
7202 -- the naming exception it replaces is no longer a source.
7203
7204 if Name_Loc.Source.Naming_Exception = Inherited then
7205 declare
7206 Proj : Project_Id := Name_Loc.Source.Project.Extends;
7207 Iter : Source_Iterator;
7208 Src : Source_Id;
7209 begin
7210 while Proj /= No_Project loop
7211 Iter := For_Each_Source (Data.Tree, Proj);
7212 Src := Prj.Element (Iter);
7213 while Src /= No_Source loop
7214 if Src.File = Name_Loc.Source.File then
7215 Src.Replaced_By := Name_Loc.Source;
7216 exit;
7217 end if;
7218
7219 Next (Iter);
7220 Src := Prj.Element (Iter);
7221 end loop;
7222
7223 Proj := Proj.Extends;
7224 end loop;
7225 end;
7226
7227 if Name_Loc.Source.Unit /= No_Unit_Index then
7228 if Name_Loc.Source.Kind = Spec then
7229 Name_Loc.Source.Unit.File_Names (Spec) :=
7230 Name_Loc.Source;
7231
7232 elsif Name_Loc.Source.Kind = Impl then
7233 Name_Loc.Source.Unit.File_Names (Impl) :=
7234 Name_Loc.Source;
7235 end if;
7236
7237 Units_Htable.Set
7238 (Data.Tree.Units_HT,
7239 Name_Loc.Source.Unit.Name,
7240 Name_Loc.Source.Unit);
7241 end if;
7242 end if;
7243 end if;
7244 end if;
7245 end if;
7246
7247 if Check_Name then
7248 Check_File_Naming_Schemes
7249 (Project => Project,
7250 File_Name => File_Name,
7251 Alternate_Languages => Alternate_Languages,
7252 Language => Language,
7253 Display_Language_Name => Display_Language_Name,
7254 Unit => Unit,
7255 Lang_Kind => Lang_Kind,
7256 Kind => Kind);
7257
7258 if Language = No_Language_Index then
7259
7260 -- A file name in a list must be a source of a language
7261
7262 if Data.Flags.Error_On_Unknown_Language and then Name_Loc.Found
7263 then
7264 Error_Msg_File_1 := File_Name;
7265 Error_Msg
7266 (Data.Flags,
7267 "language unknown for {",
7268 Name_Loc.Location, Project.Project);
7269 end if;
7270
7271 else
7272 Add_Source
7273 (Id => Source,
7274 Project => Project.Project,
7275 Source_Dir_Rank => Source_Dir_Rank,
7276 Lang_Id => Language,
7277 Kind => Kind,
7278 Data => Data,
7279 Alternate_Languages => Alternate_Languages,
7280 File_Name => File_Name,
7281 Display_File => Display_File_Name,
7282 Unit => Unit,
7283 Locally_Removed => Locally_Removed,
7284 Path => (Path, Display_Path));
7285
7286 -- If it is a source specified in a list, update the entry in
7287 -- the Source_Names table.
7288
7289 if Name_Loc.Found and then Name_Loc.Source = No_Source then
7290 Name_Loc.Source := Source;
7291 Source_Names_Htable.Set
7292 (Project.Source_Names, File_Name, Name_Loc);
7293 end if;
7294 end if;
7295 end if;
7296
7297 Debug_Decrease_Indent;
7298 end Check_File;
7299
7300 ---------------------------------
7301 -- Expand_Subdirectory_Pattern --
7302 ---------------------------------
7303
7304 procedure Expand_Subdirectory_Pattern
7305 (Project : Project_Id;
7306 Data : in out Tree_Processing_Data;
7307 Patterns : String_List_Id;
7308 Ignore : String_List_Id;
7309 Search_For : Search_Type;
7310 Resolve_Links : Boolean)
7311 is
7312 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
7313
7314 package Recursive_Dirs is new GNAT.Dynamic_HTables.Simple_HTable
7315 (Header_Num => Header_Num,
7316 Element => Boolean,
7317 No_Element => False,
7318 Key => Path_Name_Type,
7319 Hash => Hash,
7320 Equal => "=");
7321 -- Hash table stores recursive source directories, to avoid looking
7322 -- several times, and to avoid cycles that may be introduced by symbolic
7323 -- links.
7324
7325 File_Pattern : GNAT.Regexp.Regexp;
7326 -- Pattern to use when matching file names
7327
7328 Visited : Recursive_Dirs.Instance;
7329
7330 procedure Find_Pattern
7331 (Pattern_Id : Name_Id;
7332 Rank : Natural;
7333 Location : Source_Ptr);
7334 -- Find a specific pattern
7335
7336 function Recursive_Find_Dirs
7337 (Path : Path_Information;
7338 Rank : Natural) return Boolean;
7339 -- Search all the subdirectories (recursively) of Path.
7340 -- Return True if at least one file or directory was processed
7341
7342 function Subdirectory_Matches
7343 (Path : Path_Information;
7344 Rank : Natural) return Boolean;
7345 -- Called when a matching directory was found. If the user is in fact
7346 -- searching for files, we then search for those files matching the
7347 -- pattern within the directory.
7348 -- Return True if at least one file or directory was processed
7349
7350 --------------------------
7351 -- Subdirectory_Matches --
7352 --------------------------
7353
7354 function Subdirectory_Matches
7355 (Path : Path_Information;
7356 Rank : Natural) return Boolean
7357 is
7358 Dir : Dir_Type;
7359 Name : String (1 .. 250);
7360 Last : Natural;
7361 Found : Path_Information;
7362 Success : Boolean := False;
7363
7364 begin
7365 case Search_For is
7366 when Search_Directories =>
7367 Callback (Path, Rank);
7368 return True;
7369
7370 when Search_Files =>
7371 Open (Dir, Get_Name_String (Path.Display_Name));
7372 loop
7373 Read (Dir, Name, Last);
7374 exit when Last = 0;
7375
7376 if Name (Name'First .. Last) /= "."
7377 and then Name (Name'First .. Last) /= ".."
7378 and then Match (Name (Name'First .. Last), File_Pattern)
7379 then
7380 Get_Name_String (Path.Display_Name);
7381 Add_Str_To_Name_Buffer (Name (Name'First .. Last));
7382
7383 Found.Display_Name := Name_Find;
7384 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
7385 Found.Name := Name_Find;
7386
7387 Callback (Found, Rank);
7388 Success := True;
7389 end if;
7390 end loop;
7391
7392 Close (Dir);
7393
7394 return Success;
7395 end case;
7396 end Subdirectory_Matches;
7397
7398 -------------------------
7399 -- Recursive_Find_Dirs --
7400 -------------------------
7401
7402 function Recursive_Find_Dirs
7403 (Path : Path_Information;
7404 Rank : Natural) return Boolean
7405 is
7406 Path_Str : constant String := Get_Name_String (Path.Display_Name);
7407 Dir : Dir_Type;
7408 Name : String (1 .. 250);
7409 Last : Natural;
7410 Success : Boolean := False;
7411
7412 begin
7413 Debug_Output ("looking for subdirs of ", Name_Id (Path.Display_Name));
7414
7415 if Recursive_Dirs.Get (Visited, Path.Name) then
7416 return Success;
7417 end if;
7418
7419 Recursive_Dirs.Set (Visited, Path.Name, True);
7420
7421 Success := Subdirectory_Matches (Path, Rank) or Success;
7422
7423 Open (Dir, Path_Str);
7424
7425 loop
7426 Read (Dir, Name, Last);
7427 exit when Last = 0;
7428
7429 if Name (1 .. Last) /= "." and then Name (1 .. Last) /= ".." then
7430 declare
7431 Path_Name : constant String :=
7432 Normalize_Pathname
7433 (Name => Name (1 .. Last),
7434 Directory => Path_Str,
7435 Resolve_Links => Resolve_Links)
7436 & Directory_Separator;
7437
7438 Path2 : Path_Information;
7439 OK : Boolean := True;
7440
7441 begin
7442 if Is_Directory (Path_Name) then
7443 if Ignore /= Nil_String then
7444 declare
7445 Dir_Name : String := Name (1 .. Last);
7446 List : String_List_Id := Ignore;
7447
7448 begin
7449 Canonical_Case_File_Name (Dir_Name);
7450
7451 while List /= Nil_String loop
7452 Get_Name_String
7453 (Shared.String_Elements.Table (List).Value);
7454 Canonical_Case_File_Name
7455 (Name_Buffer (1 .. Name_Len));
7456 OK := Name_Buffer (1 .. Name_Len) /= Dir_Name;
7457 exit when not OK;
7458 List := Shared.String_Elements.Table (List).Next;
7459 end loop;
7460 end;
7461 end if;
7462
7463 if OK then
7464 Name_Len := 0;
7465 Add_Str_To_Name_Buffer (Path_Name);
7466 Path2.Display_Name := Name_Find;
7467
7468 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
7469 Path2.Name := Name_Find;
7470
7471 Success :=
7472 Recursive_Find_Dirs (Path2, Rank) or Success;
7473 end if;
7474 end if;
7475 end;
7476 end if;
7477 end loop;
7478
7479 Close (Dir);
7480
7481 return Success;
7482
7483 exception
7484 when Directory_Error =>
7485 return Success;
7486 end Recursive_Find_Dirs;
7487
7488 ------------------
7489 -- Find_Pattern --
7490 ------------------
7491
7492 procedure Find_Pattern
7493 (Pattern_Id : Name_Id;
7494 Rank : Natural;
7495 Location : Source_Ptr)
7496 is
7497 Pattern : constant String := Get_Name_String (Pattern_Id);
7498 Pattern_End : Natural := Pattern'Last;
7499 Recursive : Boolean;
7500 Dir : File_Name_Type;
7501 Path_Name : Path_Information;
7502 Dir_Exists : Boolean;
7503 Has_Error : Boolean := False;
7504 Success : Boolean;
7505
7506 begin
7507 Debug_Increase_Indent ("Find_Pattern", Pattern_Id);
7508
7509 -- If we are looking for files, find the pattern for the files
7510
7511 if Search_For = Search_Files then
7512 while Pattern_End >= Pattern'First
7513 and then not Is_Directory_Separator (Pattern (Pattern_End))
7514 loop
7515 Pattern_End := Pattern_End - 1;
7516 end loop;
7517
7518 if Pattern_End = Pattern'Last then
7519 Err_Vars.Error_Msg_File_1 := File_Name_Type (Pattern_Id);
7520 Error_Or_Warning
7521 (Data.Flags, Data.Flags.Missing_Source_Files,
7522 "Missing file name or pattern in {", Location, Project);
7523 return;
7524 end if;
7525
7526 if Current_Verbosity = High then
7527 Debug_Indent;
7528 Write_Str ("file_pattern=");
7529 Write_Str (Pattern (Pattern_End + 1 .. Pattern'Last));
7530 Write_Str (" dir_pattern=");
7531 Write_Line (Pattern (Pattern'First .. Pattern_End));
7532 end if;
7533
7534 File_Pattern := Compile
7535 (Pattern (Pattern_End + 1 .. Pattern'Last),
7536 Glob => True,
7537 Case_Sensitive => File_Names_Case_Sensitive);
7538
7539 -- If we had just "*.gpr", this is equivalent to "./*.gpr"
7540
7541 if Pattern_End > Pattern'First then
7542 Pattern_End := Pattern_End - 1; -- Skip directory separator
7543 end if;
7544 end if;
7545
7546 Recursive :=
7547 Pattern_End - 1 >= Pattern'First
7548 and then Pattern (Pattern_End - 1 .. Pattern_End) = "**"
7549 and then
7550 (Pattern_End - 1 = Pattern'First
7551 or else Is_Directory_Separator (Pattern (Pattern_End - 2)));
7552
7553 if Recursive then
7554 Pattern_End := Pattern_End - 2;
7555 if Pattern_End > Pattern'First then
7556 Pattern_End := Pattern_End - 1; -- Skip '/'
7557 end if;
7558 end if;
7559
7560 Name_Len := Pattern_End - Pattern'First + 1;
7561 Name_Buffer (1 .. Name_Len) := Pattern (Pattern'First .. Pattern_End);
7562 Dir := Name_Find;
7563
7564 Locate_Directory
7565 (Project => Project,
7566 Name => Dir,
7567 Path => Path_Name,
7568 Dir_Exists => Dir_Exists,
7569 Data => Data,
7570 Must_Exist => False);
7571
7572 if not Dir_Exists then
7573 Err_Vars.Error_Msg_File_1 := Dir;
7574 Error_Or_Warning
7575 (Data.Flags, Data.Flags.Missing_Source_Files,
7576 "{ is not a valid directory", Location, Project);
7577 Has_Error := Data.Flags.Missing_Source_Files = Error;
7578 end if;
7579
7580 if not Has_Error then
7581
7582 -- Links have been resolved if necessary, and Path_Name
7583 -- always ends with a directory separator.
7584
7585 if Recursive then
7586 Success := Recursive_Find_Dirs (Path_Name, Rank);
7587 else
7588 Success := Subdirectory_Matches (Path_Name, Rank);
7589 end if;
7590
7591 if not Success then
7592 case Search_For is
7593 when Search_Directories =>
7594 null; -- Error can't occur
7595
7596 when Search_Files =>
7597 Err_Vars.Error_Msg_File_1 := File_Name_Type (Pattern_Id);
7598 Error_Or_Warning
7599 (Data.Flags, Data.Flags.Missing_Source_Files,
7600 "file { not found", Location, Project);
7601 end case;
7602 end if;
7603 end if;
7604
7605 Debug_Decrease_Indent ("done Find_Pattern");
7606 end Find_Pattern;
7607
7608 -- Local variables
7609
7610 Pattern_Id : String_List_Id := Patterns;
7611 Element : String_Element;
7612 Rank : Natural := 1;
7613
7614 -- Start of processing for Expand_Subdirectory_Pattern
7615
7616 begin
7617 while Pattern_Id /= Nil_String loop
7618 Element := Shared.String_Elements.Table (Pattern_Id);
7619 Find_Pattern (Element.Value, Rank, Element.Location);
7620 Rank := Rank + 1;
7621 Pattern_Id := Element.Next;
7622 end loop;
7623
7624 Recursive_Dirs.Reset (Visited);
7625 end Expand_Subdirectory_Pattern;
7626
7627 ------------------------
7628 -- Search_Directories --
7629 ------------------------
7630
7631 procedure Search_Directories
7632 (Project : in out Project_Processing_Data;
7633 Data : in out Tree_Processing_Data;
7634 For_All_Sources : Boolean)
7635 is
7636 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
7637
7638 Source_Dir : String_List_Id;
7639 Element : String_Element;
7640 Src_Dir_Rank : Number_List_Index;
7641 Num_Nod : Number_Node;
7642 Dir : Dir_Type;
7643 Name : String (1 .. 1_000);
7644 Last : Natural;
7645 File_Name : File_Name_Type;
7646 Display_File_Name : File_Name_Type;
7647
7648 begin
7649 Debug_Increase_Indent ("looking for sources of", Project.Project.Name);
7650
7651 -- Loop through subdirectories
7652
7653 Src_Dir_Rank := Project.Project.Source_Dir_Ranks;
7654
7655 Source_Dir := Project.Project.Source_Dirs;
7656 while Source_Dir /= Nil_String loop
7657 begin
7658 Num_Nod := Shared.Number_Lists.Table (Src_Dir_Rank);
7659 Element := Shared.String_Elements.Table (Source_Dir);
7660
7661 -- Use Element.Value in this test, not Display_Value, because we
7662 -- want the symbolic links to be resolved when appropriate.
7663
7664 if Element.Value /= No_Name then
7665 declare
7666 Source_Directory : constant String :=
7667 Get_Name_String (Element.Value)
7668 & Directory_Separator;
7669
7670 Dir_Last : constant Natural :=
7671 Compute_Directory_Last (Source_Directory);
7672
7673 Display_Source_Directory : constant String :=
7674 Get_Name_String
7675 (Element.Display_Value)
7676 & Directory_Separator;
7677 -- Display_Source_Directory is to allow us to open a UTF-8
7678 -- encoded directory on Windows.
7679
7680 begin
7681 if Current_Verbosity = High then
7682 Debug_Increase_Indent
7683 ("Source_Dir (node=" & Num_Nod.Number'Img & ") """
7684 & Source_Directory (Source_Directory'First .. Dir_Last)
7685 & '"');
7686 end if;
7687
7688 -- We look to every entry in the source directory
7689
7690 Open (Dir, Display_Source_Directory);
7691
7692 loop
7693 Read (Dir, Name, Last);
7694 exit when Last = 0;
7695
7696 -- In fast project loading mode (without -eL), the user
7697 -- guarantees that no directory has a name which is a
7698 -- valid source name, so we can avoid doing a system call
7699 -- here. This provides a very significant speed up on
7700 -- slow file systems (remote files for instance).
7701
7702 if not Opt.Follow_Links_For_Files
7703 or else Is_Regular_File
7704 (Display_Source_Directory & Name (1 .. Last))
7705 then
7706 Name_Len := Last;
7707 Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
7708 Display_File_Name := Name_Find;
7709
7710 if Osint.File_Names_Case_Sensitive then
7711 File_Name := Display_File_Name;
7712 else
7713 Canonical_Case_File_Name
7714 (Name_Buffer (1 .. Name_Len));
7715 File_Name := Name_Find;
7716 end if;
7717
7718 declare
7719 Path_Name : constant String :=
7720 Normalize_Pathname
7721 (Name (1 .. Last),
7722 Directory =>
7723 Source_Directory
7724 (Source_Directory'First ..
7725 Dir_Last),
7726 Resolve_Links =>
7727 Opt.Follow_Links_For_Files,
7728 Case_Sensitive => True);
7729
7730 Path : Path_Name_Type;
7731 FF : File_Found :=
7732 Excluded_Sources_Htable.Get
7733 (Project.Excluded, File_Name);
7734 To_Remove : Boolean := False;
7735
7736 begin
7737 Name_Len := Path_Name'Length;
7738 Name_Buffer (1 .. Name_Len) := Path_Name;
7739
7740 if Osint.File_Names_Case_Sensitive then
7741 Path := Name_Find;
7742 else
7743 Canonical_Case_File_Name
7744 (Name_Buffer (1 .. Name_Len));
7745 Path := Name_Find;
7746 end if;
7747
7748 if FF /= No_File_Found then
7749 if not FF.Found then
7750 FF.Found := True;
7751 Excluded_Sources_Htable.Set
7752 (Project.Excluded, File_Name, FF);
7753
7754 Debug_Output
7755 ("excluded source ",
7756 Name_Id (Display_File_Name));
7757
7758 -- Will mark the file as removed, but we
7759 -- still need to add it to the list: if we
7760 -- don't, the file will not appear in the
7761 -- mapping file and will cause the compiler
7762 -- to fail.
7763
7764 To_Remove := True;
7765 end if;
7766 end if;
7767
7768 -- Preserve the user's original casing and use of
7769 -- links. The display_value (a directory) already
7770 -- ends with a directory separator by construction,
7771 -- so no need to add one.
7772
7773 Get_Name_String (Element.Display_Value);
7774 Get_Name_String_And_Append (Display_File_Name);
7775
7776 Check_File
7777 (Project => Project,
7778 Source_Dir_Rank => Num_Nod.Number,
7779 Data => Data,
7780 Path => Path,
7781 Display_Path => Name_Find,
7782 File_Name => File_Name,
7783 Locally_Removed => To_Remove,
7784 Display_File_Name => Display_File_Name,
7785 For_All_Sources => For_All_Sources);
7786 end;
7787
7788 else
7789 if Current_Verbosity = High then
7790 Debug_Output ("ignore " & Name (1 .. Last));
7791 end if;
7792 end if;
7793 end loop;
7794
7795 Debug_Decrease_Indent;
7796 Close (Dir);
7797 end;
7798 end if;
7799
7800 exception
7801 when Directory_Error =>
7802 null;
7803 end;
7804
7805 Source_Dir := Element.Next;
7806 Src_Dir_Rank := Num_Nod.Next;
7807 end loop;
7808
7809 Debug_Decrease_Indent ("end looking for sources.");
7810 end Search_Directories;
7811
7812 ----------------------------
7813 -- Load_Naming_Exceptions --
7814 ----------------------------
7815
7816 procedure Load_Naming_Exceptions
7817 (Project : in out Project_Processing_Data;
7818 Data : in out Tree_Processing_Data)
7819 is
7820 Source : Source_Id;
7821 Iter : Source_Iterator;
7822
7823 begin
7824 Iter := For_Each_Source (Data.Tree, Project.Project);
7825 loop
7826 Source := Prj.Element (Iter);
7827 exit when Source = No_Source;
7828
7829 -- An excluded file cannot also be an exception file name
7830
7831 if Excluded_Sources_Htable.Get (Project.Excluded, Source.File) /=
7832 No_File_Found
7833 then
7834 Error_Msg_File_1 := Source.File;
7835 Error_Msg
7836 (Data.Flags,
7837 "\{ cannot be both excluded and an exception file name",
7838 No_Location, Project.Project);
7839 end if;
7840
7841 Debug_Output
7842 ("naming exception: adding source file to source_Names: ",
7843 Name_Id (Source.File));
7844
7845 Source_Names_Htable.Set
7846 (Project.Source_Names,
7847 K => Source.File,
7848 E => Name_Location'
7849 (Name => Source.File,
7850 Location => Source.Location,
7851 Source => Source,
7852 Listed => False,
7853 Found => False));
7854
7855 -- If this is an Ada exception, record in table Unit_Exceptions
7856
7857 if Source.Unit /= No_Unit_Index then
7858 declare
7859 Unit_Except : Unit_Exception :=
7860 Unit_Exceptions_Htable.Get
7861 (Project.Unit_Exceptions, Source.Unit.Name);
7862
7863 begin
7864 Unit_Except.Name := Source.Unit.Name;
7865
7866 if Source.Kind = Spec then
7867 Unit_Except.Spec := Source.File;
7868 else
7869 Unit_Except.Impl := Source.File;
7870 end if;
7871
7872 Unit_Exceptions_Htable.Set
7873 (Project.Unit_Exceptions, Source.Unit.Name, Unit_Except);
7874 end;
7875 end if;
7876
7877 Next (Iter);
7878 end loop;
7879 end Load_Naming_Exceptions;
7880
7881 ----------------------
7882 -- Look_For_Sources --
7883 ----------------------
7884
7885 procedure Look_For_Sources
7886 (Project : in out Project_Processing_Data;
7887 Data : in out Tree_Processing_Data)
7888 is
7889 Object_Files : Object_File_Names_Htable.Instance;
7890 Iter : Source_Iterator;
7891 Src : Source_Id;
7892
7893 procedure Check_Object (Src : Source_Id);
7894 -- Check if object file name of Src is already used in the project tree,
7895 -- and report an error if so.
7896
7897 procedure Check_Object_Files;
7898 -- Check that no two sources of this project have the same object file
7899
7900 procedure Mark_Excluded_Sources;
7901 -- Mark as such the sources that are declared as excluded
7902
7903 procedure Check_Missing_Sources;
7904 -- Check whether one of the languages has no sources, and report an
7905 -- error when appropriate
7906
7907 procedure Get_Sources_From_Source_Info;
7908 -- Get the source information from the tables that were created when a
7909 -- source info file was read.
7910
7911 ---------------------------
7912 -- Check_Missing_Sources --
7913 ---------------------------
7914
7915 procedure Check_Missing_Sources is
7916 Extending : constant Boolean :=
7917 Project.Project.Extends /= No_Project;
7918 Language : Language_Ptr;
7919 Source : Source_Id;
7920 Alt_Lang : Language_List;
7921 Continuation : Boolean := False;
7922 Iter : Source_Iterator;
7923 begin
7924 if not Project.Project.Externally_Built and then not Extending then
7925 Language := Project.Project.Languages;
7926 while Language /= No_Language_Index loop
7927
7928 -- If there are no sources for this language, check if there
7929 -- are sources for which this is an alternate language.
7930
7931 if Language.First_Source = No_Source
7932 and then (Data.Flags.Require_Sources_Other_Lang
7933 or else Language.Name = Name_Ada)
7934 then
7935 Iter := For_Each_Source (In_Tree => Data.Tree,
7936 Project => Project.Project);
7937 Source_Loop : loop
7938 Source := Element (Iter);
7939 exit Source_Loop when Source = No_Source
7940 or else Source.Language = Language;
7941
7942 Alt_Lang := Source.Alternate_Languages;
7943 while Alt_Lang /= null loop
7944 exit Source_Loop when Alt_Lang.Language = Language;
7945 Alt_Lang := Alt_Lang.Next;
7946 end loop;
7947
7948 Next (Iter);
7949 end loop Source_Loop;
7950
7951 if Source = No_Source then
7952 Report_No_Sources
7953 (Project.Project,
7954 Get_Name_String (Language.Display_Name),
7955 Data,
7956 Project.Source_List_File_Location,
7957 Continuation);
7958 Continuation := True;
7959 end if;
7960 end if;
7961
7962 Language := Language.Next;
7963 end loop;
7964 end if;
7965 end Check_Missing_Sources;
7966
7967 ------------------
7968 -- Check_Object --
7969 ------------------
7970
7971 procedure Check_Object (Src : Source_Id) is
7972 Source : Source_Id;
7973
7974 begin
7975 Source := Object_File_Names_Htable.Get (Object_Files, Src.Object);
7976
7977 -- We cannot just check on "Source /= Src", since we might have
7978 -- two different entries for the same file (and since that's
7979 -- the same file it is expected that it has the same object)
7980
7981 if Source /= No_Source
7982 and then Source.Replaced_By = No_Source
7983 and then Source.Path /= Src.Path
7984 and then Source.Index = 0
7985 and then Src.Index = 0
7986 and then Is_Extending (Src.Project, Source.Project)
7987 then
7988 Error_Msg_File_1 := Src.File;
7989 Error_Msg_File_2 := Source.File;
7990 Error_Msg
7991 (Data.Flags,
7992 "\{ and { have the same object file name",
7993 No_Location, Project.Project);
7994
7995 else
7996 Object_File_Names_Htable.Set (Object_Files, Src.Object, Src);
7997 end if;
7998 end Check_Object;
7999
8000 ---------------------------
8001 -- Mark_Excluded_Sources --
8002 ---------------------------
8003
8004 procedure Mark_Excluded_Sources is
8005 Source : Source_Id := No_Source;
8006 Excluded : File_Found;
8007 Proj : Project_Id;
8008
8009 begin
8010 -- Minor optimization: if there are no excluded files, no need to
8011 -- traverse the list of sources. We cannot however also check whether
8012 -- the existing exceptions have ".Found" set to True (indicating we
8013 -- found them before) because we need to do some final processing on
8014 -- them in any case.
8015
8016 if Excluded_Sources_Htable.Get_First (Project.Excluded) /=
8017 No_File_Found
8018 then
8019 Proj := Project.Project;
8020 while Proj /= No_Project loop
8021 Iter := For_Each_Source (Data.Tree, Proj);
8022 while Prj.Element (Iter) /= No_Source loop
8023 Source := Prj.Element (Iter);
8024 Excluded := Excluded_Sources_Htable.Get
8025 (Project.Excluded, Source.File);
8026
8027 if Excluded /= No_File_Found then
8028 Source.In_Interfaces := False;
8029 Source.Locally_Removed := True;
8030
8031 if Proj = Project.Project then
8032 Source.Suppressed := True;
8033 end if;
8034
8035 if Current_Verbosity = High then
8036 Debug_Indent;
8037 Write_Str ("removing file ");
8038 Write_Line
8039 (Get_Name_String (Excluded.File)
8040 & " " & Get_Name_String (Source.Project.Name));
8041 end if;
8042
8043 Excluded_Sources_Htable.Remove
8044 (Project.Excluded, Source.File);
8045 end if;
8046
8047 Next (Iter);
8048 end loop;
8049
8050 Proj := Proj.Extends;
8051 end loop;
8052 end if;
8053
8054 -- If we have any excluded element left, that means we did not find
8055 -- the source file
8056
8057 Excluded := Excluded_Sources_Htable.Get_First (Project.Excluded);
8058 while Excluded /= No_File_Found loop
8059 if not Excluded.Found then
8060
8061 -- Check if the file belongs to another imported project to
8062 -- provide a better error message.
8063
8064 Src := Find_Source
8065 (In_Tree => Data.Tree,
8066 Project => Project.Project,
8067 In_Imported_Only => True,
8068 Base_Name => Excluded.File);
8069
8070 Err_Vars.Error_Msg_File_1 := Excluded.File;
8071
8072 if Src = No_Source then
8073 if Excluded.Excl_File = No_File then
8074 Error_Msg
8075 (Data.Flags,
8076 "unknown file {", Excluded.Location, Project.Project);
8077
8078 else
8079 Error_Msg
8080 (Data.Flags,
8081 "in " &
8082 Get_Name_String (Excluded.Excl_File) & ":" &
8083 No_Space_Img (Excluded.Excl_Line) &
8084 ": unknown file {", Excluded.Location, Project.Project);
8085 end if;
8086
8087 else
8088 if Excluded.Excl_File = No_File then
8089 Error_Msg
8090 (Data.Flags,
8091 "cannot remove a source from an imported project: {",
8092 Excluded.Location, Project.Project);
8093
8094 else
8095 Error_Msg
8096 (Data.Flags,
8097 "in " &
8098 Get_Name_String (Excluded.Excl_File) & ":" &
8099 No_Space_Img (Excluded.Excl_Line) &
8100 ": cannot remove a source from an imported project: {",
8101 Excluded.Location, Project.Project);
8102 end if;
8103 end if;
8104 end if;
8105
8106 Excluded := Excluded_Sources_Htable.Get_Next (Project.Excluded);
8107 end loop;
8108 end Mark_Excluded_Sources;
8109
8110 ------------------------
8111 -- Check_Object_Files --
8112 ------------------------
8113
8114 procedure Check_Object_Files is
8115 Iter : Source_Iterator;
8116 Src_Id : Source_Id;
8117 Src_Ind : Source_File_Index;
8118
8119 begin
8120 Iter := For_Each_Source (Data.Tree);
8121 loop
8122 Src_Id := Prj.Element (Iter);
8123 exit when Src_Id = No_Source;
8124
8125 if Is_Compilable (Src_Id)
8126 and then Src_Id.Language.Config.Object_Generated
8127 and then Is_Extending (Project.Project, Src_Id.Project)
8128 then
8129 if Src_Id.Unit = No_Unit_Index then
8130 if Src_Id.Kind = Impl then
8131 Check_Object (Src_Id);
8132 end if;
8133
8134 else
8135 case Src_Id.Kind is
8136 when Spec =>
8137 if Other_Part (Src_Id) = No_Source then
8138 Check_Object (Src_Id);
8139 end if;
8140
8141 when Sep =>
8142 null;
8143
8144 when Impl =>
8145 if Other_Part (Src_Id) /= No_Source then
8146 Check_Object (Src_Id);
8147
8148 else
8149 -- Check if it is a subunit
8150
8151 Src_Ind :=
8152 Sinput.P.Load_Project_File
8153 (Get_Name_String (Src_Id.Path.Display_Name));
8154
8155 if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
8156 Override_Kind (Src_Id, Sep);
8157 else
8158 Check_Object (Src_Id);
8159 end if;
8160 end if;
8161 end case;
8162 end if;
8163 end if;
8164
8165 Next (Iter);
8166 end loop;
8167 end Check_Object_Files;
8168
8169 ----------------------------------
8170 -- Get_Sources_From_Source_Info --
8171 ----------------------------------
8172
8173 procedure Get_Sources_From_Source_Info is
8174 Iter : Source_Info_Iterator;
8175 Src : Source_Info;
8176 Id : Source_Id;
8177 Lang_Id : Language_Ptr;
8178
8179 begin
8180 Initialize (Iter, Project.Project.Name);
8181
8182 loop
8183 Src := Source_Info_Of (Iter);
8184
8185 exit when Src = No_Source_Info;
8186
8187 Id := new Source_Data;
8188
8189 Id.Project := Project.Project;
8190
8191 Lang_Id := Project.Project.Languages;
8192 while Lang_Id /= No_Language_Index
8193 and then Lang_Id.Name /= Src.Language
8194 loop
8195 Lang_Id := Lang_Id.Next;
8196 end loop;
8197
8198 if Lang_Id = No_Language_Index then
8199 Prj.Com.Fail
8200 ("unknown language " &
8201 Get_Name_String (Src.Language) &
8202 " for project " &
8203 Get_Name_String (Src.Project) &
8204 " in source info file");
8205 end if;
8206
8207 Id.Language := Lang_Id;
8208 Id.Kind := Src.Kind;
8209 Id.Index := Src.Index;
8210
8211 Id.Path :=
8212 (Path_Name_Type (Src.Display_Path_Name),
8213 Path_Name_Type (Src.Path_Name));
8214
8215 Name_Len := 0;
8216 Add_Str_To_Name_Buffer
8217 (Directories.Simple_Name (Get_Name_String (Src.Path_Name)));
8218 Id.File := Name_Find;
8219
8220 Id.Next_With_File_Name :=
8221 Source_Files_Htable.Get (Data.Tree.Source_Files_HT, Id.File);
8222 Source_Files_Htable.Set (Data.Tree.Source_Files_HT, Id.File, Id);
8223
8224 Name_Len := 0;
8225 Add_Str_To_Name_Buffer
8226 (Directories.Simple_Name
8227 (Get_Name_String (Src.Display_Path_Name)));
8228 Id.Display_File := Name_Find;
8229
8230 Id.Dep_Name :=
8231 Dependency_Name (Id.File, Id.Language.Config.Dependency_Kind);
8232 Id.Naming_Exception := Src.Naming_Exception;
8233 Id.Object :=
8234 Object_Name (Id.File, Id.Language.Config.Object_File_Suffix);
8235 Id.Switches := Switches_Name (Id.File);
8236
8237 -- Add the source id to the Unit_Sources_HT hash table, if the
8238 -- unit name is not null.
8239
8240 if Src.Kind /= Sep and then Src.Unit_Name /= No_Name then
8241 declare
8242 UData : Unit_Index :=
8243 Units_Htable.Get (Data.Tree.Units_HT, Src.Unit_Name);
8244 begin
8245 if UData = No_Unit_Index then
8246 UData := new Unit_Data;
8247 UData.Name := Src.Unit_Name;
8248 Units_Htable.Set
8249 (Data.Tree.Units_HT, Src.Unit_Name, UData);
8250 end if;
8251
8252 Id.Unit := UData;
8253 end;
8254
8255 -- Note that this updates Unit information as well
8256
8257 Override_Kind (Id, Id.Kind);
8258 end if;
8259
8260 if Src.Index /= 0 then
8261 Project.Project.Has_Multi_Unit_Sources := True;
8262 end if;
8263
8264 -- Add the source to the language list
8265
8266 Id.Next_In_Lang := Id.Language.First_Source;
8267 Id.Language.First_Source := Id;
8268
8269 Next (Iter);
8270 end loop;
8271 end Get_Sources_From_Source_Info;
8272
8273 -- Start of processing for Look_For_Sources
8274
8275 begin
8276 if Data.Tree.Source_Info_File_Exists then
8277 Get_Sources_From_Source_Info;
8278
8279 else
8280 if Project.Project.Source_Dirs /= Nil_String then
8281 Find_Excluded_Sources (Project, Data);
8282
8283 if Project.Project.Languages /= No_Language_Index then
8284 Load_Naming_Exceptions (Project, Data);
8285 Find_Sources (Project, Data);
8286 Mark_Excluded_Sources;
8287 Check_Object_Files;
8288 Check_Missing_Sources;
8289 end if;
8290 end if;
8291
8292 Object_File_Names_Htable.Reset (Object_Files);
8293 end if;
8294 end Look_For_Sources;
8295
8296 ------------------
8297 -- Path_Name_Of --
8298 ------------------
8299
8300 function Path_Name_Of
8301 (File_Name : File_Name_Type;
8302 Directory : Path_Name_Type) return String
8303 is
8304 Result : String_Access;
8305 The_Directory : constant String := Get_Name_String (Directory);
8306
8307 begin
8308 Debug_Output ("Path_Name_Of file name=", Name_Id (File_Name));
8309 Debug_Output ("Path_Name_Of directory=", Name_Id (Directory));
8310 Get_Name_String (File_Name);
8311 Result :=
8312 Locate_Regular_File
8313 (File_Name => Name_Buffer (1 .. Name_Len),
8314 Path => The_Directory);
8315
8316 if Result = null then
8317 return "";
8318 else
8319 declare
8320 R : constant String := Result.all;
8321 begin
8322 Free (Result);
8323 return R;
8324 end;
8325 end if;
8326 end Path_Name_Of;
8327
8328 -------------------
8329 -- Remove_Source --
8330 -------------------
8331
8332 procedure Remove_Source
8333 (Tree : Project_Tree_Ref;
8334 Id : Source_Id;
8335 Replaced_By : Source_Id)
8336 is
8337 Source : Source_Id;
8338
8339 begin
8340 if Current_Verbosity = High then
8341 Debug_Indent;
8342 Write_Str ("removing source ");
8343 Write_Str (Get_Name_String (Id.File));
8344
8345 if Id.Index /= 0 then
8346 Write_Str (" at" & Id.Index'Img);
8347 end if;
8348
8349 Write_Eol;
8350 end if;
8351
8352 if Replaced_By /= No_Source then
8353 Id.Replaced_By := Replaced_By;
8354 Replaced_By.Declared_In_Interfaces := Id.Declared_In_Interfaces;
8355
8356 if Id.File /= Replaced_By.File then
8357 declare
8358 Replacement : constant File_Name_Type :=
8359 Replaced_Source_HTable.Get
8360 (Tree.Replaced_Sources, Id.File);
8361
8362 begin
8363 Replaced_Source_HTable.Set
8364 (Tree.Replaced_Sources, Id.File, Replaced_By.File);
8365
8366 if Replacement = No_File then
8367 Tree.Replaced_Source_Number :=
8368 Tree.Replaced_Source_Number + 1;
8369 end if;
8370 end;
8371 end if;
8372 end if;
8373
8374 Id.In_Interfaces := False;
8375 Id.Locally_Removed := True;
8376
8377 -- ??? Should we remove the source from the unit ? The file is not used,
8378 -- so probably should not be referenced from the unit. On the other hand
8379 -- it might give useful additional info
8380 -- if Id.Unit /= null then
8381 -- Id.Unit.File_Names (Id.Kind) := null;
8382 -- end if;
8383
8384 Source := Id.Language.First_Source;
8385
8386 if Source = Id then
8387 Id.Language.First_Source := Id.Next_In_Lang;
8388
8389 else
8390 while Source.Next_In_Lang /= Id loop
8391 Source := Source.Next_In_Lang;
8392 end loop;
8393
8394 Source.Next_In_Lang := Id.Next_In_Lang;
8395 end if;
8396 end Remove_Source;
8397
8398 -----------------------
8399 -- Report_No_Sources --
8400 -----------------------
8401
8402 procedure Report_No_Sources
8403 (Project : Project_Id;
8404 Lang_Name : String;
8405 Data : Tree_Processing_Data;
8406 Location : Source_Ptr;
8407 Continuation : Boolean := False)
8408 is
8409 begin
8410 case Data.Flags.When_No_Sources is
8411 when Silent =>
8412 null;
8413
8414 when Warning | Error =>
8415 declare
8416 Msg : constant String :=
8417 "<there are no "
8418 & Lang_Name & " sources in this project";
8419
8420 begin
8421 Error_Msg_Warn := Data.Flags.When_No_Sources = Warning;
8422
8423 if Continuation then
8424 Error_Msg (Data.Flags, "\" & Msg, Location, Project);
8425 else
8426 Error_Msg (Data.Flags, Msg, Location, Project);
8427 end if;
8428 end;
8429 end case;
8430 end Report_No_Sources;
8431
8432 ----------------------
8433 -- Show_Source_Dirs --
8434 ----------------------
8435
8436 procedure Show_Source_Dirs
8437 (Project : Project_Id;
8438 Shared : Shared_Project_Tree_Data_Access)
8439 is
8440 Current : String_List_Id;
8441 Element : String_Element;
8442
8443 begin
8444 if Project.Source_Dirs = Nil_String then
8445 Debug_Output ("no Source_Dirs");
8446 else
8447 Debug_Increase_Indent ("Source_Dirs:");
8448
8449 Current := Project.Source_Dirs;
8450 while Current /= Nil_String loop
8451 Element := Shared.String_Elements.Table (Current);
8452 Debug_Output (Get_Name_String (Element.Display_Value));
8453 Current := Element.Next;
8454 end loop;
8455
8456 Debug_Decrease_Indent ("end Source_Dirs.");
8457 end if;
8458 end Show_Source_Dirs;
8459
8460 ---------------------------
8461 -- Process_Naming_Scheme --
8462 ---------------------------
8463
8464 procedure Process_Naming_Scheme
8465 (Tree : Project_Tree_Ref;
8466 Root_Project : Project_Id;
8467 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
8468 Flags : Processing_Flags)
8469 is
8470
8471 procedure Check
8472 (Project : Project_Id;
8473 In_Aggregate_Lib : Boolean;
8474 Data : in out Tree_Processing_Data);
8475 -- Process the naming scheme for a single project
8476
8477 procedure Recursive_Check
8478 (Project : Project_Id;
8479 Prj_Tree : Project_Tree_Ref;
8480 Context : Project_Context;
8481 Data : in out Tree_Processing_Data);
8482 -- Check_Naming_Scheme for the project
8483
8484 -----------
8485 -- Check --
8486 -----------
8487
8488 procedure Check
8489 (Project : Project_Id;
8490 In_Aggregate_Lib : Boolean;
8491 Data : in out Tree_Processing_Data)
8492 is
8493 procedure Check_Aggregated;
8494 -- Check aggregated projects which should not be externally built
8495
8496 ----------------------
8497 -- Check_Aggregated --
8498 ----------------------
8499
8500 procedure Check_Aggregated is
8501 L : Aggregated_Project_List;
8502
8503 begin
8504 -- Check that aggregated projects are not externally built
8505
8506 L := Project.Aggregated_Projects;
8507 while L /= null loop
8508 declare
8509 Var : constant Prj.Variable_Value :=
8510 Prj.Util.Value_Of
8511 (Snames.Name_Externally_Built,
8512 L.Project.Decl.Attributes,
8513 Data.Tree.Shared);
8514 begin
8515 if not Var.Default then
8516 Error_Msg_Name_1 := L.Project.Display_Name;
8517 Error_Msg
8518 (Data.Flags,
8519 "cannot aggregate externally built project %%",
8520 Var.Location, Project);
8521 end if;
8522 end;
8523
8524 L := L.Next;
8525 end loop;
8526 end Check_Aggregated;
8527
8528 -- Local Variables
8529
8530 Shared : constant Shared_Project_Tree_Data_Access :=
8531 Data.Tree.Shared;
8532 Prj_Data : Project_Processing_Data;
8533
8534 -- Start of processing for Check
8535
8536 begin
8537 Debug_Increase_Indent ("check", Project.Name);
8538
8539 Initialize (Prj_Data, Project);
8540
8541 Check_If_Externally_Built (Project, Data);
8542
8543 case Project.Qualifier is
8544 when Aggregate =>
8545 Check_Aggregated;
8546
8547 when Aggregate_Library =>
8548 Check_Aggregated;
8549
8550 if Project.Object_Directory = No_Path_Information then
8551 Project.Object_Directory := Project.Directory;
8552 end if;
8553
8554 when others =>
8555 Get_Directories (Project, Data);
8556 Check_Programming_Languages (Project, Data);
8557
8558 if Current_Verbosity = High then
8559 Show_Source_Dirs (Project, Shared);
8560 end if;
8561
8562 if Project.Qualifier = Abstract_Project then
8563 Check_Abstract_Project (Project, Data);
8564 end if;
8565 end case;
8566
8567 -- Check configuration. Must be done for gnatmake (even though no
8568 -- user configuration file was provided) since the default config we
8569 -- generate indicates whether libraries are supported for instance.
8570
8571 Check_Configuration (Project, Data);
8572
8573 if Project.Qualifier /= Aggregate then
8574 Check_Library_Attributes (Project, Data);
8575 Check_Package_Naming (Project, Data);
8576
8577 -- An aggregate library has no source, no need to look for them
8578
8579 if Project.Qualifier /= Aggregate_Library then
8580 Look_For_Sources (Prj_Data, Data);
8581 end if;
8582
8583 Check_Interfaces (Project, Data);
8584
8585 -- If this library is part of an aggregated library don't check it
8586 -- as it has no sources by itself and so interface won't be found.
8587
8588 if Project.Library and not In_Aggregate_Lib then
8589 Check_Stand_Alone_Library (Project, Data);
8590 end if;
8591
8592 Get_Mains (Project, Data);
8593 end if;
8594
8595 Free (Prj_Data);
8596
8597 Debug_Decrease_Indent ("done check");
8598 end Check;
8599
8600 ---------------------
8601 -- Recursive_Check --
8602 ---------------------
8603
8604 procedure Recursive_Check
8605 (Project : Project_Id;
8606 Prj_Tree : Project_Tree_Ref;
8607 Context : Project_Context;
8608 Data : in out Tree_Processing_Data)
8609 is
8610 begin
8611 if Current_Verbosity = High then
8612 Debug_Increase_Indent
8613 ("Processing_Naming_Scheme for project", Project.Name);
8614 end if;
8615
8616 Data.Tree := Prj_Tree;
8617 Data.In_Aggregate_Lib := Context.In_Aggregate_Lib;
8618
8619 Check (Project, Context.In_Aggregate_Lib, Data);
8620
8621 if Current_Verbosity = High then
8622 Debug_Decrease_Indent ("done Processing_Naming_Scheme");
8623 end if;
8624 end Recursive_Check;
8625
8626 procedure Check_All_Projects is new For_Every_Project_Imported_Context
8627 (Tree_Processing_Data, Recursive_Check);
8628 -- Comment required???
8629
8630 -- Local Variables
8631
8632 Data : Tree_Processing_Data;
8633
8634 -- Start of processing for Process_Naming_Scheme
8635
8636 begin
8637 Lib_Data_Table.Init;
8638 Initialize (Data, Tree => Tree, Node_Tree => Node_Tree, Flags => Flags);
8639 Check_All_Projects (Root_Project, Tree, Data, Imported_First => True);
8640 Free (Data);
8641
8642 -- Adjust language configs for projects that are extended
8643
8644 declare
8645 List : Project_List;
8646 Proj : Project_Id;
8647 Exte : Project_Id;
8648 Lang : Language_Ptr;
8649 Elng : Language_Ptr;
8650
8651 begin
8652 List := Tree.Projects;
8653 while List /= null loop
8654 Proj := List.Project;
8655
8656 Exte := Proj;
8657 while Exte.Extended_By /= No_Project loop
8658 Exte := Exte.Extended_By;
8659 end loop;
8660
8661 if Exte /= Proj then
8662 Lang := Proj.Languages;
8663
8664 if Lang /= No_Language_Index then
8665 loop
8666 Elng := Get_Language_From_Name
8667 (Exte, Get_Name_String (Lang.Name));
8668 exit when Elng /= No_Language_Index;
8669 Exte := Exte.Extends;
8670 end loop;
8671
8672 if Elng /= Lang then
8673 Lang.Config := Elng.Config;
8674 end if;
8675 end if;
8676 end if;
8677
8678 List := List.Next;
8679 end loop;
8680 end;
8681 end Process_Naming_Scheme;
8682
8683 end Prj.Nmsc;