2011-02-08 Janus Weil <janus@gcc.gnu.org>
[official-gcc.git] / gcc / ada / prj-nmsc.adb
blob5175d01ab50ed3b3104208e0650c347ad529f4a9
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-2010, 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 ------------------------------------------------------------------------------
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.Err; use Prj.Err;
32 with Prj.Util; use Prj.Util;
33 with Sinput.P;
34 with Snames; use Snames;
35 with Targparm; use Targparm;
37 with Ada.Characters.Handling; use Ada.Characters.Handling;
38 with Ada.Directories; use Ada.Directories;
39 with Ada.Strings; use Ada.Strings;
40 with Ada.Strings.Fixed; use Ada.Strings.Fixed;
41 with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
43 with GNAT.Case_Util; use GNAT.Case_Util;
44 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
45 with GNAT.Dynamic_HTables;
46 with GNAT.Regexp; use GNAT.Regexp;
47 with GNAT.Table;
49 package body Prj.Nmsc is
51 No_Continuation_String : aliased String := "";
52 Continuation_String : aliased String := "\";
53 -- Used in Check_Library for continuation error messages at the same
54 -- location.
56 type Name_Location is record
57 Name : File_Name_Type;
58 -- Key is duplicated, so that it is known when using functions Get_First
59 -- and Get_Next, as these functions only return an Element.
61 Location : Source_Ptr;
62 Source : Source_Id := No_Source;
63 Listed : Boolean := False;
64 Found : Boolean := False;
65 end record;
67 No_Name_Location : constant Name_Location :=
68 (Name => No_File,
69 Location => No_Location,
70 Source => No_Source,
71 Listed => False,
72 Found => False);
74 package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
75 (Header_Num => Header_Num,
76 Element => Name_Location,
77 No_Element => No_Name_Location,
78 Key => File_Name_Type,
79 Hash => Hash,
80 Equal => "=");
81 -- File name information found in string list attribute (Source_Files or
82 -- Source_List_File). Except is set to True if source is a naming exception
83 -- in the project. Used to check that all referenced files were indeed
84 -- found on the disk.
86 type Unit_Exception is record
87 Name : Name_Id;
88 -- Key is duplicated, so that it is known when using functions Get_First
89 -- and Get_Next, as these functions only return an Element.
91 Spec : File_Name_Type;
92 Impl : File_Name_Type;
93 end record;
95 No_Unit_Exception : constant Unit_Exception := (No_Name, No_File, No_File);
97 package Unit_Exceptions_Htable is new GNAT.Dynamic_HTables.Simple_HTable
98 (Header_Num => Header_Num,
99 Element => Unit_Exception,
100 No_Element => No_Unit_Exception,
101 Key => Name_Id,
102 Hash => Hash,
103 Equal => "=");
104 -- Record special naming schemes for Ada units (name of spec file and name
105 -- of implementation file). The elements in this list come from the naming
106 -- exceptions specified in the project files.
108 type File_Found is record
109 File : File_Name_Type := No_File;
110 Found : Boolean := False;
111 Location : Source_Ptr := No_Location;
112 end record;
114 No_File_Found : constant File_Found := (No_File, False, No_Location);
116 package Excluded_Sources_Htable is new GNAT.Dynamic_HTables.Simple_HTable
117 (Header_Num => Header_Num,
118 Element => File_Found,
119 No_Element => No_File_Found,
120 Key => File_Name_Type,
121 Hash => Hash,
122 Equal => "=");
123 -- A hash table to store the base names of excluded files, if any
125 package Object_File_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
126 (Header_Num => Header_Num,
127 Element => Source_Id,
128 No_Element => No_Source,
129 Key => File_Name_Type,
130 Hash => Hash,
131 Equal => "=");
132 -- A hash table to store the object file names for a project, to check that
133 -- two different sources have different object file names.
135 type Project_Processing_Data is record
136 Project : Project_Id;
137 Source_Names : Source_Names_Htable.Instance;
138 Unit_Exceptions : Unit_Exceptions_Htable.Instance;
139 Excluded : Excluded_Sources_Htable.Instance;
141 Source_List_File_Location : Source_Ptr;
142 -- Location of the Source_List_File attribute, for error messages
143 end record;
144 -- This is similar to Tree_Processing_Data, but contains project-specific
145 -- information which is only useful while processing the project, and can
146 -- be discarded as soon as we have finished processing the project
148 package Files_Htable is new GNAT.Dynamic_HTables.Simple_HTable
149 (Header_Num => Header_Num,
150 Element => Source_Id,
151 No_Element => No_Source,
152 Key => File_Name_Type,
153 Hash => Hash,
154 Equal => "=");
155 -- Mapping from base file names to Source_Id (containing full info about
156 -- the source).
158 type Tree_Processing_Data is record
159 Tree : Project_Tree_Ref;
160 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
161 File_To_Source : Files_Htable.Instance;
162 Flags : Prj.Processing_Flags;
163 end record;
164 -- Temporary data which is needed while parsing a project. It does not need
165 -- to be kept in memory once a project has been fully loaded, but is
166 -- necessary while performing consistency checks (duplicate sources,...)
167 -- This data must be initialized before processing any project, and the
168 -- same data is used for processing all projects in the tree.
170 type Lib_Data is record
171 Name : Name_Id;
172 Proj : Project_Id;
173 end record;
175 package Lib_Data_Table is new GNAT.Table
176 (Table_Component_Type => Lib_Data,
177 Table_Index_Type => Natural,
178 Table_Low_Bound => 1,
179 Table_Initial => 10,
180 Table_Increment => 100);
181 -- A table to record library names in order to check that two library
182 -- projects do not have the same library names.
184 procedure Initialize
185 (Data : out Tree_Processing_Data;
186 Tree : Project_Tree_Ref;
187 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
188 Flags : Prj.Processing_Flags);
189 -- Initialize Data
191 procedure Free (Data : in out Tree_Processing_Data);
192 -- Free the memory occupied by Data
194 procedure Check
195 (Project : Project_Id;
196 Data : in out Tree_Processing_Data);
197 -- Process the naming scheme for a single project
199 procedure Initialize
200 (Data : in out Project_Processing_Data;
201 Project : Project_Id);
202 procedure Free (Data : in out Project_Processing_Data);
203 -- Initialize or free memory for a project-specific data
205 procedure Find_Excluded_Sources
206 (Project : in out Project_Processing_Data;
207 Data : in out Tree_Processing_Data);
208 -- Find the list of files that should not be considered as source files
209 -- for this project. Sets the list in the Project.Excluded_Sources_Htable.
211 procedure Override_Kind (Source : Source_Id; Kind : Source_Kind);
212 -- Override the reference kind for a source file. This properly updates
213 -- the unit data if necessary.
215 procedure Load_Naming_Exceptions
216 (Project : in out Project_Processing_Data;
217 Data : in out Tree_Processing_Data);
218 -- All source files in Data.First_Source are considered as naming
219 -- exceptions, and copied into the Source_Names and Unit_Exceptions tables
220 -- as appropriate.
222 type Search_Type is (Search_Files, Search_Directories);
224 generic
225 with procedure Callback
226 (Path : Path_Information;
227 Pattern_Index : Natural);
228 procedure Expand_Subdirectory_Pattern
229 (Project : Project_Id;
230 Data : in out Tree_Processing_Data;
231 Patterns : String_List_Id;
232 Ignore : String_List_Id;
233 Search_For : Search_Type;
234 Resolve_Links : Boolean);
235 -- Search the subdirectories of Project's directory for files or
236 -- directories that match the globbing patterns found in Patterns (for
237 -- instance "**/*.adb"). Typically, Patterns will be the value of the
238 -- Source_Dirs or Excluded_Source_Dirs attributes.
239 -- Every time such a file or directory is found, the callback is called.
240 -- Resolve_Links indicates whether we should resolve links while
241 -- normalizing names.
242 -- In the callback, Pattern_Index is the index within Patterns where the
243 -- expanded pattern was found (1 for the first element of Patterns and
244 -- all its matching directories, then 2,...).
245 -- We use a generic and not an access-to-subprogram because in some cases
246 -- this code is compiled with the restriction No_Implicit_Dynamic_Code
248 procedure Add_Source
249 (Id : out Source_Id;
250 Data : in out Tree_Processing_Data;
251 Project : Project_Id;
252 Source_Dir_Rank : Natural;
253 Lang_Id : Language_Ptr;
254 Kind : Source_Kind;
255 File_Name : File_Name_Type;
256 Display_File : File_Name_Type;
257 Naming_Exception : Boolean := False;
258 Path : Path_Information := No_Path_Information;
259 Alternate_Languages : Language_List := null;
260 Unit : Name_Id := No_Name;
261 Index : Int := 0;
262 Locally_Removed : Boolean := False;
263 Location : Source_Ptr := No_Location);
264 -- Add a new source to the different lists: list of all sources in the
265 -- project tree, list of source of a project and list of sources of a
266 -- language.
268 -- If Path is specified, the file is also added to Source_Paths_HT.
270 -- Location is used for error messages
272 function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type;
273 -- Same as Osint.Canonical_Case_File_Name but applies to Name_Id.
274 -- This alters Name_Buffer
276 function Suffix_Matches
277 (Filename : String;
278 Suffix : File_Name_Type) return Boolean;
279 -- True if the file name ends with the given suffix. Always returns False
280 -- if Suffix is No_Name.
282 procedure Replace_Into_Name_Buffer
283 (Str : String;
284 Pattern : String;
285 Replacement : Character);
286 -- Copy Str into Name_Buffer, replacing Pattern with Replacement. Str is
287 -- converted to lower-case at the same time.
289 procedure Check_Ada_Name (Name : String; Unit : out Name_Id);
290 -- Check that a name is a valid Ada unit name
292 procedure Check_Package_Naming
293 (Project : Project_Id;
294 Data : in out Tree_Processing_Data);
295 -- Check the naming scheme part of Data, and initialize the naming scheme
296 -- data in the config of the various languages.
298 procedure Check_Configuration
299 (Project : Project_Id;
300 Data : in out Tree_Processing_Data);
301 -- Check the configuration attributes for the project
303 procedure Check_If_Externally_Built
304 (Project : Project_Id;
305 Data : in out Tree_Processing_Data);
306 -- Check attribute Externally_Built of project Project in project tree
307 -- Data.Tree and modify its data Data if it has the value "true".
309 procedure Check_Interfaces
310 (Project : Project_Id;
311 Data : in out Tree_Processing_Data);
312 -- If a list of sources is specified in attribute Interfaces, set
313 -- In_Interfaces only for the sources specified in the list.
315 procedure Check_Library_Attributes
316 (Project : Project_Id;
317 Data : in out Tree_Processing_Data);
318 -- Check the library attributes of project Project in project tree
319 -- and modify its data Data accordingly.
321 procedure Check_Aggregate_Project
322 (Project : Project_Id;
323 Data : in out Tree_Processing_Data);
324 -- Check aggregate projects attributes, and find the list of aggregated
325 -- projects. They are stored as a "project_files" language in Project.
327 procedure Check_Abstract_Project
328 (Project : Project_Id;
329 Data : in out Tree_Processing_Data);
330 -- Check abstract projects attributes
332 procedure Check_Programming_Languages
333 (Project : Project_Id;
334 Data : in out Tree_Processing_Data);
335 -- Check attribute Languages for the project with data Data in project
336 -- tree Data.Tree and set the components of Data for all the programming
337 -- languages indicated in attribute Languages, if any.
339 procedure Check_Stand_Alone_Library
340 (Project : Project_Id;
341 Data : in out Tree_Processing_Data);
342 -- Check if project Project in project tree Data.Tree is a Stand-Alone
343 -- Library project, and modify its data Data accordingly if it is one.
345 function Compute_Directory_Last (Dir : String) return Natural;
346 -- Return the index of the last significant character in Dir. This is used
347 -- to avoid duplicate '/' (slash) characters at the end of directory names.
349 procedure Search_Directories
350 (Project : in out Project_Processing_Data;
351 Data : in out Tree_Processing_Data;
352 For_All_Sources : Boolean);
353 -- Search the source directories to find the sources. If For_All_Sources is
354 -- True, check each regular file name against the naming schemes of the
355 -- various languages. Otherwise consider only the file names in hash table
356 -- Source_Names. If Allow_Duplicate_Basenames then files with identical
357 -- base names are permitted within a project for source-based languages
358 -- (never for unit based languages).
360 procedure Check_File
361 (Project : in out Project_Processing_Data;
362 Data : in out Tree_Processing_Data;
363 Source_Dir_Rank : Natural;
364 Path : Path_Name_Type;
365 Display_Path : Path_Name_Type;
366 File_Name : File_Name_Type;
367 Display_File_Name : File_Name_Type;
368 Locally_Removed : Boolean;
369 For_All_Sources : Boolean);
370 -- Check if file File_Name is a valid source of the project. This is used
371 -- in multi-language mode only. When the file matches one of the naming
372 -- schemes, it is added to various htables through Add_Source and to
373 -- Source_Paths_Htable.
375 -- File_Name is the same as Display_File_Name, but has been normalized.
376 -- They do not include the directory information.
378 -- Path and Display_Path on the other hand are the full path to the file.
379 -- Path must have been normalized (canonical casing and possibly links
380 -- resolved).
382 -- Source_Directory is the directory in which the file was found. It is
383 -- neither normalized nor has had links resolved, and must not end with a
384 -- a directory separator, to avoid duplicates later on.
386 -- If For_All_Sources is True, then all possible file names are analyzed
387 -- otherwise only those currently set in the Source_Names hash table.
389 procedure Check_File_Naming_Schemes
390 (In_Tree : Project_Tree_Ref;
391 Project : Project_Processing_Data;
392 File_Name : File_Name_Type;
393 Alternate_Languages : out Language_List;
394 Language : out Language_Ptr;
395 Display_Language_Name : out Name_Id;
396 Unit : out Name_Id;
397 Lang_Kind : out Language_Kind;
398 Kind : out Source_Kind);
399 -- Check if the file name File_Name conforms to one of the naming schemes
400 -- of the project. If the file does not match one of the naming schemes,
401 -- set Language to No_Language_Index. Filename is the name of the file
402 -- being investigated. It has been normalized (case-folded). File_Name is
403 -- the same value.
405 procedure Get_Directories
406 (Project : Project_Id;
407 Data : in out Tree_Processing_Data);
408 -- Get the object directory, the exec directory and the source directories
409 -- of a project.
411 procedure Get_Mains
412 (Project : Project_Id;
413 Data : in out Tree_Processing_Data);
414 -- Get the mains of a project from attribute Main, if it exists, and put
415 -- them in the project data.
417 procedure Get_Sources_From_File
418 (Path : String;
419 Location : Source_Ptr;
420 Project : in out Project_Processing_Data;
421 Data : in out Tree_Processing_Data);
422 -- Get the list of sources from a text file and put them in hash table
423 -- Source_Names.
425 procedure Find_Sources
426 (Project : in out Project_Processing_Data;
427 Data : in out Tree_Processing_Data);
428 -- Process the Source_Files and Source_List_File attributes, and store the
429 -- list of source files into the Source_Names htable. When these attributes
430 -- are not defined, find all files matching the naming schemes in the
431 -- source directories. If Allow_Duplicate_Basenames, then files with the
432 -- same base names are authorized within a project for source-based
433 -- languages (never for unit based languages)
435 procedure Compute_Unit_Name
436 (File_Name : File_Name_Type;
437 Naming : Lang_Naming_Data;
438 Kind : out Source_Kind;
439 Unit : out Name_Id;
440 Project : Project_Processing_Data;
441 In_Tree : Project_Tree_Ref);
442 -- Check whether the file matches the naming scheme. If it does,
443 -- compute its unit name. If Unit is set to No_Name on exit, none of the
444 -- other out parameters are relevant.
446 procedure Check_Illegal_Suffix
447 (Project : Project_Id;
448 Suffix : File_Name_Type;
449 Dot_Replacement : File_Name_Type;
450 Attribute_Name : String;
451 Location : Source_Ptr;
452 Data : in out Tree_Processing_Data);
453 -- Display an error message if the given suffix is illegal for some reason.
454 -- The name of the attribute we are testing is specified in Attribute_Name,
455 -- which is used in the error message. Location is the location where the
456 -- suffix is defined.
458 procedure Locate_Directory
459 (Project : Project_Id;
460 Name : File_Name_Type;
461 Path : out Path_Information;
462 Dir_Exists : out Boolean;
463 Data : in out Tree_Processing_Data;
464 Create : String := "";
465 Location : Source_Ptr := No_Location;
466 Must_Exist : Boolean := True;
467 Externally_Built : Boolean := False);
468 -- Locate a directory. Name is the directory name. Relative paths are
469 -- resolved relative to the project's directory. If the directory does not
470 -- exist and Setup_Projects is True and Create is a non null string, an
471 -- attempt is made to create the directory. If the directory does not
472 -- exist, it is either created if Setup_Projects is False (and then
473 -- returned), or simply returned without checking for its existence (if
474 -- Must_Exist is False) or No_Path_Information is returned. In all cases,
475 -- Dir_Exists indicates whether the directory now exists. Create is also
476 -- used for debugging traces to show which path we are computing.
478 procedure Look_For_Sources
479 (Project : in out Project_Processing_Data;
480 Data : in out Tree_Processing_Data);
481 -- Find all the sources of project Project in project tree Data.Tree and
482 -- update its Data accordingly. This assumes that the special naming
483 -- exceptions have already been processed.
485 function Path_Name_Of
486 (File_Name : File_Name_Type;
487 Directory : Path_Name_Type) return String;
488 -- Returns the path name of a (non project) file. Returns an empty string
489 -- if file cannot be found.
491 procedure Remove_Source
492 (Tree : Project_Tree_Ref;
493 Id : Source_Id;
494 Replaced_By : Source_Id);
495 -- Remove a file from the list of sources of a project. This might be
496 -- because the file is replaced by another one in an extending project,
497 -- or because a file was added as a naming exception but was not found
498 -- in the end.
500 procedure Report_No_Sources
501 (Project : Project_Id;
502 Lang_Name : String;
503 Data : Tree_Processing_Data;
504 Location : Source_Ptr;
505 Continuation : Boolean := False);
506 -- Report an error or a warning depending on the value of When_No_Sources
507 -- when there are no sources for language Lang_Name.
509 procedure Show_Source_Dirs
510 (Project : Project_Id; In_Tree : Project_Tree_Ref);
511 -- List all the source directories of a project
513 procedure Write_Attr (Name, Value : String);
514 -- Debug print a value for a specific property. Does nothing when not in
515 -- debug mode
517 procedure Error_Or_Warning
518 (Flags : Processing_Flags;
519 Kind : Error_Warning;
520 Msg : String;
521 Location : Source_Ptr;
522 Project : Project_Id);
523 -- Emits either an error or warning message (or nothing), depending on Kind
525 ----------------------
526 -- Error_Or_Warning --
527 ----------------------
529 procedure Error_Or_Warning
530 (Flags : Processing_Flags;
531 Kind : Error_Warning;
532 Msg : String;
533 Location : Source_Ptr;
534 Project : Project_Id) is
535 begin
536 case Kind is
537 when Error => Error_Msg (Flags, Msg, Location, Project);
538 when Warning => Error_Msg (Flags, "?" & Msg, Location, Project);
539 when Silent => null;
540 end case;
541 end Error_Or_Warning;
543 ------------------------------
544 -- Replace_Into_Name_Buffer --
545 ------------------------------
547 procedure Replace_Into_Name_Buffer
548 (Str : String;
549 Pattern : String;
550 Replacement : Character)
552 Max : constant Integer := Str'Last - Pattern'Length + 1;
553 J : Positive;
555 begin
556 Name_Len := 0;
558 J := Str'First;
559 while J <= Str'Last loop
560 Name_Len := Name_Len + 1;
562 if J <= Max
563 and then Str (J .. J + Pattern'Length - 1) = Pattern
564 then
565 Name_Buffer (Name_Len) := Replacement;
566 J := J + Pattern'Length;
568 else
569 Name_Buffer (Name_Len) := GNAT.Case_Util.To_Lower (Str (J));
570 J := J + 1;
571 end if;
572 end loop;
573 end Replace_Into_Name_Buffer;
575 --------------------
576 -- Suffix_Matches --
577 --------------------
579 function Suffix_Matches
580 (Filename : String;
581 Suffix : File_Name_Type) return Boolean
583 Min_Prefix_Length : Natural := 0;
585 begin
586 if Suffix = No_File or else Suffix = Empty_File then
587 return False;
588 end if;
590 declare
591 Suf : String := Get_Name_String (Suffix);
593 begin
594 -- On non case-sensitive systems, use proper suffix casing
596 Canonical_Case_File_Name (Suf);
598 -- The file name must end with the suffix (which is not an extension)
599 -- For instance a suffix "configure.in" must match a file with the
600 -- same name. To avoid dummy cases, though, a suffix starting with
601 -- '.' requires a file that is at least one character longer ('.cpp'
602 -- should not match a file with the same name)
604 if Suf (Suf'First) = '.' then
605 Min_Prefix_Length := 1;
606 end if;
608 return Filename'Length >= Suf'Length + Min_Prefix_Length
609 and then Filename
610 (Filename'Last - Suf'Length + 1 .. Filename'Last) = Suf;
611 end;
612 end Suffix_Matches;
614 ----------------
615 -- Write_Attr --
616 ----------------
618 procedure Write_Attr (Name, Value : String) is
619 begin
620 if Current_Verbosity = High then
621 Write_Str (" " & Name & " = """);
622 Write_Str (Value);
623 Write_Char ('"');
624 Write_Eol;
625 end if;
626 end Write_Attr;
628 ----------------
629 -- Add_Source --
630 ----------------
632 procedure Add_Source
633 (Id : out Source_Id;
634 Data : in out Tree_Processing_Data;
635 Project : Project_Id;
636 Source_Dir_Rank : Natural;
637 Lang_Id : Language_Ptr;
638 Kind : Source_Kind;
639 File_Name : File_Name_Type;
640 Display_File : File_Name_Type;
641 Naming_Exception : Boolean := False;
642 Path : Path_Information := No_Path_Information;
643 Alternate_Languages : Language_List := null;
644 Unit : Name_Id := No_Name;
645 Index : Int := 0;
646 Locally_Removed : Boolean := False;
647 Location : Source_Ptr := No_Location)
649 Config : constant Language_Config := Lang_Id.Config;
650 UData : Unit_Index;
651 Add_Src : Boolean;
652 Source : Source_Id;
653 Prev_Unit : Unit_Index := No_Unit_Index;
655 Source_To_Replace : Source_Id := No_Source;
657 begin
658 -- Check if the same file name or unit is used in the prj tree
660 Add_Src := True;
662 if Unit /= No_Name then
663 Prev_Unit := Units_Htable.Get (Data.Tree.Units_HT, Unit);
664 end if;
666 if Prev_Unit /= No_Unit_Index
667 and then (Kind = Impl or else Kind = Spec)
668 and then Prev_Unit.File_Names (Kind) /= null
669 then
670 -- Suspicious, we need to check later whether this is authorized
672 Add_Src := False;
673 Source := Prev_Unit.File_Names (Kind);
675 else
676 Source := Files_Htable.Get (Data.File_To_Source, File_Name);
678 if Source /= No_Source
679 and then Source.Index = Index
680 then
681 Add_Src := False;
682 end if;
683 end if;
685 -- Duplication of file/unit in same project is allowed if order of
686 -- source directories is known.
688 if Add_Src = False then
689 Add_Src := True;
691 if Project = Source.Project then
692 if Prev_Unit = No_Unit_Index then
693 if Data.Flags.Allow_Duplicate_Basenames then
694 Add_Src := True;
696 elsif Source_Dir_Rank /= Source.Source_Dir_Rank then
697 Add_Src := False;
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;
707 else
708 if Source_Dir_Rank /= Source.Source_Dir_Rank then
709 Add_Src := False;
711 -- We might be seeing the same file through a different path
712 -- (for instance because of symbolic links).
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, "\duplicate unit %%", Location, Project);
719 Source.Duplicate_Unit := True;
720 end if;
722 Add_Src := False;
723 end if;
724 end if;
726 -- Do not allow the same unit name in different projects, except
727 -- if one is extending the other.
729 -- For a file based language, the same file name replaces a file
730 -- in a project being extended, but it is allowed to have the same
731 -- file name in unrelated projects.
733 elsif Is_Extending (Project, Source.Project) then
734 if not Locally_Removed then
735 Source_To_Replace := Source;
736 end if;
738 elsif Prev_Unit /= No_Unit_Index
739 and then Prev_Unit.File_Names (Kind) /= null
740 and then not Source.Locally_Removed
741 then
742 -- Path is set if this is a source we found on the disk, in which
743 -- case we can provide more explicit error message. Path is unset
744 -- when the source is added from one of the naming exceptions in
745 -- the project.
747 if Path /= No_Path_Information then
748 Error_Msg_Name_1 := Unit;
749 Error_Msg
750 (Data.Flags,
751 "unit %% cannot belong to several projects",
752 Location, Project);
754 Error_Msg_Name_1 := Project.Name;
755 Error_Msg_Name_2 := Name_Id (Path.Display_Name);
756 Error_Msg
757 (Data.Flags, "\ project %%, %%", Location, Project);
759 Error_Msg_Name_1 := Source.Project.Name;
760 Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name);
761 Error_Msg
762 (Data.Flags, "\ project %%, %%", Location, Project);
764 else
765 Error_Msg_Name_1 := Unit;
766 Error_Msg_Name_2 := Source.Project.Name;
767 Error_Msg
768 (Data.Flags, "unit %% already belongs to project %%",
769 Location, Project);
770 end if;
772 Add_Src := False;
774 elsif not Source.Locally_Removed
775 and then not Data.Flags.Allow_Duplicate_Basenames
776 and then Lang_Id.Config.Kind = Unit_Based
777 and then Source.Language.Config.Kind = Unit_Based
778 then
779 Error_Msg_File_1 := File_Name;
780 Error_Msg_File_2 := File_Name_Type (Source.Project.Name);
781 Error_Msg
782 (Data.Flags,
783 "{ is already a source of project {", Location, Project);
785 -- Add the file anyway, to avoid further warnings like "language
786 -- unknown".
788 Add_Src := True;
789 end if;
790 end if;
792 if not Add_Src then
793 return;
794 end if;
796 -- Add the new file
798 Id := new Source_Data;
800 if Current_Verbosity = High then
801 Write_Str ("Adding source File: ");
802 Write_Str (Get_Name_String (Display_File));
804 if Index /= 0 then
805 Write_Str (" at" & Index'Img);
806 end if;
808 if Lang_Id.Config.Kind = Unit_Based then
809 Write_Str (" Unit: ");
811 -- ??? in gprclean, it seems we sometimes pass an empty Unit name
812 -- (see test extended_projects).
814 if Unit /= No_Name then
815 Write_Str (Get_Name_String (Unit));
816 end if;
818 Write_Str (" Kind: ");
819 Write_Str (Source_Kind'Image (Kind));
820 end if;
822 Write_Eol;
823 end if;
825 Id.Project := Project;
826 Id.Location := Location;
827 Id.Source_Dir_Rank := Source_Dir_Rank;
828 Id.Language := Lang_Id;
829 Id.Kind := Kind;
830 Id.Alternate_Languages := Alternate_Languages;
831 Id.Locally_Removed := Locally_Removed;
832 Id.Index := Index;
833 Id.File := File_Name;
834 Id.Display_File := Display_File;
835 Id.Dep_Name := Dependency_Name
836 (File_Name, Lang_Id.Config.Dependency_Kind);
837 Id.Naming_Exception := Naming_Exception;
838 Id.Object := Object_Name
839 (File_Name, Config.Object_File_Suffix);
840 Id.Switches := Switches_Name (File_Name);
842 -- Add the source id to the Unit_Sources_HT hash table, if the unit name
843 -- is not null.
845 if Unit /= No_Name then
847 -- Note: we might be creating a dummy unit here, when we in fact have
848 -- a separate. For instance, file file-bar.adb will initially be
849 -- assumed to be the IMPL of unit "file.bar". Only later on (in
850 -- Check_Object_Files) will we parse those units that only have an
851 -- impl and no spec to make sure whether we have a Separate in fact
852 -- (that significantly reduces the number of times we need to parse
853 -- the files, since we are then only interested in those with no
854 -- spec). We still need those dummy units in the table, since that's
855 -- the name we find in the ALI file
857 UData := Units_Htable.Get (Data.Tree.Units_HT, Unit);
859 if UData = No_Unit_Index then
860 UData := new Unit_Data;
861 UData.Name := Unit;
862 Units_Htable.Set (Data.Tree.Units_HT, Unit, UData);
863 end if;
865 Id.Unit := UData;
867 -- Note that this updates Unit information as well
869 Override_Kind (Id, Kind);
870 end if;
872 if Path /= No_Path_Information then
873 Id.Path := Path;
874 Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path.Name, Id);
875 end if;
877 Id.Next_With_File_Name :=
878 Source_Files_Htable.Get (Data.Tree.Source_Files_HT, File_Name);
879 Source_Files_Htable.Set (Data.Tree.Source_Files_HT, File_Name, Id);
881 if Index /= 0 then
882 Project.Has_Multi_Unit_Sources := True;
883 end if;
885 -- Add the source to the language list
887 Id.Next_In_Lang := Lang_Id.First_Source;
888 Lang_Id.First_Source := Id;
890 if Source_To_Replace /= No_Source then
891 Remove_Source (Data.Tree, Source_To_Replace, Id);
892 end if;
894 if Data.Tree.Replaced_Source_Number > 0 and then
895 Replaced_Source_HTable.Get (Data.Tree.Replaced_Sources, Id.File) /=
896 No_File
897 then
898 Replaced_Source_HTable.Remove (Data.Tree.Replaced_Sources, Id.File);
899 Data.Tree.Replaced_Source_Number :=
900 Data.Tree.Replaced_Source_Number - 1;
901 end if;
903 Files_Htable.Set (Data.File_To_Source, File_Name, Id);
904 end Add_Source;
906 ------------------------------
907 -- Canonical_Case_File_Name --
908 ------------------------------
910 function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type is
911 begin
912 if Osint.File_Names_Case_Sensitive then
913 return File_Name_Type (Name);
914 else
915 Get_Name_String (Name);
916 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
917 return Name_Find;
918 end if;
919 end Canonical_Case_File_Name;
921 -----------------------------
922 -- Check_Aggregate_Project --
923 -----------------------------
925 procedure Check_Aggregate_Project
926 (Project : Project_Id;
927 Data : in out Tree_Processing_Data)
929 Project_Files : constant Prj.Variable_Value :=
930 Prj.Util.Value_Of
931 (Snames.Name_Project_Files,
932 Project.Decl.Attributes,
933 Data.Tree);
935 procedure Found_Project_File (Path : Path_Information; Rank : Natural);
936 -- Comments required ???
938 procedure Expand_Project_Files is
939 new Expand_Subdirectory_Pattern (Callback => Found_Project_File);
940 -- Comments required ???
942 ------------------------
943 -- Found_Project_File --
944 ------------------------
946 procedure Found_Project_File (Path : Path_Information; Rank : Natural) is
947 pragma Unreferenced (Rank);
948 begin
949 if Current_Verbosity = High then
950 Write_Str (" Aggregates:");
951 Write_Line (Get_Name_String (Path.Display_Name));
952 end if;
953 end Found_Project_File;
955 -- Start of processing for Check_Aggregate_Project
957 begin
958 if Project_Files.Default then
959 Error_Msg_Name_1 := Snames.Name_Project_Files;
960 Error_Msg
961 (Data.Flags,
962 "Attribute %% must be specified in aggregate project",
963 Project.Location, Project);
964 return;
965 end if;
967 -- Look for aggregated projects. For similarity with source files and
968 -- dirs, the aggregated project files are not searched for on the
969 -- project path, and are only found through the path specified in
970 -- the Project_Files attribute.
972 Expand_Project_Files
973 (Project => Project,
974 Data => Data,
975 Patterns => Project_Files.Values,
976 Ignore => Nil_String,
977 Search_For => Search_Files,
978 Resolve_Links => Opt.Follow_Links_For_Files);
980 end Check_Aggregate_Project;
982 ----------------------------
983 -- Check_Abstract_Project --
984 ----------------------------
986 procedure Check_Abstract_Project
987 (Project : Project_Id;
988 Data : in out Tree_Processing_Data)
990 Source_Dirs : constant Variable_Value :=
991 Util.Value_Of
992 (Name_Source_Dirs,
993 Project.Decl.Attributes, Data.Tree);
994 Source_Files : constant Variable_Value :=
995 Util.Value_Of
996 (Name_Source_Files,
997 Project.Decl.Attributes, Data.Tree);
998 Source_List_File : constant Variable_Value :=
999 Util.Value_Of
1000 (Name_Source_List_File,
1001 Project.Decl.Attributes, Data.Tree);
1002 Languages : constant Variable_Value :=
1003 Util.Value_Of
1004 (Name_Languages,
1005 Project.Decl.Attributes, Data.Tree);
1007 begin
1008 if Project.Source_Dirs /= Nil_String then
1009 if Source_Dirs.Values = Nil_String
1010 and then Source_Files.Values = Nil_String
1011 and then Languages.Values = Nil_String
1012 and then Source_List_File.Default
1013 then
1014 Project.Source_Dirs := Nil_String;
1016 else
1017 Error_Msg
1018 (Data.Flags,
1019 "at least one of Source_Files, Source_Dirs or Languages "
1020 & "must be declared empty for an abstract project",
1021 Project.Location, Project);
1022 end if;
1023 end if;
1024 end Check_Abstract_Project;
1026 -----------
1027 -- Check --
1028 -----------
1030 procedure Check
1031 (Project : Project_Id;
1032 Data : in out Tree_Processing_Data)
1034 Prj_Data : Project_Processing_Data;
1036 begin
1037 Initialize (Prj_Data, Project);
1039 Check_If_Externally_Built (Project, Data);
1041 if Project.Qualifier /= Aggregate then
1042 Get_Directories (Project, Data);
1043 Check_Programming_Languages (Project, Data);
1045 if Current_Verbosity = High then
1046 Show_Source_Dirs (Project, Data.Tree);
1047 end if;
1048 end if;
1050 case Project.Qualifier is
1051 when Aggregate => Check_Aggregate_Project (Project, Data);
1052 when Dry => Check_Abstract_Project (Project, Data);
1053 when others => null;
1054 end case;
1056 -- Check configuration. This must be done even for gnatmake (even though
1057 -- no user configuration file was provided) since the default config we
1058 -- generate indicates whether libraries are supported for instance.
1060 Check_Configuration (Project, Data);
1062 if Project.Qualifier /= Aggregate then
1063 Check_Library_Attributes (Project, Data);
1064 Check_Package_Naming (Project, Data);
1065 Look_For_Sources (Prj_Data, Data);
1066 Check_Interfaces (Project, Data);
1068 if Project.Library then
1069 Check_Stand_Alone_Library (Project, Data);
1070 end if;
1072 Get_Mains (Project, Data);
1073 end if;
1075 Free (Prj_Data);
1076 end Check;
1078 --------------------
1079 -- Check_Ada_Name --
1080 --------------------
1082 procedure Check_Ada_Name (Name : String; Unit : out Name_Id) is
1083 The_Name : String := Name;
1084 Real_Name : Name_Id;
1085 Need_Letter : Boolean := True;
1086 Last_Underscore : Boolean := False;
1087 OK : Boolean := The_Name'Length > 0;
1088 First : Positive;
1090 function Is_Reserved (Name : Name_Id) return Boolean;
1091 function Is_Reserved (S : String) return Boolean;
1092 -- Check that the given name is not an Ada 95 reserved word. The reason
1093 -- for the Ada 95 here is that we do not want to exclude the case of an
1094 -- Ada 95 unit called Interface (for example). In Ada 2005, such a unit
1095 -- name would be rejected anyway by the compiler. That means there is no
1096 -- requirement that the project file parser reject this.
1098 -----------------
1099 -- Is_Reserved --
1100 -----------------
1102 function Is_Reserved (S : String) return Boolean is
1103 begin
1104 Name_Len := 0;
1105 Add_Str_To_Name_Buffer (S);
1106 return Is_Reserved (Name_Find);
1107 end Is_Reserved;
1109 -----------------
1110 -- Is_Reserved --
1111 -----------------
1113 function Is_Reserved (Name : Name_Id) return Boolean is
1114 begin
1115 if Get_Name_Table_Byte (Name) /= 0
1116 and then Name /= Name_Project
1117 and then Name /= Name_Extends
1118 and then Name /= Name_External
1119 and then Name not in Ada_2005_Reserved_Words
1120 then
1121 Unit := No_Name;
1123 if Current_Verbosity = High then
1124 Write_Str (The_Name);
1125 Write_Line (" is an Ada reserved word.");
1126 end if;
1128 return True;
1130 else
1131 return False;
1132 end if;
1133 end Is_Reserved;
1135 -- Start of processing for Check_Ada_Name
1137 begin
1138 To_Lower (The_Name);
1140 Name_Len := The_Name'Length;
1141 Name_Buffer (1 .. Name_Len) := The_Name;
1143 -- Special cases of children of packages A, G, I and S on VMS
1145 if OpenVMS_On_Target
1146 and then Name_Len > 3
1147 and then Name_Buffer (2 .. 3) = "__"
1148 and then
1149 ((Name_Buffer (1) = 'a') or else
1150 (Name_Buffer (1) = 'g') or else
1151 (Name_Buffer (1) = 'i') or else
1152 (Name_Buffer (1) = 's'))
1153 then
1154 Name_Buffer (2) := '.';
1155 Name_Buffer (3 .. Name_Len - 1) := Name_Buffer (4 .. Name_Len);
1156 Name_Len := Name_Len - 1;
1157 end if;
1159 Real_Name := Name_Find;
1161 if Is_Reserved (Real_Name) then
1162 return;
1163 end if;
1165 First := The_Name'First;
1167 for Index in The_Name'Range loop
1168 if Need_Letter then
1170 -- We need a letter (at the beginning, and following a dot),
1171 -- but we don't have one.
1173 if Is_Letter (The_Name (Index)) then
1174 Need_Letter := False;
1176 else
1177 OK := False;
1179 if Current_Verbosity = High then
1180 Write_Int (Types.Int (Index));
1181 Write_Str (": '");
1182 Write_Char (The_Name (Index));
1183 Write_Line ("' is not a letter.");
1184 end if;
1186 exit;
1187 end if;
1189 elsif Last_Underscore
1190 and then (The_Name (Index) = '_' or else The_Name (Index) = '.')
1191 then
1192 -- Two underscores are illegal, and a dot cannot follow
1193 -- an underscore.
1195 OK := False;
1197 if Current_Verbosity = High then
1198 Write_Int (Types.Int (Index));
1199 Write_Str (": '");
1200 Write_Char (The_Name (Index));
1201 Write_Line ("' is illegal here.");
1202 end if;
1204 exit;
1206 elsif The_Name (Index) = '.' then
1208 -- First, check if the name before the dot is not a reserved word
1210 if Is_Reserved (The_Name (First .. Index - 1)) then
1211 return;
1212 end if;
1214 First := Index + 1;
1216 -- We need a letter after a dot
1218 Need_Letter := True;
1220 elsif The_Name (Index) = '_' then
1221 Last_Underscore := True;
1223 else
1224 -- We need an letter or a digit
1226 Last_Underscore := False;
1228 if not Is_Alphanumeric (The_Name (Index)) then
1229 OK := False;
1231 if Current_Verbosity = High then
1232 Write_Int (Types.Int (Index));
1233 Write_Str (": '");
1234 Write_Char (The_Name (Index));
1235 Write_Line ("' is not alphanumeric.");
1236 end if;
1238 exit;
1239 end if;
1240 end if;
1241 end loop;
1243 -- Cannot end with an underscore or a dot
1245 OK := OK and then not Need_Letter and then not Last_Underscore;
1247 if OK then
1248 if First /= Name'First and then
1249 Is_Reserved (The_Name (First .. The_Name'Last))
1250 then
1251 return;
1252 end if;
1254 Unit := Real_Name;
1256 else
1257 -- Signal a problem with No_Name
1259 Unit := No_Name;
1260 end if;
1261 end Check_Ada_Name;
1263 -------------------------
1264 -- Check_Configuration --
1265 -------------------------
1267 procedure Check_Configuration
1268 (Project : Project_Id;
1269 Data : in out Tree_Processing_Data)
1271 Dot_Replacement : File_Name_Type := No_File;
1272 Casing : Casing_Type := All_Lower_Case;
1273 Separate_Suffix : File_Name_Type := No_File;
1275 Lang_Index : Language_Ptr := No_Language_Index;
1276 -- The index of the language data being checked
1278 Prev_Index : Language_Ptr := No_Language_Index;
1279 -- The index of the previous language
1281 procedure Process_Project_Level_Simple_Attributes;
1282 -- Process the simple attributes at the project level
1284 procedure Process_Project_Level_Array_Attributes;
1285 -- Process the associate array attributes at the project level
1287 procedure Process_Packages;
1288 -- Read the packages of the project
1290 ----------------------
1291 -- Process_Packages --
1292 ----------------------
1294 procedure Process_Packages is
1295 Packages : Package_Id;
1296 Element : Package_Element;
1298 procedure Process_Binder (Arrays : Array_Id);
1299 -- Process the associate array attributes of package Binder
1301 procedure Process_Builder (Attributes : Variable_Id);
1302 -- Process the simple attributes of package Builder
1304 procedure Process_Compiler (Arrays : Array_Id);
1305 -- Process the associate array attributes of package Compiler
1307 procedure Process_Naming (Attributes : Variable_Id);
1308 -- Process the simple attributes of package Naming
1310 procedure Process_Naming (Arrays : Array_Id);
1311 -- Process the associate array attributes of package Naming
1313 procedure Process_Linker (Attributes : Variable_Id);
1314 -- Process the simple attributes of package Linker of a
1315 -- configuration project.
1317 --------------------
1318 -- Process_Binder --
1319 --------------------
1321 procedure Process_Binder (Arrays : Array_Id) is
1322 Current_Array_Id : Array_Id;
1323 Current_Array : Array_Data;
1324 Element_Id : Array_Element_Id;
1325 Element : Array_Element;
1327 begin
1328 -- Process the associative array attribute of package Binder
1330 Current_Array_Id := Arrays;
1331 while Current_Array_Id /= No_Array loop
1332 Current_Array := Data.Tree.Arrays.Table (Current_Array_Id);
1334 Element_Id := Current_Array.Value;
1335 while Element_Id /= No_Array_Element loop
1336 Element := Data.Tree.Array_Elements.Table (Element_Id);
1338 if Element.Index /= All_Other_Names then
1340 -- Get the name of the language
1342 Lang_Index :=
1343 Get_Language_From_Name
1344 (Project, Get_Name_String (Element.Index));
1346 if Lang_Index /= No_Language_Index then
1347 case Current_Array.Name is
1348 when Name_Driver =>
1350 -- Attribute Driver (<language>)
1352 Lang_Index.Config.Binder_Driver :=
1353 File_Name_Type (Element.Value.Value);
1355 when Name_Required_Switches =>
1357 (Into_List =>
1358 Lang_Index.Config.Binder_Required_Switches,
1359 From_List => Element.Value.Values,
1360 In_Tree => Data.Tree);
1362 when Name_Prefix =>
1364 -- Attribute Prefix (<language>)
1366 Lang_Index.Config.Binder_Prefix :=
1367 Element.Value.Value;
1369 when Name_Objects_Path =>
1371 -- Attribute Objects_Path (<language>)
1373 Lang_Index.Config.Objects_Path :=
1374 Element.Value.Value;
1376 when Name_Objects_Path_File =>
1378 -- Attribute Objects_Path (<language>)
1380 Lang_Index.Config.Objects_Path_File :=
1381 Element.Value.Value;
1383 when others =>
1384 null;
1385 end case;
1386 end if;
1387 end if;
1389 Element_Id := Element.Next;
1390 end loop;
1392 Current_Array_Id := Current_Array.Next;
1393 end loop;
1394 end Process_Binder;
1396 ---------------------
1397 -- Process_Builder --
1398 ---------------------
1400 procedure Process_Builder (Attributes : Variable_Id) is
1401 Attribute_Id : Variable_Id;
1402 Attribute : Variable;
1404 begin
1405 -- Process non associated array attribute from package Builder
1407 Attribute_Id := Attributes;
1408 while Attribute_Id /= No_Variable loop
1409 Attribute :=
1410 Data.Tree.Variable_Elements.Table (Attribute_Id);
1412 if not Attribute.Value.Default then
1413 if Attribute.Name = Name_Executable_Suffix then
1415 -- Attribute Executable_Suffix: the suffix of the
1416 -- executables.
1418 Project.Config.Executable_Suffix :=
1419 Attribute.Value.Value;
1420 end if;
1421 end if;
1423 Attribute_Id := Attribute.Next;
1424 end loop;
1425 end Process_Builder;
1427 ----------------------
1428 -- Process_Compiler --
1429 ----------------------
1431 procedure Process_Compiler (Arrays : Array_Id) is
1432 Current_Array_Id : Array_Id;
1433 Current_Array : Array_Data;
1434 Element_Id : Array_Element_Id;
1435 Element : Array_Element;
1436 List : String_List_Id;
1438 begin
1439 -- Process the associative array attribute of package Compiler
1441 Current_Array_Id := Arrays;
1442 while Current_Array_Id /= No_Array loop
1443 Current_Array := Data.Tree.Arrays.Table (Current_Array_Id);
1445 Element_Id := Current_Array.Value;
1446 while Element_Id /= No_Array_Element loop
1447 Element := Data.Tree.Array_Elements.Table (Element_Id);
1449 if Element.Index /= All_Other_Names then
1451 -- Get the name of the language
1453 Lang_Index := Get_Language_From_Name
1454 (Project, Get_Name_String (Element.Index));
1456 if Lang_Index /= No_Language_Index then
1457 case Current_Array.Name is
1458 when Name_Dependency_Switches =>
1460 -- Attribute Dependency_Switches (<language>)
1462 if Lang_Index.Config.Dependency_Kind = None then
1463 Lang_Index.Config.Dependency_Kind := Makefile;
1464 end if;
1466 List := Element.Value.Values;
1468 if List /= Nil_String then
1469 Put (Into_List =>
1470 Lang_Index.Config.Dependency_Option,
1471 From_List => List,
1472 In_Tree => Data.Tree);
1473 end if;
1475 when Name_Dependency_Driver =>
1477 -- Attribute Dependency_Driver (<language>)
1479 if Lang_Index.Config.Dependency_Kind = None then
1480 Lang_Index.Config.Dependency_Kind := Makefile;
1481 end if;
1483 List := Element.Value.Values;
1485 if List /= Nil_String then
1486 Put (Into_List =>
1487 Lang_Index.Config.Compute_Dependency,
1488 From_List => List,
1489 In_Tree => Data.Tree);
1490 end if;
1492 when Name_Include_Switches =>
1494 -- Attribute Include_Switches (<language>)
1496 List := Element.Value.Values;
1498 if List = Nil_String then
1499 Error_Msg
1500 (Data.Flags, "include option cannot be null",
1501 Element.Value.Location, Project);
1502 end if;
1504 Put (Into_List => Lang_Index.Config.Include_Option,
1505 From_List => List,
1506 In_Tree => Data.Tree);
1508 when Name_Include_Path =>
1510 -- Attribute Include_Path (<language>)
1512 Lang_Index.Config.Include_Path :=
1513 Element.Value.Value;
1515 when Name_Include_Path_File =>
1517 -- Attribute Include_Path_File (<language>)
1519 Lang_Index.Config.Include_Path_File :=
1520 Element.Value.Value;
1522 when Name_Driver =>
1524 -- Attribute Driver (<language>)
1526 Lang_Index.Config.Compiler_Driver :=
1527 File_Name_Type (Element.Value.Value);
1529 when Name_Required_Switches |
1530 Name_Leading_Required_Switches =>
1531 Put (Into_List =>
1532 Lang_Index.Config.
1533 Compiler_Leading_Required_Switches,
1534 From_List => Element.Value.Values,
1535 In_Tree => Data.Tree);
1537 when Name_Trailing_Required_Switches =>
1538 Put (Into_List =>
1539 Lang_Index.Config.
1540 Compiler_Trailing_Required_Switches,
1541 From_List => Element.Value.Values,
1542 In_Tree => Data.Tree);
1544 when Name_Multi_Unit_Switches =>
1545 Put (Into_List =>
1546 Lang_Index.Config.Multi_Unit_Switches,
1547 From_List => Element.Value.Values,
1548 In_Tree => Data.Tree);
1550 when Name_Multi_Unit_Object_Separator =>
1551 Get_Name_String (Element.Value.Value);
1553 if Name_Len /= 1 then
1554 Error_Msg
1555 (Data.Flags,
1556 "multi-unit object separator must have " &
1557 "a single character",
1558 Element.Value.Location, Project);
1560 elsif Name_Buffer (1) = ' ' then
1561 Error_Msg
1562 (Data.Flags,
1563 "multi-unit object separator cannot be " &
1564 "a space",
1565 Element.Value.Location, Project);
1567 else
1568 Lang_Index.Config.Multi_Unit_Object_Separator :=
1569 Name_Buffer (1);
1570 end if;
1572 when Name_Path_Syntax =>
1573 begin
1574 Lang_Index.Config.Path_Syntax :=
1575 Path_Syntax_Kind'Value
1576 (Get_Name_String (Element.Value.Value));
1578 exception
1579 when Constraint_Error =>
1580 Error_Msg
1581 (Data.Flags,
1582 "invalid value for Path_Syntax",
1583 Element.Value.Location, Project);
1584 end;
1586 when Name_Object_File_Suffix =>
1587 if Get_Name_String (Element.Value.Value) = "" then
1588 Error_Msg
1589 (Data.Flags,
1590 "object file suffix cannot be empty",
1591 Element.Value.Location, Project);
1593 else
1594 Lang_Index.Config.Object_File_Suffix :=
1595 Element.Value.Value;
1596 end if;
1598 when Name_Object_File_Switches =>
1599 Put (Into_List =>
1600 Lang_Index.Config.Object_File_Switches,
1601 From_List => Element.Value.Values,
1602 In_Tree => Data.Tree);
1604 when Name_Pic_Option =>
1606 -- Attribute Compiler_Pic_Option (<language>)
1608 List := Element.Value.Values;
1610 if List = Nil_String then
1611 Error_Msg
1612 (Data.Flags,
1613 "compiler PIC option cannot be null",
1614 Element.Value.Location, Project);
1615 end if;
1617 Put (Into_List =>
1618 Lang_Index.Config.Compilation_PIC_Option,
1619 From_List => List,
1620 In_Tree => Data.Tree);
1622 when Name_Mapping_File_Switches =>
1624 -- Attribute Mapping_File_Switches (<language>)
1626 List := Element.Value.Values;
1628 if List = Nil_String then
1629 Error_Msg
1630 (Data.Flags,
1631 "mapping file switches cannot be null",
1632 Element.Value.Location, Project);
1633 end if;
1635 Put (Into_List =>
1636 Lang_Index.Config.Mapping_File_Switches,
1637 From_List => List,
1638 In_Tree => Data.Tree);
1640 when Name_Mapping_Spec_Suffix =>
1642 -- Attribute Mapping_Spec_Suffix (<language>)
1644 Lang_Index.Config.Mapping_Spec_Suffix :=
1645 File_Name_Type (Element.Value.Value);
1647 when Name_Mapping_Body_Suffix =>
1649 -- Attribute Mapping_Body_Suffix (<language>)
1651 Lang_Index.Config.Mapping_Body_Suffix :=
1652 File_Name_Type (Element.Value.Value);
1654 when Name_Config_File_Switches =>
1656 -- Attribute Config_File_Switches (<language>)
1658 List := Element.Value.Values;
1660 if List = Nil_String then
1661 Error_Msg
1662 (Data.Flags,
1663 "config file switches cannot be null",
1664 Element.Value.Location, Project);
1665 end if;
1667 Put (Into_List =>
1668 Lang_Index.Config.Config_File_Switches,
1669 From_List => List,
1670 In_Tree => Data.Tree);
1672 when Name_Objects_Path =>
1674 -- Attribute Objects_Path (<language>)
1676 Lang_Index.Config.Objects_Path :=
1677 Element.Value.Value;
1679 when Name_Objects_Path_File =>
1681 -- Attribute Objects_Path_File (<language>)
1683 Lang_Index.Config.Objects_Path_File :=
1684 Element.Value.Value;
1686 when Name_Config_Body_File_Name =>
1688 -- Attribute Config_Body_File_Name (<language>)
1690 Lang_Index.Config.Config_Body :=
1691 Element.Value.Value;
1693 when Name_Config_Body_File_Name_Index =>
1695 -- Attribute Config_Body_File_Name_Index
1696 -- ( < Language > )
1698 Lang_Index.Config.Config_Body_Index :=
1699 Element.Value.Value;
1701 when Name_Config_Body_File_Name_Pattern =>
1703 -- Attribute Config_Body_File_Name_Pattern
1704 -- (<language>)
1706 Lang_Index.Config.Config_Body_Pattern :=
1707 Element.Value.Value;
1709 when Name_Config_Spec_File_Name =>
1711 -- Attribute Config_Spec_File_Name (<language>)
1713 Lang_Index.Config.Config_Spec :=
1714 Element.Value.Value;
1716 when Name_Config_Spec_File_Name_Index =>
1718 -- Attribute Config_Spec_File_Name_Index
1719 -- ( < Language > )
1721 Lang_Index.Config.Config_Spec_Index :=
1722 Element.Value.Value;
1724 when Name_Config_Spec_File_Name_Pattern =>
1726 -- Attribute Config_Spec_File_Name_Pattern
1727 -- (<language>)
1729 Lang_Index.Config.Config_Spec_Pattern :=
1730 Element.Value.Value;
1732 when Name_Config_File_Unique =>
1734 -- Attribute Config_File_Unique (<language>)
1736 begin
1737 Lang_Index.Config.Config_File_Unique :=
1738 Boolean'Value
1739 (Get_Name_String (Element.Value.Value));
1740 exception
1741 when Constraint_Error =>
1742 Error_Msg
1743 (Data.Flags,
1744 "illegal value for Config_File_Unique",
1745 Element.Value.Location, Project);
1746 end;
1748 when others =>
1749 null;
1750 end case;
1751 end if;
1752 end if;
1754 Element_Id := Element.Next;
1755 end loop;
1757 Current_Array_Id := Current_Array.Next;
1758 end loop;
1759 end Process_Compiler;
1761 --------------------
1762 -- Process_Naming --
1763 --------------------
1765 procedure Process_Naming (Attributes : Variable_Id) is
1766 Attribute_Id : Variable_Id;
1767 Attribute : Variable;
1769 begin
1770 -- Process non associated array attribute from package Naming
1772 Attribute_Id := Attributes;
1773 while Attribute_Id /= No_Variable loop
1774 Attribute := Data.Tree.Variable_Elements.Table (Attribute_Id);
1776 if not Attribute.Value.Default then
1777 if Attribute.Name = Name_Separate_Suffix then
1779 -- Attribute Separate_Suffix
1781 Get_Name_String (Attribute.Value.Value);
1782 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1783 Separate_Suffix := Name_Find;
1785 elsif Attribute.Name = Name_Casing then
1787 -- Attribute Casing
1789 begin
1790 Casing :=
1791 Value (Get_Name_String (Attribute.Value.Value));
1793 exception
1794 when Constraint_Error =>
1795 Error_Msg
1796 (Data.Flags,
1797 "invalid value for Casing",
1798 Attribute.Value.Location, Project);
1799 end;
1801 elsif Attribute.Name = Name_Dot_Replacement then
1803 -- Attribute Dot_Replacement
1805 Dot_Replacement := File_Name_Type (Attribute.Value.Value);
1807 end if;
1808 end if;
1810 Attribute_Id := Attribute.Next;
1811 end loop;
1812 end Process_Naming;
1814 procedure Process_Naming (Arrays : Array_Id) is
1815 Current_Array_Id : Array_Id;
1816 Current_Array : Array_Data;
1817 Element_Id : Array_Element_Id;
1818 Element : Array_Element;
1820 begin
1821 -- Process the associative array attribute of package Naming
1823 Current_Array_Id := Arrays;
1824 while Current_Array_Id /= No_Array loop
1825 Current_Array := Data.Tree.Arrays.Table (Current_Array_Id);
1827 Element_Id := Current_Array.Value;
1828 while Element_Id /= No_Array_Element loop
1829 Element := Data.Tree.Array_Elements.Table (Element_Id);
1831 -- Get the name of the language
1833 Lang_Index := Get_Language_From_Name
1834 (Project, Get_Name_String (Element.Index));
1836 if Lang_Index /= No_Language_Index then
1837 case Current_Array.Name is
1838 when Name_Spec_Suffix | Name_Specification_Suffix =>
1840 -- Attribute Spec_Suffix (<language>)
1842 Get_Name_String (Element.Value.Value);
1843 Canonical_Case_File_Name
1844 (Name_Buffer (1 .. Name_Len));
1845 Lang_Index.Config.Naming_Data.Spec_Suffix :=
1846 Name_Find;
1848 when Name_Implementation_Suffix | Name_Body_Suffix =>
1850 Get_Name_String (Element.Value.Value);
1851 Canonical_Case_File_Name
1852 (Name_Buffer (1 .. Name_Len));
1854 -- Attribute Body_Suffix (<language>)
1856 Lang_Index.Config.Naming_Data.Body_Suffix :=
1857 Name_Find;
1858 Lang_Index.Config.Naming_Data.Separate_Suffix :=
1859 Lang_Index.Config.Naming_Data.Body_Suffix;
1861 when others =>
1862 null;
1863 end case;
1864 end if;
1866 Element_Id := Element.Next;
1867 end loop;
1869 Current_Array_Id := Current_Array.Next;
1870 end loop;
1871 end Process_Naming;
1873 --------------------
1874 -- Process_Linker --
1875 --------------------
1877 procedure Process_Linker (Attributes : Variable_Id) is
1878 Attribute_Id : Variable_Id;
1879 Attribute : Variable;
1881 begin
1882 -- Process non associated array attribute from package Linker
1884 Attribute_Id := Attributes;
1885 while Attribute_Id /= No_Variable loop
1886 Attribute :=
1887 Data.Tree.Variable_Elements.Table (Attribute_Id);
1889 if not Attribute.Value.Default then
1890 if Attribute.Name = Name_Driver then
1892 -- Attribute Linker'Driver: the default linker to use
1894 Project.Config.Linker :=
1895 Path_Name_Type (Attribute.Value.Value);
1897 -- Linker'Driver is also used to link shared libraries
1898 -- if the obsolescent attribute Library_GCC has not been
1899 -- specified.
1901 if Project.Config.Shared_Lib_Driver = No_File then
1902 Project.Config.Shared_Lib_Driver :=
1903 File_Name_Type (Attribute.Value.Value);
1904 end if;
1906 elsif Attribute.Name = Name_Required_Switches then
1908 -- Attribute Required_Switches: the minimum trailing
1909 -- options to use when invoking the linker
1911 Put (Into_List =>
1912 Project.Config.Trailing_Linker_Required_Switches,
1913 From_List => Attribute.Value.Values,
1914 In_Tree => Data.Tree);
1916 elsif Attribute.Name = Name_Map_File_Option then
1917 Project.Config.Map_File_Option := Attribute.Value.Value;
1919 elsif Attribute.Name = Name_Max_Command_Line_Length then
1920 begin
1921 Project.Config.Max_Command_Line_Length :=
1922 Natural'Value (Get_Name_String
1923 (Attribute.Value.Value));
1925 exception
1926 when Constraint_Error =>
1927 Error_Msg
1928 (Data.Flags,
1929 "value must be positive or equal to 0",
1930 Attribute.Value.Location, Project);
1931 end;
1933 elsif Attribute.Name = Name_Response_File_Format then
1934 declare
1935 Name : Name_Id;
1937 begin
1938 Get_Name_String (Attribute.Value.Value);
1939 To_Lower (Name_Buffer (1 .. Name_Len));
1940 Name := Name_Find;
1942 if Name = Name_None then
1943 Project.Config.Resp_File_Format := None;
1945 elsif Name = Name_Gnu then
1946 Project.Config.Resp_File_Format := GNU;
1948 elsif Name = Name_Object_List then
1949 Project.Config.Resp_File_Format := Object_List;
1951 elsif Name = Name_Option_List then
1952 Project.Config.Resp_File_Format := Option_List;
1954 elsif Name_Buffer (1 .. Name_Len) = "gcc" then
1955 Project.Config.Resp_File_Format := GCC;
1957 elsif Name_Buffer (1 .. Name_Len) = "gcc_gnu" then
1958 Project.Config.Resp_File_Format := GCC_GNU;
1960 elsif
1961 Name_Buffer (1 .. Name_Len) = "gcc_option_list"
1962 then
1963 Project.Config.Resp_File_Format := GCC_Option_List;
1965 elsif
1966 Name_Buffer (1 .. Name_Len) = "gcc_object_list"
1967 then
1968 Project.Config.Resp_File_Format := GCC_Object_List;
1970 else
1971 Error_Msg
1972 (Data.Flags,
1973 "illegal response file format",
1974 Attribute.Value.Location, Project);
1975 end if;
1976 end;
1978 elsif Attribute.Name = Name_Response_File_Switches then
1979 Put (Into_List => Project.Config.Resp_File_Options,
1980 From_List => Attribute.Value.Values,
1981 In_Tree => Data.Tree);
1982 end if;
1983 end if;
1985 Attribute_Id := Attribute.Next;
1986 end loop;
1987 end Process_Linker;
1989 -- Start of processing for Process_Packages
1991 begin
1992 Packages := Project.Decl.Packages;
1993 while Packages /= No_Package loop
1994 Element := Data.Tree.Packages.Table (Packages);
1996 case Element.Name is
1997 when Name_Binder =>
1999 -- Process attributes of package Binder
2001 Process_Binder (Element.Decl.Arrays);
2003 when Name_Builder =>
2005 -- Process attributes of package Builder
2007 Process_Builder (Element.Decl.Attributes);
2009 when Name_Compiler =>
2011 -- Process attributes of package Compiler
2013 Process_Compiler (Element.Decl.Arrays);
2015 when Name_Linker =>
2017 -- Process attributes of package Linker
2019 Process_Linker (Element.Decl.Attributes);
2021 when Name_Naming =>
2023 -- Process attributes of package Naming
2025 Process_Naming (Element.Decl.Attributes);
2026 Process_Naming (Element.Decl.Arrays);
2028 when others =>
2029 null;
2030 end case;
2032 Packages := Element.Next;
2033 end loop;
2034 end Process_Packages;
2036 ---------------------------------------------
2037 -- Process_Project_Level_Simple_Attributes --
2038 ---------------------------------------------
2040 procedure Process_Project_Level_Simple_Attributes is
2041 Attribute_Id : Variable_Id;
2042 Attribute : Variable;
2043 List : String_List_Id;
2045 begin
2046 -- Process non associated array attribute at project level
2048 Attribute_Id := Project.Decl.Attributes;
2049 while Attribute_Id /= No_Variable loop
2050 Attribute :=
2051 Data.Tree.Variable_Elements.Table (Attribute_Id);
2053 if not Attribute.Value.Default then
2054 if Attribute.Name = Name_Target then
2056 -- Attribute Target: the target specified
2058 Project.Config.Target := Attribute.Value.Value;
2060 elsif Attribute.Name = Name_Library_Builder then
2062 -- Attribute Library_Builder: the application to invoke
2063 -- to build libraries.
2065 Project.Config.Library_Builder :=
2066 Path_Name_Type (Attribute.Value.Value);
2068 elsif Attribute.Name = Name_Archive_Builder then
2070 -- Attribute Archive_Builder: the archive builder
2071 -- (usually "ar") and its minimum options (usually "cr").
2073 List := Attribute.Value.Values;
2075 if List = Nil_String then
2076 Error_Msg
2077 (Data.Flags,
2078 "archive builder cannot be null",
2079 Attribute.Value.Location, Project);
2080 end if;
2082 Put (Into_List => Project.Config.Archive_Builder,
2083 From_List => List,
2084 In_Tree => Data.Tree);
2086 elsif Attribute.Name = Name_Archive_Builder_Append_Option then
2088 -- Attribute Archive_Builder: the archive builder
2089 -- (usually "ar") and its minimum options (usually "cr").
2091 List := Attribute.Value.Values;
2093 if List /= Nil_String then
2095 (Into_List =>
2096 Project.Config.Archive_Builder_Append_Option,
2097 From_List => List,
2098 In_Tree => Data.Tree);
2099 end if;
2101 elsif Attribute.Name = Name_Archive_Indexer then
2103 -- Attribute Archive_Indexer: the optional archive
2104 -- indexer (usually "ranlib") with its minimum options
2105 -- (usually none).
2107 List := Attribute.Value.Values;
2109 if List = Nil_String then
2110 Error_Msg
2111 (Data.Flags,
2112 "archive indexer cannot be null",
2113 Attribute.Value.Location, Project);
2114 end if;
2116 Put (Into_List => Project.Config.Archive_Indexer,
2117 From_List => List,
2118 In_Tree => Data.Tree);
2120 elsif Attribute.Name = Name_Library_Partial_Linker then
2122 -- Attribute Library_Partial_Linker: the optional linker
2123 -- driver with its minimum options, to partially link
2124 -- archives.
2126 List := Attribute.Value.Values;
2128 if List = Nil_String then
2129 Error_Msg
2130 (Data.Flags,
2131 "partial linker cannot be null",
2132 Attribute.Value.Location, Project);
2133 end if;
2135 Put (Into_List => Project.Config.Lib_Partial_Linker,
2136 From_List => List,
2137 In_Tree => Data.Tree);
2139 elsif Attribute.Name = Name_Library_GCC then
2140 Project.Config.Shared_Lib_Driver :=
2141 File_Name_Type (Attribute.Value.Value);
2142 Error_Msg
2143 (Data.Flags,
2144 "?Library_'G'C'C is an obsolescent attribute, " &
2145 "use Linker''Driver instead",
2146 Attribute.Value.Location, Project);
2148 elsif Attribute.Name = Name_Archive_Suffix then
2149 Project.Config.Archive_Suffix :=
2150 File_Name_Type (Attribute.Value.Value);
2152 elsif Attribute.Name = Name_Linker_Executable_Option then
2154 -- Attribute Linker_Executable_Option: optional options
2155 -- to specify an executable name. Defaults to "-o".
2157 List := Attribute.Value.Values;
2159 if List = Nil_String then
2160 Error_Msg
2161 (Data.Flags,
2162 "linker executable option cannot be null",
2163 Attribute.Value.Location, Project);
2164 end if;
2166 Put (Into_List => Project.Config.Linker_Executable_Option,
2167 From_List => List,
2168 In_Tree => Data.Tree);
2170 elsif Attribute.Name = Name_Linker_Lib_Dir_Option then
2172 -- Attribute Linker_Lib_Dir_Option: optional options
2173 -- to specify a library search directory. Defaults to
2174 -- "-L".
2176 Get_Name_String (Attribute.Value.Value);
2178 if Name_Len = 0 then
2179 Error_Msg
2180 (Data.Flags,
2181 "linker library directory option cannot be empty",
2182 Attribute.Value.Location, Project);
2183 end if;
2185 Project.Config.Linker_Lib_Dir_Option :=
2186 Attribute.Value.Value;
2188 elsif Attribute.Name = Name_Linker_Lib_Name_Option then
2190 -- Attribute Linker_Lib_Name_Option: optional options
2191 -- to specify the name of a library to be linked in.
2192 -- Defaults to "-l".
2194 Get_Name_String (Attribute.Value.Value);
2196 if Name_Len = 0 then
2197 Error_Msg
2198 (Data.Flags,
2199 "linker library name option cannot be empty",
2200 Attribute.Value.Location, Project);
2201 end if;
2203 Project.Config.Linker_Lib_Name_Option :=
2204 Attribute.Value.Value;
2206 elsif Attribute.Name = Name_Run_Path_Option then
2208 -- Attribute Run_Path_Option: optional options to
2209 -- specify a path for libraries.
2211 List := Attribute.Value.Values;
2213 if List /= Nil_String then
2214 Put (Into_List => Project.Config.Run_Path_Option,
2215 From_List => List,
2216 In_Tree => Data.Tree);
2217 end if;
2219 elsif Attribute.Name = Name_Run_Path_Origin then
2220 Get_Name_String (Attribute.Value.Value);
2222 if Name_Len = 0 then
2223 Error_Msg
2224 (Data.Flags,
2225 "run path origin cannot be empty",
2226 Attribute.Value.Location, Project);
2227 end if;
2229 Project.Config.Run_Path_Origin := Attribute.Value.Value;
2231 elsif Attribute.Name = Name_Library_Install_Name_Option then
2232 Project.Config.Library_Install_Name_Option :=
2233 Attribute.Value.Value;
2235 elsif Attribute.Name = Name_Separate_Run_Path_Options then
2236 declare
2237 pragma Unsuppress (All_Checks);
2238 begin
2239 Project.Config.Separate_Run_Path_Options :=
2240 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2241 exception
2242 when Constraint_Error =>
2243 Error_Msg
2244 (Data.Flags,
2245 "invalid value """ &
2246 Get_Name_String (Attribute.Value.Value) &
2247 """ for Separate_Run_Path_Options",
2248 Attribute.Value.Location, Project);
2249 end;
2251 elsif Attribute.Name = Name_Library_Support then
2252 declare
2253 pragma Unsuppress (All_Checks);
2254 begin
2255 Project.Config.Lib_Support :=
2256 Library_Support'Value (Get_Name_String
2257 (Attribute.Value.Value));
2258 exception
2259 when Constraint_Error =>
2260 Error_Msg
2261 (Data.Flags,
2262 "invalid value """ &
2263 Get_Name_String (Attribute.Value.Value) &
2264 """ for Library_Support",
2265 Attribute.Value.Location, Project);
2266 end;
2268 elsif Attribute.Name = Name_Shared_Library_Prefix then
2269 Project.Config.Shared_Lib_Prefix :=
2270 File_Name_Type (Attribute.Value.Value);
2272 elsif Attribute.Name = Name_Shared_Library_Suffix then
2273 Project.Config.Shared_Lib_Suffix :=
2274 File_Name_Type (Attribute.Value.Value);
2276 elsif Attribute.Name = Name_Symbolic_Link_Supported then
2277 declare
2278 pragma Unsuppress (All_Checks);
2279 begin
2280 Project.Config.Symbolic_Link_Supported :=
2281 Boolean'Value (Get_Name_String
2282 (Attribute.Value.Value));
2283 exception
2284 when Constraint_Error =>
2285 Error_Msg
2286 (Data.Flags,
2287 "invalid value """
2288 & Get_Name_String (Attribute.Value.Value)
2289 & """ for Symbolic_Link_Supported",
2290 Attribute.Value.Location, Project);
2291 end;
2293 elsif
2294 Attribute.Name = Name_Library_Major_Minor_Id_Supported
2295 then
2296 declare
2297 pragma Unsuppress (All_Checks);
2298 begin
2299 Project.Config.Lib_Maj_Min_Id_Supported :=
2300 Boolean'Value (Get_Name_String
2301 (Attribute.Value.Value));
2302 exception
2303 when Constraint_Error =>
2304 Error_Msg
2305 (Data.Flags,
2306 "invalid value """ &
2307 Get_Name_String (Attribute.Value.Value) &
2308 """ for Library_Major_Minor_Id_Supported",
2309 Attribute.Value.Location, Project);
2310 end;
2312 elsif Attribute.Name = Name_Library_Auto_Init_Supported then
2313 declare
2314 pragma Unsuppress (All_Checks);
2315 begin
2316 Project.Config.Auto_Init_Supported :=
2317 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2318 exception
2319 when Constraint_Error =>
2320 Error_Msg
2321 (Data.Flags,
2322 "invalid value """
2323 & Get_Name_String (Attribute.Value.Value)
2324 & """ for Library_Auto_Init_Supported",
2325 Attribute.Value.Location, Project);
2326 end;
2328 elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then
2329 List := Attribute.Value.Values;
2331 if List /= Nil_String then
2332 Put (Into_List => Project.Config.Shared_Lib_Min_Options,
2333 From_List => List,
2334 In_Tree => Data.Tree);
2335 end if;
2337 elsif Attribute.Name = Name_Library_Version_Switches then
2338 List := Attribute.Value.Values;
2340 if List /= Nil_String then
2341 Put (Into_List => Project.Config.Lib_Version_Options,
2342 From_List => List,
2343 In_Tree => Data.Tree);
2344 end if;
2345 end if;
2346 end if;
2348 Attribute_Id := Attribute.Next;
2349 end loop;
2350 end Process_Project_Level_Simple_Attributes;
2352 --------------------------------------------
2353 -- Process_Project_Level_Array_Attributes --
2354 --------------------------------------------
2356 procedure Process_Project_Level_Array_Attributes is
2357 Current_Array_Id : Array_Id;
2358 Current_Array : Array_Data;
2359 Element_Id : Array_Element_Id;
2360 Element : Array_Element;
2361 List : String_List_Id;
2363 begin
2364 -- Process the associative array attributes at project level
2366 Current_Array_Id := Project.Decl.Arrays;
2367 while Current_Array_Id /= No_Array loop
2368 Current_Array := Data.Tree.Arrays.Table (Current_Array_Id);
2370 Element_Id := Current_Array.Value;
2371 while Element_Id /= No_Array_Element loop
2372 Element := Data.Tree.Array_Elements.Table (Element_Id);
2374 -- Get the name of the language
2376 Lang_Index :=
2377 Get_Language_From_Name
2378 (Project, Get_Name_String (Element.Index));
2380 if Lang_Index /= No_Language_Index then
2381 case Current_Array.Name is
2382 when Name_Inherit_Source_Path =>
2383 List := Element.Value.Values;
2385 if List /= Nil_String then
2387 (Into_List =>
2388 Lang_Index.Config.Include_Compatible_Languages,
2389 From_List => List,
2390 In_Tree => Data.Tree,
2391 Lower_Case => True);
2392 end if;
2394 when Name_Toolchain_Description =>
2396 -- Attribute Toolchain_Description (<language>)
2398 Lang_Index.Config.Toolchain_Description :=
2399 Element.Value.Value;
2401 when Name_Toolchain_Version =>
2403 -- Attribute Toolchain_Version (<language>)
2405 Lang_Index.Config.Toolchain_Version :=
2406 Element.Value.Value;
2408 -- For Ada, set proper checksum computation mode
2410 if Lang_Index.Name = Name_Ada then
2411 declare
2412 Vers : constant String :=
2413 Get_Name_String (Element.Value.Value);
2414 pragma Assert (Vers'First = 1);
2416 begin
2417 -- Version 6.3 or earlier
2419 if Vers'Length >= 8
2420 and then Vers (1 .. 5) = "GNAT "
2421 and then Vers (7) = '.'
2422 and then
2423 (Vers (6) < '6'
2424 or else
2425 (Vers (6) = '6' and then Vers (8) < '4'))
2426 then
2427 Checksum_GNAT_6_3 := True;
2429 -- Version 5.03 or earlier
2431 if Vers (6) < '5'
2432 or else (Vers (6) = '5'
2433 and then Vers (Vers'Last) < '4')
2434 then
2435 Checksum_GNAT_5_03 := True;
2437 -- Version 5.02 or earlier
2439 if Vers (6) /= '5'
2440 or else Vers (Vers'Last) < '3'
2441 then
2442 Checksum_Accumulate_Token_Checksum :=
2443 False;
2444 end if;
2445 end if;
2446 end if;
2447 end;
2448 end if;
2450 when Name_Runtime_Library_Dir =>
2452 -- Attribute Runtime_Library_Dir (<language>)
2454 Lang_Index.Config.Runtime_Library_Dir :=
2455 Element.Value.Value;
2457 when Name_Runtime_Source_Dir =>
2459 -- Attribute Runtime_Library_Dir (<language>)
2461 Lang_Index.Config.Runtime_Source_Dir :=
2462 Element.Value.Value;
2464 when Name_Object_Generated =>
2465 declare
2466 pragma Unsuppress (All_Checks);
2467 Value : Boolean;
2469 begin
2470 Value :=
2471 Boolean'Value
2472 (Get_Name_String (Element.Value.Value));
2474 Lang_Index.Config.Object_Generated := Value;
2476 -- If no object is generated, no object may be
2477 -- linked.
2479 if not Value then
2480 Lang_Index.Config.Objects_Linked := False;
2481 end if;
2483 exception
2484 when Constraint_Error =>
2485 Error_Msg
2486 (Data.Flags,
2487 "invalid value """
2488 & Get_Name_String (Element.Value.Value)
2489 & """ for Object_Generated",
2490 Element.Value.Location, Project);
2491 end;
2493 when Name_Objects_Linked =>
2494 declare
2495 pragma Unsuppress (All_Checks);
2496 Value : Boolean;
2498 begin
2499 Value :=
2500 Boolean'Value
2501 (Get_Name_String (Element.Value.Value));
2503 -- No change if Object_Generated is False, as this
2504 -- forces Objects_Linked to be False too.
2506 if Lang_Index.Config.Object_Generated then
2507 Lang_Index.Config.Objects_Linked := Value;
2508 end if;
2510 exception
2511 when Constraint_Error =>
2512 Error_Msg
2513 (Data.Flags,
2514 "invalid value """
2515 & Get_Name_String (Element.Value.Value)
2516 & """ for Objects_Linked",
2517 Element.Value.Location, Project);
2518 end;
2519 when others =>
2520 null;
2521 end case;
2522 end if;
2524 Element_Id := Element.Next;
2525 end loop;
2527 Current_Array_Id := Current_Array.Next;
2528 end loop;
2529 end Process_Project_Level_Array_Attributes;
2531 -- Start of processing for Check_Configuration
2533 begin
2534 Process_Project_Level_Simple_Attributes;
2535 Process_Project_Level_Array_Attributes;
2536 Process_Packages;
2538 -- For unit based languages, set Casing, Dot_Replacement and
2539 -- Separate_Suffix in Naming_Data.
2541 Lang_Index := Project.Languages;
2542 while Lang_Index /= No_Language_Index loop
2543 if Lang_Index.Name = Name_Ada then
2544 Lang_Index.Config.Naming_Data.Casing := Casing;
2545 Lang_Index.Config.Naming_Data.Dot_Replacement := Dot_Replacement;
2547 if Separate_Suffix /= No_File then
2548 Lang_Index.Config.Naming_Data.Separate_Suffix :=
2549 Separate_Suffix;
2550 end if;
2552 exit;
2553 end if;
2555 Lang_Index := Lang_Index.Next;
2556 end loop;
2558 -- Give empty names to various prefixes/suffixes, if they have not
2559 -- been specified in the configuration.
2561 if Project.Config.Archive_Suffix = No_File then
2562 Project.Config.Archive_Suffix := Empty_File;
2563 end if;
2565 if Project.Config.Shared_Lib_Prefix = No_File then
2566 Project.Config.Shared_Lib_Prefix := Empty_File;
2567 end if;
2569 if Project.Config.Shared_Lib_Suffix = No_File then
2570 Project.Config.Shared_Lib_Suffix := Empty_File;
2571 end if;
2573 Lang_Index := Project.Languages;
2574 while Lang_Index /= No_Language_Index loop
2576 -- For all languages, Compiler_Driver needs to be specified. This is
2577 -- only needed if we do intend to compile (not in GPS for instance).
2579 if Data.Flags.Compiler_Driver_Mandatory
2580 and then Lang_Index.Config.Compiler_Driver = No_File
2581 then
2582 Error_Msg_Name_1 := Lang_Index.Display_Name;
2583 Error_Msg
2584 (Data.Flags,
2585 "?no compiler specified for language %%" &
2586 ", ignoring all its sources",
2587 No_Location, Project);
2589 if Lang_Index = Project.Languages then
2590 Project.Languages := Lang_Index.Next;
2591 else
2592 Prev_Index.Next := Lang_Index.Next;
2593 end if;
2595 elsif Lang_Index.Name = Name_Ada then
2596 Prev_Index := Lang_Index;
2598 -- For unit based languages, Dot_Replacement, Spec_Suffix and
2599 -- Body_Suffix need to be specified.
2601 if Lang_Index.Config.Naming_Data.Dot_Replacement = No_File then
2602 Error_Msg
2603 (Data.Flags,
2604 "Dot_Replacement not specified for Ada",
2605 No_Location, Project);
2606 end if;
2608 if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then
2609 Error_Msg
2610 (Data.Flags,
2611 "Spec_Suffix not specified for Ada",
2612 No_Location, Project);
2613 end if;
2615 if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then
2616 Error_Msg
2617 (Data.Flags,
2618 "Body_Suffix not specified for Ada",
2619 No_Location, Project);
2620 end if;
2622 else
2623 Prev_Index := Lang_Index;
2625 -- For file based languages, either Spec_Suffix or Body_Suffix
2626 -- need to be specified.
2628 if Data.Flags.Require_Sources_Other_Lang
2629 and then Lang_Index.Config.Naming_Data.Spec_Suffix = No_File
2630 and then Lang_Index.Config.Naming_Data.Body_Suffix = No_File
2631 then
2632 Error_Msg_Name_1 := Lang_Index.Display_Name;
2633 Error_Msg
2634 (Data.Flags,
2635 "no suffixes specified for %%",
2636 No_Location, Project);
2637 end if;
2638 end if;
2640 Lang_Index := Lang_Index.Next;
2641 end loop;
2642 end Check_Configuration;
2644 -------------------------------
2645 -- Check_If_Externally_Built --
2646 -------------------------------
2648 procedure Check_If_Externally_Built
2649 (Project : Project_Id;
2650 Data : in out Tree_Processing_Data)
2652 Externally_Built : constant Variable_Value :=
2653 Util.Value_Of
2654 (Name_Externally_Built,
2655 Project.Decl.Attributes, Data.Tree);
2657 begin
2658 if not Externally_Built.Default then
2659 Get_Name_String (Externally_Built.Value);
2660 To_Lower (Name_Buffer (1 .. Name_Len));
2662 if Name_Buffer (1 .. Name_Len) = "true" then
2663 Project.Externally_Built := True;
2665 elsif Name_Buffer (1 .. Name_Len) /= "false" then
2666 Error_Msg (Data.Flags,
2667 "Externally_Built may only be true or false",
2668 Externally_Built.Location, Project);
2669 end if;
2670 end if;
2672 -- A virtual project extending an externally built project is itself
2673 -- externally built.
2675 if Project.Virtual and then Project.Extends /= No_Project then
2676 Project.Externally_Built := Project.Extends.Externally_Built;
2677 end if;
2679 if Current_Verbosity = High then
2680 Write_Str ("Project is ");
2682 if not Project.Externally_Built then
2683 Write_Str ("not ");
2684 end if;
2686 Write_Line ("externally built.");
2687 end if;
2688 end Check_If_Externally_Built;
2690 ----------------------
2691 -- Check_Interfaces --
2692 ----------------------
2694 procedure Check_Interfaces
2695 (Project : Project_Id;
2696 Data : in out Tree_Processing_Data)
2698 Interfaces : constant Prj.Variable_Value :=
2699 Prj.Util.Value_Of
2700 (Snames.Name_Interfaces,
2701 Project.Decl.Attributes,
2702 Data.Tree);
2704 Library_Interface : constant Prj.Variable_Value :=
2705 Prj.Util.Value_Of
2706 (Snames.Name_Library_Interface,
2707 Project.Decl.Attributes,
2708 Data.Tree);
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;
2718 begin
2719 if not Interfaces.Default then
2721 -- Set In_Interfaces to False for all sources. It will be set to True
2722 -- later for the sources in the Interfaces list.
2724 Project_2 := Project;
2725 while Project_2 /= No_Project loop
2726 Iter := For_Each_Source (Data.Tree, Project_2);
2727 loop
2728 Source := Prj.Element (Iter);
2729 exit when Source = No_Source;
2730 Source.In_Interfaces := False;
2731 Next (Iter);
2732 end loop;
2734 Project_2 := Project_2.Extends;
2735 end loop;
2737 List := Interfaces.Values;
2738 while List /= Nil_String loop
2739 Element := Data.Tree.String_Elements.Table (List);
2740 Name := Canonical_Case_File_Name (Element.Value);
2742 Project_2 := Project;
2743 Big_Loop :
2744 while Project_2 /= No_Project loop
2745 Iter := For_Each_Source (Data.Tree, Project_2);
2747 loop
2748 Source := Prj.Element (Iter);
2749 exit when Source = No_Source;
2751 if Source.File = Name then
2752 if not Source.Locally_Removed then
2753 Source.In_Interfaces := True;
2754 Source.Declared_In_Interfaces := True;
2756 Other := Other_Part (Source);
2758 if Other /= No_Source then
2759 Other.In_Interfaces := True;
2760 Other.Declared_In_Interfaces := True;
2761 end if;
2763 if Current_Verbosity = High then
2764 Write_Str (" interface: ");
2765 Write_Line (Get_Name_String (Source.Path.Name));
2766 end if;
2767 end if;
2769 exit Big_Loop;
2770 end if;
2772 Next (Iter);
2773 end loop;
2775 Project_2 := Project_2.Extends;
2776 end loop Big_Loop;
2778 if Source = No_Source then
2779 Error_Msg_File_1 := File_Name_Type (Element.Value);
2780 Error_Msg_Name_1 := Project.Name;
2782 Error_Msg
2783 (Data.Flags,
2784 "{ cannot be an interface of project %% "
2785 & "as it is not one of its sources",
2786 Element.Location, Project);
2787 end if;
2789 List := Element.Next;
2790 end loop;
2792 Project.Interfaces_Defined := True;
2794 elsif Project.Library and then not Library_Interface.Default then
2796 -- Set In_Interfaces to False for all sources. It will be set to True
2797 -- later for the sources in the Library_Interface list.
2799 Project_2 := Project;
2800 while Project_2 /= No_Project loop
2801 Iter := For_Each_Source (Data.Tree, Project_2);
2802 loop
2803 Source := Prj.Element (Iter);
2804 exit when Source = No_Source;
2805 Source.In_Interfaces := False;
2806 Next (Iter);
2807 end loop;
2809 Project_2 := Project_2.Extends;
2810 end loop;
2812 List := Library_Interface.Values;
2813 while List /= Nil_String loop
2814 Element := Data.Tree.String_Elements.Table (List);
2815 Get_Name_String (Element.Value);
2816 To_Lower (Name_Buffer (1 .. Name_Len));
2817 Name := Name_Find;
2819 Project_2 := Project;
2820 Big_Loop_2 :
2821 while Project_2 /= No_Project loop
2822 Iter := For_Each_Source (Data.Tree, Project_2);
2824 loop
2825 Source := Prj.Element (Iter);
2826 exit when Source = No_Source;
2828 if Source.Unit /= No_Unit_Index and then
2829 Source.Unit.Name = Name_Id (Name)
2830 then
2831 if not Source.Locally_Removed then
2832 Source.In_Interfaces := True;
2833 Source.Declared_In_Interfaces := True;
2835 Other := Other_Part (Source);
2837 if Other /= No_Source then
2838 Other.In_Interfaces := True;
2839 Other.Declared_In_Interfaces := True;
2840 end if;
2842 if Current_Verbosity = High then
2843 Write_Str (" interface: ");
2844 Write_Line (Get_Name_String (Source.Path.Name));
2845 end if;
2846 end if;
2848 exit Big_Loop_2;
2849 end if;
2851 Next (Iter);
2852 end loop;
2854 Project_2 := Project_2.Extends;
2855 end loop Big_Loop_2;
2857 List := Element.Next;
2858 end loop;
2860 Project.Interfaces_Defined := True;
2862 elsif Project.Extends /= No_Project
2863 and then Project.Extends.Interfaces_Defined
2864 then
2865 Project.Interfaces_Defined := True;
2867 Iter := For_Each_Source (Data.Tree, Project);
2868 loop
2869 Source := Prj.Element (Iter);
2870 exit when Source = No_Source;
2872 if not Source.Declared_In_Interfaces then
2873 Source.In_Interfaces := False;
2874 end if;
2876 Next (Iter);
2877 end loop;
2878 end if;
2879 end Check_Interfaces;
2881 --------------------------
2882 -- Check_Package_Naming --
2883 --------------------------
2885 procedure Check_Package_Naming
2886 (Project : Project_Id;
2887 Data : in out Tree_Processing_Data)
2889 Naming_Id : constant Package_Id :=
2890 Util.Value_Of
2891 (Name_Naming, Project.Decl.Packages, Data.Tree);
2892 Naming : Package_Element;
2894 Ada_Body_Suffix_Loc : Source_Ptr := No_Location;
2896 procedure Check_Naming;
2897 -- Check the validity of the Naming package (suffixes valid, ...)
2899 procedure Check_Common
2900 (Dot_Replacement : in out File_Name_Type;
2901 Casing : in out Casing_Type;
2902 Casing_Defined : out Boolean;
2903 Separate_Suffix : in out File_Name_Type;
2904 Sep_Suffix_Loc : out Source_Ptr);
2905 -- Check attributes common
2907 procedure Process_Exceptions_File_Based
2908 (Lang_Id : Language_Ptr;
2909 Kind : Source_Kind);
2910 procedure Process_Exceptions_Unit_Based
2911 (Lang_Id : Language_Ptr;
2912 Kind : Source_Kind);
2913 -- Process the naming exceptions for the two types of languages
2915 procedure Initialize_Naming_Data;
2916 -- Initialize internal naming data for the various languages
2918 ------------------
2919 -- Check_Common --
2920 ------------------
2922 procedure Check_Common
2923 (Dot_Replacement : in out File_Name_Type;
2924 Casing : in out Casing_Type;
2925 Casing_Defined : out Boolean;
2926 Separate_Suffix : in out File_Name_Type;
2927 Sep_Suffix_Loc : out Source_Ptr)
2929 Dot_Repl : constant Variable_Value :=
2930 Util.Value_Of
2931 (Name_Dot_Replacement,
2932 Naming.Decl.Attributes,
2933 Data.Tree);
2934 Casing_String : constant Variable_Value :=
2935 Util.Value_Of
2936 (Name_Casing,
2937 Naming.Decl.Attributes,
2938 Data.Tree);
2939 Sep_Suffix : constant Variable_Value :=
2940 Util.Value_Of
2941 (Name_Separate_Suffix,
2942 Naming.Decl.Attributes,
2943 Data.Tree);
2944 Dot_Repl_Loc : Source_Ptr;
2946 begin
2947 Sep_Suffix_Loc := No_Location;
2949 if not Dot_Repl.Default then
2950 pragma Assert
2951 (Dot_Repl.Kind = Single, "Dot_Replacement is not a string");
2953 if Length_Of_Name (Dot_Repl.Value) = 0 then
2954 Error_Msg
2955 (Data.Flags, "Dot_Replacement cannot be empty",
2956 Dot_Repl.Location, Project);
2957 end if;
2959 Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value);
2960 Dot_Repl_Loc := Dot_Repl.Location;
2962 declare
2963 Repl : constant String := Get_Name_String (Dot_Replacement);
2965 begin
2966 -- Dot_Replacement cannot
2967 -- - be empty
2968 -- - start or end with an alphanumeric
2969 -- - be a single '_'
2970 -- - start with an '_' followed by an alphanumeric
2971 -- - contain a '.' except if it is "."
2973 if Repl'Length = 0
2974 or else Is_Alphanumeric (Repl (Repl'First))
2975 or else Is_Alphanumeric (Repl (Repl'Last))
2976 or else (Repl (Repl'First) = '_'
2977 and then
2978 (Repl'Length = 1
2979 or else
2980 Is_Alphanumeric (Repl (Repl'First + 1))))
2981 or else (Repl'Length > 1
2982 and then
2983 Index (Source => Repl, Pattern => ".") /= 0)
2984 then
2985 Error_Msg
2986 (Data.Flags,
2987 '"' & Repl &
2988 """ is illegal for Dot_Replacement.",
2989 Dot_Repl_Loc, Project);
2990 end if;
2991 end;
2992 end if;
2994 if Dot_Replacement /= No_File then
2995 Write_Attr
2996 ("Dot_Replacement", Get_Name_String (Dot_Replacement));
2997 end if;
2999 Casing_Defined := False;
3001 if not Casing_String.Default then
3002 pragma Assert
3003 (Casing_String.Kind = Single, "Casing is not a string");
3005 declare
3006 Casing_Image : constant String :=
3007 Get_Name_String (Casing_String.Value);
3009 begin
3010 if Casing_Image'Length = 0 then
3011 Error_Msg
3012 (Data.Flags,
3013 "Casing cannot be an empty string",
3014 Casing_String.Location, Project);
3015 end if;
3017 Casing := Value (Casing_Image);
3018 Casing_Defined := True;
3020 exception
3021 when Constraint_Error =>
3022 Name_Len := Casing_Image'Length;
3023 Name_Buffer (1 .. Name_Len) := Casing_Image;
3024 Err_Vars.Error_Msg_Name_1 := Name_Find;
3025 Error_Msg
3026 (Data.Flags,
3027 "%% is not a correct Casing",
3028 Casing_String.Location, Project);
3029 end;
3030 end if;
3032 Write_Attr ("Casing", Image (Casing));
3034 if not Sep_Suffix.Default then
3035 if Length_Of_Name (Sep_Suffix.Value) = 0 then
3036 Error_Msg
3037 (Data.Flags,
3038 "Separate_Suffix cannot be empty",
3039 Sep_Suffix.Location, Project);
3041 else
3042 Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value);
3043 Sep_Suffix_Loc := Sep_Suffix.Location;
3045 Check_Illegal_Suffix
3046 (Project, Separate_Suffix,
3047 Dot_Replacement, "Separate_Suffix", Sep_Suffix.Location,
3048 Data);
3049 end if;
3050 end if;
3052 if Separate_Suffix /= No_File then
3053 Write_Attr
3054 ("Separate_Suffix", Get_Name_String (Separate_Suffix));
3055 end if;
3056 end Check_Common;
3058 -----------------------------------
3059 -- Process_Exceptions_File_Based --
3060 -----------------------------------
3062 procedure Process_Exceptions_File_Based
3063 (Lang_Id : Language_Ptr;
3064 Kind : Source_Kind)
3066 Lang : constant Name_Id := Lang_Id.Name;
3067 Exceptions : Array_Element_Id;
3068 Exception_List : Variable_Value;
3069 Element_Id : String_List_Id;
3070 Element : String_Element;
3071 File_Name : File_Name_Type;
3072 Source : Source_Id;
3074 begin
3075 case Kind is
3076 when Impl | Sep =>
3077 Exceptions :=
3078 Value_Of
3079 (Name_Implementation_Exceptions,
3080 In_Arrays => Naming.Decl.Arrays,
3081 In_Tree => Data.Tree);
3083 when Spec =>
3084 Exceptions :=
3085 Value_Of
3086 (Name_Specification_Exceptions,
3087 In_Arrays => Naming.Decl.Arrays,
3088 In_Tree => Data.Tree);
3089 end case;
3091 Exception_List :=
3092 Value_Of
3093 (Index => Lang,
3094 In_Array => Exceptions,
3095 In_Tree => Data.Tree);
3097 if Exception_List /= Nil_Variable_Value then
3098 Element_Id := Exception_List.Values;
3099 while Element_Id /= Nil_String loop
3100 Element := Data.Tree.String_Elements.Table (Element_Id);
3101 File_Name := Canonical_Case_File_Name (Element.Value);
3103 Source :=
3104 Source_Files_Htable.Get
3105 (Data.Tree.Source_Files_HT, File_Name);
3106 while Source /= No_Source
3107 and then Source.Project /= Project
3108 loop
3109 Source := Source.Next_With_File_Name;
3110 end loop;
3112 if Source = No_Source then
3113 Add_Source
3114 (Id => Source,
3115 Data => Data,
3116 Project => Project,
3117 Source_Dir_Rank => 0,
3118 Lang_Id => Lang_Id,
3119 Kind => Kind,
3120 File_Name => File_Name,
3121 Display_File => File_Name_Type (Element.Value),
3122 Naming_Exception => True,
3123 Location => Element.Location);
3125 else
3126 -- Check if the file name is already recorded for another
3127 -- language or another kind.
3129 if Source.Language /= Lang_Id then
3130 Error_Msg
3131 (Data.Flags,
3132 "the same file cannot be a source of two languages",
3133 Element.Location, Project);
3135 elsif Source.Kind /= Kind then
3136 Error_Msg
3137 (Data.Flags,
3138 "the same file cannot be a source and a template",
3139 Element.Location, Project);
3140 end if;
3142 -- If the file is already recorded for the same
3143 -- language and the same kind, it means that the file
3144 -- name appears several times in the *_Exceptions
3145 -- attribute; so there is nothing to do.
3146 end if;
3148 Element_Id := Element.Next;
3149 end loop;
3150 end if;
3151 end Process_Exceptions_File_Based;
3153 -----------------------------------
3154 -- Process_Exceptions_Unit_Based --
3155 -----------------------------------
3157 procedure Process_Exceptions_Unit_Based
3158 (Lang_Id : Language_Ptr;
3159 Kind : Source_Kind)
3161 Lang : constant Name_Id := Lang_Id.Name;
3162 Exceptions : Array_Element_Id;
3163 Element : Array_Element;
3164 Unit : Name_Id;
3165 Index : Int;
3166 File_Name : File_Name_Type;
3167 Source : Source_Id;
3169 begin
3170 case Kind is
3171 when Impl | Sep =>
3172 Exceptions :=
3173 Value_Of
3174 (Name_Body,
3175 In_Arrays => Naming.Decl.Arrays,
3176 In_Tree => Data.Tree);
3178 if Exceptions = No_Array_Element then
3179 Exceptions :=
3180 Value_Of
3181 (Name_Implementation,
3182 In_Arrays => Naming.Decl.Arrays,
3183 In_Tree => Data.Tree);
3184 end if;
3186 when Spec =>
3187 Exceptions :=
3188 Value_Of
3189 (Name_Spec,
3190 In_Arrays => Naming.Decl.Arrays,
3191 In_Tree => Data.Tree);
3193 if Exceptions = No_Array_Element then
3194 Exceptions :=
3195 Value_Of
3196 (Name_Spec,
3197 In_Arrays => Naming.Decl.Arrays,
3198 In_Tree => Data.Tree);
3199 end if;
3200 end case;
3202 while Exceptions /= No_Array_Element loop
3203 Element := Data.Tree.Array_Elements.Table (Exceptions);
3204 File_Name := Canonical_Case_File_Name (Element.Value.Value);
3206 Get_Name_String (Element.Index);
3207 To_Lower (Name_Buffer (1 .. Name_Len));
3208 Unit := Name_Find;
3209 Index := Element.Value.Index;
3211 -- For Ada, check if it is a valid unit name
3213 if Lang = Name_Ada then
3214 Get_Name_String (Element.Index);
3215 Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit);
3217 if Unit = No_Name then
3218 Err_Vars.Error_Msg_Name_1 := Element.Index;
3219 Error_Msg
3220 (Data.Flags,
3221 "%% is not a valid unit name.",
3222 Element.Value.Location, Project);
3223 end if;
3224 end if;
3226 if Unit /= No_Name then
3227 Add_Source
3228 (Id => Source,
3229 Data => Data,
3230 Project => Project,
3231 Source_Dir_Rank => 0,
3232 Lang_Id => Lang_Id,
3233 Kind => Kind,
3234 File_Name => File_Name,
3235 Display_File => File_Name_Type (Element.Value.Value),
3236 Unit => Unit,
3237 Index => Index,
3238 Location => Element.Value.Location,
3239 Naming_Exception => True);
3240 end if;
3242 Exceptions := Element.Next;
3243 end loop;
3244 end Process_Exceptions_Unit_Based;
3246 ------------------
3247 -- Check_Naming --
3248 ------------------
3250 procedure Check_Naming is
3251 Dot_Replacement : File_Name_Type :=
3252 File_Name_Type
3253 (First_Name_Id + Character'Pos ('-'));
3254 Separate_Suffix : File_Name_Type := No_File;
3255 Casing : Casing_Type := All_Lower_Case;
3256 Casing_Defined : Boolean;
3257 Lang_Id : Language_Ptr;
3258 Sep_Suffix_Loc : Source_Ptr;
3259 Suffix : Variable_Value;
3260 Lang : Name_Id;
3262 begin
3263 Check_Common
3264 (Dot_Replacement => Dot_Replacement,
3265 Casing => Casing,
3266 Casing_Defined => Casing_Defined,
3267 Separate_Suffix => Separate_Suffix,
3268 Sep_Suffix_Loc => Sep_Suffix_Loc);
3270 -- For all unit based languages, if any, set the specified value
3271 -- of Dot_Replacement, Casing and/or Separate_Suffix. Do not
3272 -- systematically overwrite, since the defaults come from the
3273 -- configuration file.
3275 if Dot_Replacement /= No_File
3276 or else Casing_Defined
3277 or else Separate_Suffix /= No_File
3278 then
3279 Lang_Id := Project.Languages;
3280 while Lang_Id /= No_Language_Index loop
3281 if Lang_Id.Config.Kind = Unit_Based then
3282 if Dot_Replacement /= No_File then
3283 Lang_Id.Config.Naming_Data.Dot_Replacement :=
3284 Dot_Replacement;
3285 end if;
3287 if Casing_Defined then
3288 Lang_Id.Config.Naming_Data.Casing := Casing;
3289 end if;
3290 end if;
3292 Lang_Id := Lang_Id.Next;
3293 end loop;
3294 end if;
3296 -- Next, get the spec and body suffixes
3298 Lang_Id := Project.Languages;
3299 while Lang_Id /= No_Language_Index loop
3300 Lang := Lang_Id.Name;
3302 -- Spec_Suffix
3304 Suffix := Value_Of
3305 (Name => Lang,
3306 Attribute_Or_Array_Name => Name_Spec_Suffix,
3307 In_Package => Naming_Id,
3308 In_Tree => Data.Tree);
3310 if Suffix = Nil_Variable_Value then
3311 Suffix := Value_Of
3312 (Name => Lang,
3313 Attribute_Or_Array_Name => Name_Specification_Suffix,
3314 In_Package => Naming_Id,
3315 In_Tree => Data.Tree);
3316 end if;
3318 if Suffix /= Nil_Variable_Value then
3319 Lang_Id.Config.Naming_Data.Spec_Suffix :=
3320 File_Name_Type (Suffix.Value);
3322 Check_Illegal_Suffix
3323 (Project,
3324 Lang_Id.Config.Naming_Data.Spec_Suffix,
3325 Lang_Id.Config.Naming_Data.Dot_Replacement,
3326 "Spec_Suffix", Suffix.Location, Data);
3328 Write_Attr
3329 ("Spec_Suffix",
3330 Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix));
3331 end if;
3333 -- Body_Suffix
3335 Suffix :=
3336 Value_Of
3337 (Name => Lang,
3338 Attribute_Or_Array_Name => Name_Body_Suffix,
3339 In_Package => Naming_Id,
3340 In_Tree => Data.Tree);
3342 if Suffix = Nil_Variable_Value then
3343 Suffix :=
3344 Value_Of
3345 (Name => Lang,
3346 Attribute_Or_Array_Name => Name_Implementation_Suffix,
3347 In_Package => Naming_Id,
3348 In_Tree => Data.Tree);
3349 end if;
3351 if Suffix /= Nil_Variable_Value then
3352 Lang_Id.Config.Naming_Data.Body_Suffix :=
3353 File_Name_Type (Suffix.Value);
3355 -- The default value of separate suffix should be the same as
3356 -- the body suffix, so we need to compute that first.
3358 if Separate_Suffix = No_File then
3359 Lang_Id.Config.Naming_Data.Separate_Suffix :=
3360 Lang_Id.Config.Naming_Data.Body_Suffix;
3361 Write_Attr
3362 ("Sep_Suffix",
3363 Get_Name_String
3364 (Lang_Id.Config.Naming_Data.Separate_Suffix));
3365 else
3366 Lang_Id.Config.Naming_Data.Separate_Suffix :=
3367 Separate_Suffix;
3368 end if;
3370 Check_Illegal_Suffix
3371 (Project,
3372 Lang_Id.Config.Naming_Data.Body_Suffix,
3373 Lang_Id.Config.Naming_Data.Dot_Replacement,
3374 "Body_Suffix", Suffix.Location, Data);
3376 Write_Attr
3377 ("Body_Suffix",
3378 Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix));
3380 elsif Separate_Suffix /= No_File then
3381 Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix;
3382 end if;
3384 -- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix,
3385 -- since that would cause a clear ambiguity. Note that we do allow
3386 -- a Spec_Suffix to have the same termination as one of these,
3387 -- which causes a potential ambiguity, but we resolve that by
3388 -- matching the longest possible suffix.
3390 if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File
3391 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
3392 Lang_Id.Config.Naming_Data.Body_Suffix
3393 then
3394 Error_Msg
3395 (Data.Flags,
3396 "Body_Suffix ("""
3397 & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)
3398 & """) cannot be the same as Spec_Suffix.",
3399 Ada_Body_Suffix_Loc, Project);
3400 end if;
3402 if Lang_Id.Config.Naming_Data.Body_Suffix /=
3403 Lang_Id.Config.Naming_Data.Separate_Suffix
3404 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
3405 Lang_Id.Config.Naming_Data.Separate_Suffix
3406 then
3407 Error_Msg
3408 (Data.Flags,
3409 "Separate_Suffix ("""
3410 & Get_Name_String
3411 (Lang_Id.Config.Naming_Data.Separate_Suffix)
3412 & """) cannot be the same as Spec_Suffix.",
3413 Sep_Suffix_Loc, Project);
3414 end if;
3416 Lang_Id := Lang_Id.Next;
3417 end loop;
3419 -- Get the naming exceptions for all languages
3421 for Kind in Spec_Or_Body loop
3422 Lang_Id := Project.Languages;
3423 while Lang_Id /= No_Language_Index loop
3424 case Lang_Id.Config.Kind is
3425 when File_Based =>
3426 Process_Exceptions_File_Based (Lang_Id, Kind);
3428 when Unit_Based =>
3429 Process_Exceptions_Unit_Based (Lang_Id, Kind);
3430 end case;
3432 Lang_Id := Lang_Id.Next;
3433 end loop;
3434 end loop;
3435 end Check_Naming;
3437 ----------------------------
3438 -- Initialize_Naming_Data --
3439 ----------------------------
3441 procedure Initialize_Naming_Data is
3442 Specs : Array_Element_Id :=
3443 Util.Value_Of
3444 (Name_Spec_Suffix,
3445 Naming.Decl.Arrays,
3446 Data.Tree);
3448 Impls : Array_Element_Id :=
3449 Util.Value_Of
3450 (Name_Body_Suffix,
3451 Naming.Decl.Arrays,
3452 Data.Tree);
3454 Lang : Language_Ptr;
3455 Lang_Name : Name_Id;
3456 Value : Variable_Value;
3457 Extended : Project_Id;
3459 begin
3460 -- At this stage, the project already contains the default extensions
3461 -- for the various languages. We now merge those suffixes read in the
3462 -- user project, and they override the default.
3464 while Specs /= No_Array_Element loop
3465 Lang_Name := Data.Tree.Array_Elements.Table (Specs).Index;
3466 Lang :=
3467 Get_Language_From_Name
3468 (Project, Name => Get_Name_String (Lang_Name));
3470 -- An extending project inherits its parent projects' languages
3471 -- so if needed we should create entries for those languages
3473 if Lang = null then
3474 Extended := Project.Extends;
3475 while Extended /= null loop
3476 Lang := Get_Language_From_Name
3477 (Extended, Name => Get_Name_String (Lang_Name));
3478 exit when Lang /= null;
3480 Extended := Extended.Extends;
3481 end loop;
3483 if Lang /= null then
3484 Lang := new Language_Data'(Lang.all);
3485 Lang.First_Source := null;
3486 Lang.Next := Project.Languages;
3487 Project.Languages := Lang;
3488 end if;
3489 end if;
3491 -- If language was not found in project or the projects it extends
3493 if Lang = null then
3494 if Current_Verbosity = High then
3495 Write_Line
3496 ("Ignoring spec naming data for "
3497 & Get_Name_String (Lang_Name)
3498 & " since language is not defined for this project");
3499 end if;
3501 else
3502 Value := Data.Tree.Array_Elements.Table (Specs).Value;
3504 if Value.Kind = Single then
3505 Lang.Config.Naming_Data.Spec_Suffix :=
3506 Canonical_Case_File_Name (Value.Value);
3507 end if;
3508 end if;
3510 Specs := Data.Tree.Array_Elements.Table (Specs).Next;
3511 end loop;
3513 while Impls /= No_Array_Element loop
3514 Lang_Name := Data.Tree.Array_Elements.Table (Impls).Index;
3515 Lang :=
3516 Get_Language_From_Name
3517 (Project, Name => Get_Name_String (Lang_Name));
3519 if Lang = null then
3520 if Current_Verbosity = High then
3521 Write_Line
3522 ("Ignoring impl naming data for "
3523 & Get_Name_String (Lang_Name)
3524 & " since language is not defined for this project");
3525 end if;
3526 else
3527 Value := Data.Tree.Array_Elements.Table (Impls).Value;
3529 if Lang.Name = Name_Ada then
3530 Ada_Body_Suffix_Loc := Value.Location;
3531 end if;
3533 if Value.Kind = Single then
3534 Lang.Config.Naming_Data.Body_Suffix :=
3535 Canonical_Case_File_Name (Value.Value);
3536 end if;
3537 end if;
3539 Impls := Data.Tree.Array_Elements.Table (Impls).Next;
3540 end loop;
3541 end Initialize_Naming_Data;
3543 -- Start of processing for Check_Naming_Schemes
3545 begin
3546 -- No Naming package or parsing a configuration file? nothing to do
3548 if Naming_Id /= No_Package
3549 and then Project.Qualifier /= Configuration
3550 then
3551 Naming := Data.Tree.Packages.Table (Naming_Id);
3553 if Current_Verbosity = High then
3554 Write_Line ("Checking package Naming for project "
3555 & Get_Name_String (Project.Name));
3556 end if;
3558 Initialize_Naming_Data;
3559 Check_Naming;
3560 end if;
3561 end Check_Package_Naming;
3563 ------------------------------
3564 -- Check_Library_Attributes --
3565 ------------------------------
3567 procedure Check_Library_Attributes
3568 (Project : Project_Id;
3569 Data : in out Tree_Processing_Data)
3571 Attributes : constant Prj.Variable_Id := Project.Decl.Attributes;
3573 Lib_Dir : constant Prj.Variable_Value :=
3574 Prj.Util.Value_Of
3575 (Snames.Name_Library_Dir, Attributes, Data.Tree);
3577 Lib_Name : constant Prj.Variable_Value :=
3578 Prj.Util.Value_Of
3579 (Snames.Name_Library_Name, Attributes, Data.Tree);
3581 Lib_Version : constant Prj.Variable_Value :=
3582 Prj.Util.Value_Of
3583 (Snames.Name_Library_Version, Attributes, Data.Tree);
3585 Lib_ALI_Dir : constant Prj.Variable_Value :=
3586 Prj.Util.Value_Of
3587 (Snames.Name_Library_Ali_Dir, Attributes, Data.Tree);
3589 Lib_GCC : constant Prj.Variable_Value :=
3590 Prj.Util.Value_Of
3591 (Snames.Name_Library_GCC, Attributes, Data.Tree);
3593 The_Lib_Kind : constant Prj.Variable_Value :=
3594 Prj.Util.Value_Of
3595 (Snames.Name_Library_Kind, Attributes, Data.Tree);
3597 Imported_Project_List : Project_List;
3599 Continuation : String_Access := No_Continuation_String'Access;
3601 Support_For_Libraries : Library_Support;
3603 Library_Directory_Present : Boolean;
3605 procedure Check_Library (Proj : Project_Id; Extends : Boolean);
3606 -- Check if an imported or extended project if also a library project
3608 -------------------
3609 -- Check_Library --
3610 -------------------
3612 procedure Check_Library (Proj : Project_Id; Extends : Boolean) is
3613 Src_Id : Source_Id;
3614 Iter : Source_Iterator;
3616 begin
3617 if Proj /= No_Project then
3618 if not Proj.Library then
3620 -- The only not library projects that are OK are those that
3621 -- have no sources. However, header files from non-Ada
3622 -- languages are OK, as there is nothing to compile.
3624 Iter := For_Each_Source (Data.Tree, Proj);
3625 loop
3626 Src_Id := Prj.Element (Iter);
3627 exit when Src_Id = No_Source
3628 or else Src_Id.Language.Config.Kind /= File_Based
3629 or else Src_Id.Kind /= Spec;
3630 Next (Iter);
3631 end loop;
3633 if Src_Id /= No_Source then
3634 Error_Msg_Name_1 := Project.Name;
3635 Error_Msg_Name_2 := Proj.Name;
3637 if Extends then
3638 if Project.Library_Kind /= Static then
3639 Error_Msg
3640 (Data.Flags,
3641 Continuation.all &
3642 "shared library project %% cannot extend " &
3643 "project %% that is not a library project",
3644 Project.Location, Project);
3645 Continuation := Continuation_String'Access;
3646 end if;
3648 elsif (not Unchecked_Shared_Lib_Imports)
3649 and then Project.Library_Kind /= Static
3650 then
3651 Error_Msg
3652 (Data.Flags,
3653 Continuation.all &
3654 "shared library project %% cannot import project %% " &
3655 "that is not a shared library project",
3656 Project.Location, Project);
3657 Continuation := Continuation_String'Access;
3658 end if;
3659 end if;
3661 elsif Project.Library_Kind /= Static and then
3662 Proj.Library_Kind = Static
3663 then
3664 Error_Msg_Name_1 := Project.Name;
3665 Error_Msg_Name_2 := Proj.Name;
3667 if Extends then
3668 Error_Msg
3669 (Data.Flags,
3670 Continuation.all &
3671 "shared library project %% cannot extend static " &
3672 "library project %%",
3673 Project.Location, Project);
3674 Continuation := Continuation_String'Access;
3676 elsif not Unchecked_Shared_Lib_Imports then
3677 Error_Msg
3678 (Data.Flags,
3679 Continuation.all &
3680 "shared library project %% cannot import static " &
3681 "library project %%",
3682 Project.Location, Project);
3683 Continuation := Continuation_String'Access;
3684 end if;
3686 end if;
3687 end if;
3688 end Check_Library;
3690 Dir_Exists : Boolean;
3692 -- Start of processing for Check_Library_Attributes
3694 begin
3695 Library_Directory_Present := Lib_Dir.Value /= Empty_String;
3697 -- Special case of extending project
3699 if Project.Extends /= No_Project then
3701 -- If the project extended is a library project, we inherit the
3702 -- library name, if it is not redefined; we check that the library
3703 -- directory is specified.
3705 if Project.Extends.Library then
3706 if Project.Qualifier = Standard then
3707 Error_Msg
3708 (Data.Flags,
3709 "a standard project cannot extend a library project",
3710 Project.Location, Project);
3712 else
3713 if Lib_Name.Default then
3714 Project.Library_Name := Project.Extends.Library_Name;
3715 end if;
3717 if Lib_Dir.Default then
3718 if not Project.Virtual then
3719 Error_Msg
3720 (Data.Flags,
3721 "a project extending a library project must " &
3722 "specify an attribute Library_Dir",
3723 Project.Location, Project);
3725 else
3726 -- For a virtual project extending a library project,
3727 -- inherit library directory.
3729 Project.Library_Dir := Project.Extends.Library_Dir;
3730 Library_Directory_Present := True;
3731 end if;
3732 end if;
3733 end if;
3734 end if;
3735 end if;
3737 pragma Assert (Lib_Name.Kind = Single);
3739 if Lib_Name.Value = Empty_String then
3740 if Current_Verbosity = High
3741 and then Project.Library_Name = No_Name
3742 then
3743 Write_Line ("No library name");
3744 end if;
3746 else
3747 -- There is no restriction on the syntax of library names
3749 Project.Library_Name := Lib_Name.Value;
3750 end if;
3752 if Project.Library_Name /= No_Name then
3753 if Current_Verbosity = High then
3754 Write_Attr
3755 ("Library name", Get_Name_String (Project.Library_Name));
3756 end if;
3758 pragma Assert (Lib_Dir.Kind = Single);
3760 if not Library_Directory_Present then
3761 if Current_Verbosity = High then
3762 Write_Line ("No library directory");
3763 end if;
3765 else
3766 -- Find path name (unless inherited), check that it is a directory
3768 if Project.Library_Dir = No_Path_Information then
3769 Locate_Directory
3770 (Project,
3771 File_Name_Type (Lib_Dir.Value),
3772 Path => Project.Library_Dir,
3773 Dir_Exists => Dir_Exists,
3774 Data => Data,
3775 Create => "library",
3776 Must_Exist => False,
3777 Location => Lib_Dir.Location,
3778 Externally_Built => Project.Externally_Built);
3780 else
3781 Dir_Exists :=
3782 Is_Directory
3783 (Get_Name_String
3784 (Project.Library_Dir.Display_Name));
3785 end if;
3787 if not Dir_Exists then
3789 -- Get the absolute name of the library directory that
3790 -- does not exist, to report an error.
3792 Err_Vars.Error_Msg_File_1 :=
3793 File_Name_Type (Project.Library_Dir.Display_Name);
3794 Error_Msg
3795 (Data.Flags,
3796 "library directory { does not exist",
3797 Lib_Dir.Location, Project);
3799 elsif not Project.Externally_Built then
3801 -- The library directory cannot be the same as the Object
3802 -- directory.
3804 if Project.Library_Dir.Name = Project.Object_Directory.Name then
3805 Error_Msg
3806 (Data.Flags,
3807 "library directory cannot be the same " &
3808 "as object directory",
3809 Lib_Dir.Location, Project);
3810 Project.Library_Dir := No_Path_Information;
3812 else
3813 declare
3814 OK : Boolean := True;
3815 Dirs_Id : String_List_Id;
3816 Dir_Elem : String_Element;
3817 Pid : Project_List;
3819 begin
3820 -- The library directory cannot be the same as a source
3821 -- directory of the current project.
3823 Dirs_Id := Project.Source_Dirs;
3824 while Dirs_Id /= Nil_String loop
3825 Dir_Elem := Data.Tree.String_Elements.Table (Dirs_Id);
3826 Dirs_Id := Dir_Elem.Next;
3828 if Project.Library_Dir.Name =
3829 Path_Name_Type (Dir_Elem.Value)
3830 then
3831 Err_Vars.Error_Msg_File_1 :=
3832 File_Name_Type (Dir_Elem.Value);
3833 Error_Msg
3834 (Data.Flags,
3835 "library directory cannot be the same " &
3836 "as source directory {",
3837 Lib_Dir.Location, Project);
3838 OK := False;
3839 exit;
3840 end if;
3841 end loop;
3843 if OK then
3845 -- The library directory cannot be the same as a
3846 -- source directory of another project either.
3848 Pid := Data.Tree.Projects;
3849 Project_Loop : loop
3850 exit Project_Loop when Pid = null;
3852 if Pid.Project /= Project then
3853 Dirs_Id := Pid.Project.Source_Dirs;
3855 Dir_Loop : while Dirs_Id /= Nil_String loop
3856 Dir_Elem :=
3857 Data.Tree.String_Elements.Table (Dirs_Id);
3858 Dirs_Id := Dir_Elem.Next;
3860 if Project.Library_Dir.Name =
3861 Path_Name_Type (Dir_Elem.Value)
3862 then
3863 Err_Vars.Error_Msg_File_1 :=
3864 File_Name_Type (Dir_Elem.Value);
3865 Err_Vars.Error_Msg_Name_1 :=
3866 Pid.Project.Name;
3868 Error_Msg
3869 (Data.Flags,
3870 "library directory cannot be the same" &
3871 " as source directory { of project %%",
3872 Lib_Dir.Location, Project);
3873 OK := False;
3874 exit Project_Loop;
3875 end if;
3876 end loop Dir_Loop;
3877 end if;
3879 Pid := Pid.Next;
3880 end loop Project_Loop;
3881 end if;
3883 if not OK then
3884 Project.Library_Dir := No_Path_Information;
3886 elsif Current_Verbosity = High then
3888 -- Display the Library directory in high verbosity
3890 Write_Attr
3891 ("Library directory",
3892 Get_Name_String (Project.Library_Dir.Display_Name));
3893 end if;
3894 end;
3895 end if;
3896 end if;
3897 end if;
3899 end if;
3901 Project.Library :=
3902 Project.Library_Dir /= No_Path_Information
3903 and then Project.Library_Name /= No_Name;
3905 if Project.Extends = No_Project then
3906 case Project.Qualifier is
3907 when Standard =>
3908 if Project.Library then
3909 Error_Msg
3910 (Data.Flags,
3911 "a standard project cannot be a library project",
3912 Lib_Name.Location, Project);
3913 end if;
3915 when Library =>
3916 if not Project.Library then
3917 if Project.Library_Dir = No_Path_Information then
3918 Error_Msg
3919 (Data.Flags,
3920 "\attribute Library_Dir not declared",
3921 Project.Location, Project);
3922 end if;
3924 if Project.Library_Name = No_Name then
3925 Error_Msg
3926 (Data.Flags,
3927 "\attribute Library_Name not declared",
3928 Project.Location, Project);
3929 end if;
3930 end if;
3932 when others =>
3933 null;
3935 end case;
3936 end if;
3938 if Project.Library then
3939 Support_For_Libraries := Project.Config.Lib_Support;
3941 if Support_For_Libraries = Prj.None then
3942 Error_Msg
3943 (Data.Flags,
3944 "?libraries are not supported on this platform",
3945 Lib_Name.Location, Project);
3946 Project.Library := False;
3948 else
3949 if Lib_ALI_Dir.Value = Empty_String then
3950 if Current_Verbosity = High then
3951 Write_Line ("No library ALI directory specified");
3952 end if;
3954 Project.Library_ALI_Dir := Project.Library_Dir;
3956 else
3957 -- Find path name, check that it is a directory
3959 Locate_Directory
3960 (Project,
3961 File_Name_Type (Lib_ALI_Dir.Value),
3962 Path => Project.Library_ALI_Dir,
3963 Create => "library ALI",
3964 Dir_Exists => Dir_Exists,
3965 Data => Data,
3966 Must_Exist => False,
3967 Location => Lib_ALI_Dir.Location,
3968 Externally_Built => Project.Externally_Built);
3970 if not Dir_Exists then
3972 -- Get the absolute name of the library ALI directory that
3973 -- does not exist, to report an error.
3975 Err_Vars.Error_Msg_File_1 :=
3976 File_Name_Type (Project.Library_ALI_Dir.Display_Name);
3977 Error_Msg
3978 (Data.Flags,
3979 "library 'A'L'I directory { does not exist",
3980 Lib_ALI_Dir.Location, Project);
3981 end if;
3983 if (not Project.Externally_Built) and then
3984 Project.Library_ALI_Dir /= Project.Library_Dir
3985 then
3986 -- The library ALI directory cannot be the same as the
3987 -- Object directory.
3989 if Project.Library_ALI_Dir = Project.Object_Directory then
3990 Error_Msg
3991 (Data.Flags,
3992 "library 'A'L'I directory cannot be the same " &
3993 "as object directory",
3994 Lib_ALI_Dir.Location, Project);
3995 Project.Library_ALI_Dir := No_Path_Information;
3997 else
3998 declare
3999 OK : Boolean := True;
4000 Dirs_Id : String_List_Id;
4001 Dir_Elem : String_Element;
4002 Pid : Project_List;
4004 begin
4005 -- The library ALI directory cannot be the same as
4006 -- a source directory of the current project.
4008 Dirs_Id := Project.Source_Dirs;
4009 while Dirs_Id /= Nil_String loop
4010 Dir_Elem :=
4011 Data.Tree.String_Elements.Table (Dirs_Id);
4012 Dirs_Id := Dir_Elem.Next;
4014 if Project.Library_ALI_Dir.Name =
4015 Path_Name_Type (Dir_Elem.Value)
4016 then
4017 Err_Vars.Error_Msg_File_1 :=
4018 File_Name_Type (Dir_Elem.Value);
4019 Error_Msg
4020 (Data.Flags,
4021 "library 'A'L'I directory cannot be " &
4022 "the same as source directory {",
4023 Lib_ALI_Dir.Location, Project);
4024 OK := False;
4025 exit;
4026 end if;
4027 end loop;
4029 if OK then
4031 -- The library ALI directory cannot be the same as
4032 -- a source directory of another project either.
4034 Pid := Data.Tree.Projects;
4035 ALI_Project_Loop : loop
4036 exit ALI_Project_Loop when Pid = null;
4038 if Pid.Project /= Project then
4039 Dirs_Id := Pid.Project.Source_Dirs;
4041 ALI_Dir_Loop :
4042 while Dirs_Id /= Nil_String loop
4043 Dir_Elem :=
4044 Data.Tree.String_Elements.Table
4045 (Dirs_Id);
4046 Dirs_Id := Dir_Elem.Next;
4048 if Project.Library_ALI_Dir.Name =
4049 Path_Name_Type (Dir_Elem.Value)
4050 then
4051 Err_Vars.Error_Msg_File_1 :=
4052 File_Name_Type (Dir_Elem.Value);
4053 Err_Vars.Error_Msg_Name_1 :=
4054 Pid.Project.Name;
4056 Error_Msg
4057 (Data.Flags,
4058 "library 'A'L'I directory cannot " &
4059 "be the same as source directory " &
4060 "{ of project %%",
4061 Lib_ALI_Dir.Location, Project);
4062 OK := False;
4063 exit ALI_Project_Loop;
4064 end if;
4065 end loop ALI_Dir_Loop;
4066 end if;
4067 Pid := Pid.Next;
4068 end loop ALI_Project_Loop;
4069 end if;
4071 if not OK then
4072 Project.Library_ALI_Dir := No_Path_Information;
4074 elsif Current_Verbosity = High then
4076 -- Display Library ALI directory in high verbosity
4078 Write_Attr
4079 ("Library ALI dir",
4080 Get_Name_String
4081 (Project.Library_ALI_Dir.Display_Name));
4082 end if;
4083 end;
4084 end if;
4085 end if;
4086 end if;
4088 pragma Assert (Lib_Version.Kind = Single);
4090 if Lib_Version.Value = Empty_String then
4091 if Current_Verbosity = High then
4092 Write_Line ("No library version specified");
4093 end if;
4095 else
4096 Project.Lib_Internal_Name := Lib_Version.Value;
4097 end if;
4099 pragma Assert (The_Lib_Kind.Kind = Single);
4101 if The_Lib_Kind.Value = Empty_String then
4102 if Current_Verbosity = High then
4103 Write_Line ("No library kind specified");
4104 end if;
4106 else
4107 Get_Name_String (The_Lib_Kind.Value);
4109 declare
4110 Kind_Name : constant String :=
4111 To_Lower (Name_Buffer (1 .. Name_Len));
4113 OK : Boolean := True;
4115 begin
4116 if Kind_Name = "static" then
4117 Project.Library_Kind := Static;
4119 elsif Kind_Name = "dynamic" then
4120 Project.Library_Kind := Dynamic;
4122 elsif Kind_Name = "relocatable" then
4123 Project.Library_Kind := Relocatable;
4125 else
4126 Error_Msg
4127 (Data.Flags,
4128 "illegal value for Library_Kind",
4129 The_Lib_Kind.Location, Project);
4130 OK := False;
4131 end if;
4133 if Current_Verbosity = High and then OK then
4134 Write_Attr ("Library kind", Kind_Name);
4135 end if;
4137 if Project.Library_Kind /= Static then
4138 if Support_For_Libraries = Prj.Static_Only then
4139 Error_Msg
4140 (Data.Flags,
4141 "only static libraries are supported " &
4142 "on this platform",
4143 The_Lib_Kind.Location, Project);
4144 Project.Library := False;
4146 else
4147 -- Check if (obsolescent) attribute Library_GCC or
4148 -- Linker'Driver is declared.
4150 if Lib_GCC.Value /= Empty_String then
4151 Error_Msg
4152 (Data.Flags,
4153 "?Library_'G'C'C is an obsolescent attribute, " &
4154 "use Linker''Driver instead",
4155 Lib_GCC.Location, Project);
4156 Project.Config.Shared_Lib_Driver :=
4157 File_Name_Type (Lib_GCC.Value);
4159 else
4160 declare
4161 Linker : constant Package_Id :=
4162 Value_Of
4163 (Name_Linker,
4164 Project.Decl.Packages,
4165 Data.Tree);
4166 Driver : constant Variable_Value :=
4167 Value_Of
4168 (Name => No_Name,
4169 Attribute_Or_Array_Name =>
4170 Name_Driver,
4171 In_Package => Linker,
4172 In_Tree => Data.Tree);
4174 begin
4175 if Driver /= Nil_Variable_Value
4176 and then Driver.Value /= Empty_String
4177 then
4178 Project.Config.Shared_Lib_Driver :=
4179 File_Name_Type (Driver.Value);
4180 end if;
4181 end;
4182 end if;
4183 end if;
4184 end if;
4185 end;
4186 end if;
4188 if Project.Library then
4189 if Current_Verbosity = High then
4190 Write_Line ("This is a library project file");
4191 end if;
4193 Check_Library (Project.Extends, Extends => True);
4195 Imported_Project_List := Project.Imported_Projects;
4196 while Imported_Project_List /= null loop
4197 Check_Library
4198 (Imported_Project_List.Project,
4199 Extends => False);
4200 Imported_Project_List := Imported_Project_List.Next;
4201 end loop;
4202 end if;
4204 end if;
4205 end if;
4207 -- Check if Linker'Switches or Linker'Default_Switches are declared.
4208 -- Warn if they are declared, as it is a common error to think that
4209 -- library are "linked" with Linker switches.
4211 if Project.Library then
4212 declare
4213 Linker_Package_Id : constant Package_Id :=
4214 Util.Value_Of
4215 (Name_Linker,
4216 Project.Decl.Packages, Data.Tree);
4217 Linker_Package : Package_Element;
4218 Switches : Array_Element_Id := No_Array_Element;
4220 begin
4221 if Linker_Package_Id /= No_Package then
4222 Linker_Package := Data.Tree.Packages.Table (Linker_Package_Id);
4224 Switches :=
4225 Value_Of
4226 (Name => Name_Switches,
4227 In_Arrays => Linker_Package.Decl.Arrays,
4228 In_Tree => Data.Tree);
4230 if Switches = No_Array_Element then
4231 Switches :=
4232 Value_Of
4233 (Name => Name_Default_Switches,
4234 In_Arrays => Linker_Package.Decl.Arrays,
4235 In_Tree => Data.Tree);
4236 end if;
4238 if Switches /= No_Array_Element then
4239 Error_Msg
4240 (Data.Flags,
4241 "?Linker switches not taken into account in library " &
4242 "projects",
4243 No_Location, Project);
4244 end if;
4245 end if;
4246 end;
4247 end if;
4249 if Project.Extends /= No_Project and then Project.Extends.Library then
4251 -- Remove the library name from Lib_Data_Table
4253 for J in 1 .. Lib_Data_Table.Last loop
4254 if Lib_Data_Table.Table (J).Proj = Project.Extends then
4255 Lib_Data_Table.Table (J) :=
4256 Lib_Data_Table.Table (Lib_Data_Table.Last);
4257 Lib_Data_Table.Set_Last (Lib_Data_Table.Last - 1);
4258 exit;
4259 end if;
4260 end loop;
4262 Project.Extends.Library := False;
4263 end if;
4265 if Project.Library and then not Lib_Name.Default then
4267 -- Check if the same library name is used in an other library project
4269 for J in 1 .. Lib_Data_Table.Last loop
4270 if Lib_Data_Table.Table (J).Name = Project.Library_Name then
4271 Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name;
4272 Error_Msg
4273 (Data.Flags,
4274 "Library name cannot be the same as in project %%",
4275 Lib_Name.Location, Project);
4276 Project.Library := False;
4277 exit;
4278 end if;
4279 end loop;
4280 end if;
4282 if Project.Library then
4284 -- Record the library name
4286 Lib_Data_Table.Append
4287 ((Name => Project.Library_Name, Proj => Project));
4288 end if;
4289 end Check_Library_Attributes;
4291 ---------------------------------
4292 -- Check_Programming_Languages --
4293 ---------------------------------
4295 procedure Check_Programming_Languages
4296 (Project : Project_Id;
4297 Data : in out Tree_Processing_Data)
4299 Languages : Variable_Value := Nil_Variable_Value;
4300 Def_Lang : Variable_Value := Nil_Variable_Value;
4301 Def_Lang_Id : Name_Id;
4303 procedure Add_Language (Name, Display_Name : Name_Id);
4304 -- Add a new language to the list of languages for the project.
4305 -- Nothing is done if the language has already been defined
4307 ------------------
4308 -- Add_Language --
4309 ------------------
4311 procedure Add_Language (Name, Display_Name : Name_Id) is
4312 Lang : Language_Ptr;
4314 begin
4315 Lang := Project.Languages;
4316 while Lang /= No_Language_Index loop
4317 if Name = Lang.Name then
4318 return;
4319 end if;
4321 Lang := Lang.Next;
4322 end loop;
4324 Lang := new Language_Data'(No_Language_Data);
4325 Lang.Next := Project.Languages;
4326 Project.Languages := Lang;
4327 Lang.Name := Name;
4328 Lang.Display_Name := Display_Name;
4330 if Name = Name_Ada then
4331 Lang.Config.Kind := Unit_Based;
4332 Lang.Config.Dependency_Kind := ALI_File;
4333 else
4334 Lang.Config.Kind := File_Based;
4335 end if;
4336 end Add_Language;
4338 -- Start of processing for Check_Programming_Languages
4340 begin
4341 Project.Languages := null;
4342 Languages :=
4343 Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, Data.Tree);
4344 Def_Lang :=
4345 Prj.Util.Value_Of
4346 (Name_Default_Language, Project.Decl.Attributes, Data.Tree);
4348 if Project.Source_Dirs /= Nil_String then
4350 -- Check if languages are specified in this project
4352 if Languages.Default then
4354 -- Fail if there is no default language defined
4356 if Def_Lang.Default then
4357 Error_Msg
4358 (Data.Flags,
4359 "no languages defined for this project",
4360 Project.Location, Project);
4361 Def_Lang_Id := No_Name;
4363 else
4364 Get_Name_String (Def_Lang.Value);
4365 To_Lower (Name_Buffer (1 .. Name_Len));
4366 Def_Lang_Id := Name_Find;
4367 end if;
4369 if Def_Lang_Id /= No_Name then
4370 Get_Name_String (Def_Lang_Id);
4371 Name_Buffer (1) := GNAT.Case_Util.To_Upper (Name_Buffer (1));
4372 Add_Language
4373 (Name => Def_Lang_Id,
4374 Display_Name => Name_Find);
4375 end if;
4377 else
4378 declare
4379 Current : String_List_Id := Languages.Values;
4380 Element : String_Element;
4382 begin
4383 -- If there are no languages declared, there are no sources
4385 if Current = Nil_String then
4386 Project.Source_Dirs := Nil_String;
4388 if Project.Qualifier = Standard then
4389 Error_Msg
4390 (Data.Flags,
4391 "a standard project must have at least one language",
4392 Languages.Location, Project);
4393 end if;
4395 else
4396 -- Look through all the languages specified in attribute
4397 -- Languages.
4399 while Current /= Nil_String loop
4400 Element := Data.Tree.String_Elements.Table (Current);
4401 Get_Name_String (Element.Value);
4402 To_Lower (Name_Buffer (1 .. Name_Len));
4404 Add_Language
4405 (Name => Name_Find,
4406 Display_Name => Element.Value);
4408 Current := Element.Next;
4409 end loop;
4410 end if;
4411 end;
4412 end if;
4413 end if;
4414 end Check_Programming_Languages;
4416 -------------------------------
4417 -- Check_Stand_Alone_Library --
4418 -------------------------------
4420 procedure Check_Stand_Alone_Library
4421 (Project : Project_Id;
4422 Data : in out Tree_Processing_Data)
4424 Lib_Interfaces : constant Prj.Variable_Value :=
4425 Prj.Util.Value_Of
4426 (Snames.Name_Library_Interface,
4427 Project.Decl.Attributes,
4428 Data.Tree);
4430 Lib_Auto_Init : constant Prj.Variable_Value :=
4431 Prj.Util.Value_Of
4432 (Snames.Name_Library_Auto_Init,
4433 Project.Decl.Attributes,
4434 Data.Tree);
4436 Lib_Src_Dir : constant Prj.Variable_Value :=
4437 Prj.Util.Value_Of
4438 (Snames.Name_Library_Src_Dir,
4439 Project.Decl.Attributes,
4440 Data.Tree);
4442 Lib_Symbol_File : constant Prj.Variable_Value :=
4443 Prj.Util.Value_Of
4444 (Snames.Name_Library_Symbol_File,
4445 Project.Decl.Attributes,
4446 Data.Tree);
4448 Lib_Symbol_Policy : constant Prj.Variable_Value :=
4449 Prj.Util.Value_Of
4450 (Snames.Name_Library_Symbol_Policy,
4451 Project.Decl.Attributes,
4452 Data.Tree);
4454 Lib_Ref_Symbol_File : constant Prj.Variable_Value :=
4455 Prj.Util.Value_Of
4456 (Snames.Name_Library_Reference_Symbol_File,
4457 Project.Decl.Attributes,
4458 Data.Tree);
4460 Auto_Init_Supported : Boolean;
4461 OK : Boolean := True;
4462 Source : Source_Id;
4463 Next_Proj : Project_Id;
4464 Iter : Source_Iterator;
4466 begin
4467 Auto_Init_Supported := Project.Config.Auto_Init_Supported;
4469 pragma Assert (Lib_Interfaces.Kind = List);
4471 -- It is a stand-alone library project file if attribute
4472 -- Library_Interface is defined.
4474 if not Lib_Interfaces.Default then
4475 declare
4476 Interfaces : String_List_Id := Lib_Interfaces.Values;
4477 Interface_ALIs : String_List_Id := Nil_String;
4478 Unit : Name_Id;
4480 begin
4481 Project.Standalone_Library := True;
4483 -- Library_Interface cannot be an empty list
4485 if Interfaces = Nil_String then
4486 Error_Msg
4487 (Data.Flags,
4488 "Library_Interface cannot be an empty list",
4489 Lib_Interfaces.Location, Project);
4490 end if;
4492 -- Process each unit name specified in the attribute
4493 -- Library_Interface.
4495 while Interfaces /= Nil_String loop
4496 Get_Name_String
4497 (Data.Tree.String_Elements.Table (Interfaces).Value);
4498 To_Lower (Name_Buffer (1 .. Name_Len));
4500 if Name_Len = 0 then
4501 Error_Msg
4502 (Data.Flags,
4503 "an interface cannot be an empty string",
4504 Data.Tree.String_Elements.Table (Interfaces).Location,
4505 Project);
4507 else
4508 Unit := Name_Find;
4509 Error_Msg_Name_1 := Unit;
4511 Next_Proj := Project.Extends;
4512 Iter := For_Each_Source (Data.Tree, Project);
4513 loop
4514 while Prj.Element (Iter) /= No_Source
4515 and then
4516 (Prj.Element (Iter).Unit = null
4517 or else Prj.Element (Iter).Unit.Name /= Unit)
4518 loop
4519 Next (Iter);
4520 end loop;
4522 Source := Prj.Element (Iter);
4523 exit when Source /= No_Source
4524 or else Next_Proj = No_Project;
4526 Iter := For_Each_Source (Data.Tree, Next_Proj);
4527 Next_Proj := Next_Proj.Extends;
4528 end loop;
4530 if Source /= No_Source then
4531 if Source.Kind = Sep then
4532 Source := No_Source;
4534 elsif Source.Kind = Spec
4535 and then Other_Part (Source) /= No_Source
4536 then
4537 Source := Other_Part (Source);
4538 end if;
4539 end if;
4541 if Source /= No_Source then
4542 if Source.Project /= Project
4543 and then not Is_Extending (Project, Source.Project)
4544 then
4545 Source := No_Source;
4546 end if;
4547 end if;
4549 if Source = No_Source then
4550 Error_Msg
4551 (Data.Flags,
4552 "%% is not a unit of this project",
4553 Data.Tree.String_Elements.Table
4554 (Interfaces).Location, Project);
4556 else
4557 if Source.Kind = Spec
4558 and then Other_Part (Source) /= No_Source
4559 then
4560 Source := Other_Part (Source);
4561 end if;
4563 String_Element_Table.Increment_Last
4564 (Data.Tree.String_Elements);
4566 Data.Tree.String_Elements.Table
4567 (String_Element_Table.Last
4568 (Data.Tree.String_Elements)) :=
4569 (Value => Name_Id (Source.Dep_Name),
4570 Index => 0,
4571 Display_Value => Name_Id (Source.Dep_Name),
4572 Location =>
4573 Data.Tree.String_Elements.Table
4574 (Interfaces).Location,
4575 Flag => False,
4576 Next => Interface_ALIs);
4578 Interface_ALIs :=
4579 String_Element_Table.Last
4580 (Data.Tree.String_Elements);
4581 end if;
4582 end if;
4584 Interfaces := Data.Tree.String_Elements.Table (Interfaces).Next;
4585 end loop;
4587 -- Put the list of Interface ALIs in the project data
4589 Project.Lib_Interface_ALIs := Interface_ALIs;
4591 -- Check value of attribute Library_Auto_Init and set
4592 -- Lib_Auto_Init accordingly.
4594 if Lib_Auto_Init.Default then
4596 -- If no attribute Library_Auto_Init is declared, then set auto
4597 -- init only if it is supported.
4599 Project.Lib_Auto_Init := Auto_Init_Supported;
4601 else
4602 Get_Name_String (Lib_Auto_Init.Value);
4603 To_Lower (Name_Buffer (1 .. Name_Len));
4605 if Name_Buffer (1 .. Name_Len) = "false" then
4606 Project.Lib_Auto_Init := False;
4608 elsif Name_Buffer (1 .. Name_Len) = "true" then
4609 if Auto_Init_Supported then
4610 Project.Lib_Auto_Init := True;
4612 else
4613 -- Library_Auto_Init cannot be "true" if auto init is not
4614 -- supported.
4616 Error_Msg
4617 (Data.Flags,
4618 "library auto init not supported " &
4619 "on this platform",
4620 Lib_Auto_Init.Location, Project);
4621 end if;
4623 else
4624 Error_Msg
4625 (Data.Flags,
4626 "invalid value for attribute Library_Auto_Init",
4627 Lib_Auto_Init.Location, Project);
4628 end if;
4629 end if;
4630 end;
4632 -- If attribute Library_Src_Dir is defined and not the empty string,
4633 -- check if the directory exist and is not the object directory or
4634 -- one of the source directories. This is the directory where copies
4635 -- of the interface sources will be copied. Note that this directory
4636 -- may be the library directory.
4638 if Lib_Src_Dir.Value /= Empty_String then
4639 declare
4640 Dir_Id : constant File_Name_Type :=
4641 File_Name_Type (Lib_Src_Dir.Value);
4642 Dir_Exists : Boolean;
4644 begin
4645 Locate_Directory
4646 (Project,
4647 Dir_Id,
4648 Path => Project.Library_Src_Dir,
4649 Dir_Exists => Dir_Exists,
4650 Data => Data,
4651 Must_Exist => False,
4652 Create => "library source copy",
4653 Location => Lib_Src_Dir.Location,
4654 Externally_Built => Project.Externally_Built);
4656 -- If directory does not exist, report an error
4658 if not Dir_Exists then
4660 -- Get the absolute name of the library directory that does
4661 -- not exist, to report an error.
4663 Err_Vars.Error_Msg_File_1 :=
4664 File_Name_Type (Project.Library_Src_Dir.Display_Name);
4665 Error_Msg
4666 (Data.Flags,
4667 "Directory { does not exist",
4668 Lib_Src_Dir.Location, Project);
4670 -- Report error if it is the same as the object directory
4672 elsif Project.Library_Src_Dir = Project.Object_Directory then
4673 Error_Msg
4674 (Data.Flags,
4675 "directory to copy interfaces cannot be " &
4676 "the object directory",
4677 Lib_Src_Dir.Location, Project);
4678 Project.Library_Src_Dir := No_Path_Information;
4680 else
4681 declare
4682 Src_Dirs : String_List_Id;
4683 Src_Dir : String_Element;
4684 Pid : Project_List;
4686 begin
4687 -- Interface copy directory cannot be one of the source
4688 -- directory of the current project.
4690 Src_Dirs := Project.Source_Dirs;
4691 while Src_Dirs /= Nil_String loop
4692 Src_Dir := Data.Tree.String_Elements.Table (Src_Dirs);
4694 -- Report error if it is one of the source directories
4696 if Project.Library_Src_Dir.Name =
4697 Path_Name_Type (Src_Dir.Value)
4698 then
4699 Error_Msg
4700 (Data.Flags,
4701 "directory to copy interfaces cannot " &
4702 "be one of the source directories",
4703 Lib_Src_Dir.Location, Project);
4704 Project.Library_Src_Dir := No_Path_Information;
4705 exit;
4706 end if;
4708 Src_Dirs := Src_Dir.Next;
4709 end loop;
4711 if Project.Library_Src_Dir /= No_Path_Information then
4713 -- It cannot be a source directory of any other
4714 -- project either.
4716 Pid := Data.Tree.Projects;
4717 Project_Loop : loop
4718 exit Project_Loop when Pid = null;
4720 Src_Dirs := Pid.Project.Source_Dirs;
4721 Dir_Loop : while Src_Dirs /= Nil_String loop
4722 Src_Dir :=
4723 Data.Tree.String_Elements.Table (Src_Dirs);
4725 -- Report error if it is one of the source
4726 -- directories.
4728 if Project.Library_Src_Dir.Name =
4729 Path_Name_Type (Src_Dir.Value)
4730 then
4731 Error_Msg_File_1 :=
4732 File_Name_Type (Src_Dir.Value);
4733 Error_Msg_Name_1 := Pid.Project.Name;
4734 Error_Msg
4735 (Data.Flags,
4736 "directory to copy interfaces cannot " &
4737 "be the same as source directory { of " &
4738 "project %%",
4739 Lib_Src_Dir.Location, Project);
4740 Project.Library_Src_Dir :=
4741 No_Path_Information;
4742 exit Project_Loop;
4743 end if;
4745 Src_Dirs := Src_Dir.Next;
4746 end loop Dir_Loop;
4748 Pid := Pid.Next;
4749 end loop Project_Loop;
4750 end if;
4751 end;
4753 -- In high verbosity, if there is a valid Library_Src_Dir,
4754 -- display its path name.
4756 if Project.Library_Src_Dir /= No_Path_Information
4757 and then Current_Verbosity = High
4758 then
4759 Write_Attr
4760 ("Directory to copy interfaces",
4761 Get_Name_String (Project.Library_Src_Dir.Name));
4762 end if;
4763 end if;
4764 end;
4765 end if;
4767 -- Check the symbol related attributes
4769 -- First, the symbol policy
4771 if not Lib_Symbol_Policy.Default then
4772 declare
4773 Value : constant String :=
4774 To_Lower
4775 (Get_Name_String (Lib_Symbol_Policy.Value));
4777 begin
4778 -- Symbol policy must hove one of a limited number of values
4780 if Value = "autonomous" or else Value = "default" then
4781 Project.Symbol_Data.Symbol_Policy := Autonomous;
4783 elsif Value = "compliant" then
4784 Project.Symbol_Data.Symbol_Policy := Compliant;
4786 elsif Value = "controlled" then
4787 Project.Symbol_Data.Symbol_Policy := Controlled;
4789 elsif Value = "restricted" then
4790 Project.Symbol_Data.Symbol_Policy := Restricted;
4792 elsif Value = "direct" then
4793 Project.Symbol_Data.Symbol_Policy := Direct;
4795 else
4796 Error_Msg
4797 (Data.Flags,
4798 "illegal value for Library_Symbol_Policy",
4799 Lib_Symbol_Policy.Location, Project);
4800 end if;
4801 end;
4802 end if;
4804 -- If attribute Library_Symbol_File is not specified, symbol policy
4805 -- cannot be Restricted.
4807 if Lib_Symbol_File.Default then
4808 if Project.Symbol_Data.Symbol_Policy = Restricted then
4809 Error_Msg
4810 (Data.Flags,
4811 "Library_Symbol_File needs to be defined when " &
4812 "symbol policy is Restricted",
4813 Lib_Symbol_Policy.Location, Project);
4814 end if;
4816 else
4817 -- Library_Symbol_File is defined
4819 Project.Symbol_Data.Symbol_File :=
4820 Path_Name_Type (Lib_Symbol_File.Value);
4822 Get_Name_String (Lib_Symbol_File.Value);
4824 if Name_Len = 0 then
4825 Error_Msg
4826 (Data.Flags,
4827 "symbol file name cannot be an empty string",
4828 Lib_Symbol_File.Location, Project);
4830 else
4831 OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
4833 if OK then
4834 for J in 1 .. Name_Len loop
4835 if Name_Buffer (J) = '/'
4836 or else Name_Buffer (J) = Directory_Separator
4837 then
4838 OK := False;
4839 exit;
4840 end if;
4841 end loop;
4842 end if;
4844 if not OK then
4845 Error_Msg_File_1 := File_Name_Type (Lib_Symbol_File.Value);
4846 Error_Msg
4847 (Data.Flags,
4848 "symbol file name { is illegal. " &
4849 "Name cannot include directory info.",
4850 Lib_Symbol_File.Location, Project);
4851 end if;
4852 end if;
4853 end if;
4855 -- If attribute Library_Reference_Symbol_File is not defined,
4856 -- symbol policy cannot be Compliant or Controlled.
4858 if Lib_Ref_Symbol_File.Default then
4859 if Project.Symbol_Data.Symbol_Policy = Compliant
4860 or else Project.Symbol_Data.Symbol_Policy = Controlled
4861 then
4862 Error_Msg
4863 (Data.Flags,
4864 "a reference symbol file needs to be defined",
4865 Lib_Symbol_Policy.Location, Project);
4866 end if;
4868 else
4869 -- Library_Reference_Symbol_File is defined, check file exists
4871 Project.Symbol_Data.Reference :=
4872 Path_Name_Type (Lib_Ref_Symbol_File.Value);
4874 Get_Name_String (Lib_Ref_Symbol_File.Value);
4876 if Name_Len = 0 then
4877 Error_Msg
4878 (Data.Flags,
4879 "reference symbol file name cannot be an empty string",
4880 Lib_Symbol_File.Location, Project);
4882 else
4883 if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then
4884 Name_Len := 0;
4885 Add_Str_To_Name_Buffer
4886 (Get_Name_String (Project.Directory.Name));
4887 Add_Str_To_Name_Buffer
4888 (Get_Name_String (Lib_Ref_Symbol_File.Value));
4889 Project.Symbol_Data.Reference := Name_Find;
4890 end if;
4892 if not Is_Regular_File
4893 (Get_Name_String (Project.Symbol_Data.Reference))
4894 then
4895 Error_Msg_File_1 :=
4896 File_Name_Type (Lib_Ref_Symbol_File.Value);
4898 -- For controlled and direct symbol policies, it is an error
4899 -- if the reference symbol file does not exist. For other
4900 -- symbol policies, this is just a warning
4902 Error_Msg_Warn :=
4903 Project.Symbol_Data.Symbol_Policy /= Controlled
4904 and then Project.Symbol_Data.Symbol_Policy /= Direct;
4906 Error_Msg
4907 (Data.Flags,
4908 "<library reference symbol file { does not exist",
4909 Lib_Ref_Symbol_File.Location, Project);
4911 -- In addition in the non-controlled case, if symbol policy
4912 -- is Compliant, it is changed to Autonomous, because there
4913 -- is no reference to check against, and we don't want to
4914 -- fail in this case.
4916 if Project.Symbol_Data.Symbol_Policy /= Controlled then
4917 if Project.Symbol_Data.Symbol_Policy = Compliant then
4918 Project.Symbol_Data.Symbol_Policy := Autonomous;
4919 end if;
4920 end if;
4921 end if;
4923 -- If both the reference symbol file and the symbol file are
4924 -- defined, then check that they are not the same file.
4926 if Project.Symbol_Data.Symbol_File /= No_Path then
4927 Get_Name_String (Project.Symbol_Data.Symbol_File);
4929 if Name_Len > 0 then
4930 declare
4931 -- We do not need to pass a Directory to
4932 -- Normalize_Pathname, since the path_information
4933 -- already contains absolute information.
4935 Symb_Path : constant String :=
4936 Normalize_Pathname
4937 (Get_Name_String
4938 (Project.Object_Directory.Name) &
4939 Name_Buffer (1 .. Name_Len),
4940 Directory => "/",
4941 Resolve_Links =>
4942 Opt.Follow_Links_For_Files);
4943 Ref_Path : constant String :=
4944 Normalize_Pathname
4945 (Get_Name_String
4946 (Project.Symbol_Data.Reference),
4947 Directory => "/",
4948 Resolve_Links =>
4949 Opt.Follow_Links_For_Files);
4950 begin
4951 if Symb_Path = Ref_Path then
4952 Error_Msg
4953 (Data.Flags,
4954 "library reference symbol file and library" &
4955 " symbol file cannot be the same file",
4956 Lib_Ref_Symbol_File.Location, Project);
4957 end if;
4958 end;
4959 end if;
4960 end if;
4961 end if;
4962 end if;
4963 end if;
4964 end Check_Stand_Alone_Library;
4966 ----------------------------
4967 -- Compute_Directory_Last --
4968 ----------------------------
4970 function Compute_Directory_Last (Dir : String) return Natural is
4971 begin
4972 if Dir'Length > 1
4973 and then (Dir (Dir'Last - 1) = Directory_Separator
4974 or else
4975 Dir (Dir'Last - 1) = '/')
4976 then
4977 return Dir'Last - 1;
4978 else
4979 return Dir'Last;
4980 end if;
4981 end Compute_Directory_Last;
4983 ---------------------
4984 -- Get_Directories --
4985 ---------------------
4987 procedure Get_Directories
4988 (Project : Project_Id;
4989 Data : in out Tree_Processing_Data)
4991 Object_Dir : constant Variable_Value :=
4992 Util.Value_Of
4993 (Name_Object_Dir, Project.Decl.Attributes, Data.Tree);
4995 Exec_Dir : constant Variable_Value :=
4996 Util.Value_Of
4997 (Name_Exec_Dir, Project.Decl.Attributes, Data.Tree);
4999 Source_Dirs : constant Variable_Value :=
5000 Util.Value_Of
5001 (Name_Source_Dirs, Project.Decl.Attributes, Data.Tree);
5003 Ignore_Source_Sub_Dirs : constant Variable_Value :=
5004 Util.Value_Of
5005 (Name_Ignore_Source_Sub_Dirs,
5006 Project.Decl.Attributes,
5007 Data.Tree);
5009 Excluded_Source_Dirs : constant Variable_Value :=
5010 Util.Value_Of
5011 (Name_Excluded_Source_Dirs,
5012 Project.Decl.Attributes,
5013 Data.Tree);
5015 Source_Files : constant Variable_Value :=
5016 Util.Value_Of
5017 (Name_Source_Files,
5018 Project.Decl.Attributes, Data.Tree);
5020 Last_Source_Dir : String_List_Id := Nil_String;
5021 Last_Src_Dir_Rank : Number_List_Index := No_Number_List;
5023 Languages : constant Variable_Value :=
5024 Prj.Util.Value_Of
5025 (Name_Languages, Project.Decl.Attributes, Data.Tree);
5027 Remove_Source_Dirs : Boolean := False;
5029 procedure Add_To_Or_Remove_From_Source_Dirs
5030 (Path : Path_Information;
5031 Rank : Natural);
5032 -- When Removed = False, the directory Path_Id to the list of
5033 -- source_dirs if not already in the list. When Removed = True,
5034 -- removed directory Path_Id if in the list.
5036 procedure Find_Source_Dirs is new Expand_Subdirectory_Pattern
5037 (Add_To_Or_Remove_From_Source_Dirs);
5039 ---------------------------------------
5040 -- Add_To_Or_Remove_From_Source_Dirs --
5041 ---------------------------------------
5043 procedure Add_To_Or_Remove_From_Source_Dirs
5044 (Path : Path_Information;
5045 Rank : Natural)
5047 List : String_List_Id;
5048 Prev : String_List_Id;
5049 Rank_List : Number_List_Index;
5050 Prev_Rank : Number_List_Index;
5051 Element : String_Element;
5053 begin
5054 Prev := Nil_String;
5055 Prev_Rank := No_Number_List;
5056 List := Project.Source_Dirs;
5057 Rank_List := Project.Source_Dir_Ranks;
5058 while List /= Nil_String loop
5059 Element := Data.Tree.String_Elements.Table (List);
5060 exit when Element.Value = Name_Id (Path.Name);
5061 Prev := List;
5062 List := Element.Next;
5063 Prev_Rank := Rank_List;
5064 Rank_List := Data.Tree.Number_Lists.Table (Prev_Rank).Next;
5065 end loop;
5067 -- The directory is in the list if List is not Nil_String
5069 if not Remove_Source_Dirs and then List = Nil_String then
5070 if Current_Verbosity = High then
5071 Write_Str (" Adding Source Dir=");
5072 Write_Line (Get_Name_String (Path.Display_Name));
5073 end if;
5075 String_Element_Table.Increment_Last (Data.Tree.String_Elements);
5076 Element :=
5077 (Value => Name_Id (Path.Name),
5078 Index => 0,
5079 Display_Value => Name_Id (Path.Display_Name),
5080 Location => No_Location,
5081 Flag => False,
5082 Next => Nil_String);
5084 Number_List_Table.Increment_Last (Data.Tree.Number_Lists);
5086 if Last_Source_Dir = Nil_String then
5088 -- This is the first source directory
5090 Project.Source_Dirs :=
5091 String_Element_Table.Last (Data.Tree.String_Elements);
5092 Project.Source_Dir_Ranks :=
5093 Number_List_Table.Last (Data.Tree.Number_Lists);
5095 else
5096 -- We already have source directories, link the previous
5097 -- last to the new one.
5099 Data.Tree.String_Elements.Table (Last_Source_Dir).Next :=
5100 String_Element_Table.Last (Data.Tree.String_Elements);
5101 Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank).Next :=
5102 Number_List_Table.Last (Data.Tree.Number_Lists);
5103 end if;
5105 -- And register this source directory as the new last
5107 Last_Source_Dir :=
5108 String_Element_Table.Last (Data.Tree.String_Elements);
5109 Data.Tree.String_Elements.Table (Last_Source_Dir) := Element;
5110 Last_Src_Dir_Rank :=
5111 Number_List_Table.Last (Data.Tree.Number_Lists);
5112 Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank) :=
5113 (Number => Rank, Next => No_Number_List);
5115 elsif Remove_Source_Dirs and then List /= Nil_String then
5117 -- Remove source dir if present
5119 if Prev = Nil_String then
5120 Project.Source_Dirs :=
5121 Data.Tree.String_Elements.Table (List).Next;
5122 Project.Source_Dir_Ranks :=
5123 Data.Tree.Number_Lists.Table (Rank_List).Next;
5125 else
5126 Data.Tree.String_Elements.Table (Prev).Next :=
5127 Data.Tree.String_Elements.Table (List).Next;
5128 Data.Tree.Number_Lists.Table (Prev_Rank).Next :=
5129 Data.Tree.Number_Lists.Table (Rank_List).Next;
5130 end if;
5131 end if;
5132 end Add_To_Or_Remove_From_Source_Dirs;
5134 -- Local declarations
5136 Dir_Exists : Boolean;
5138 No_Sources : constant Boolean :=
5139 ((not Source_Files.Default
5140 and then Source_Files.Values = Nil_String)
5141 or else
5142 (not Source_Dirs.Default
5143 and then Source_Dirs.Values = Nil_String)
5144 or else
5145 (not Languages.Default
5146 and then Languages.Values = Nil_String))
5147 and then Project.Extends = No_Project;
5149 -- Start of processing for Get_Directories
5151 begin
5152 if Current_Verbosity = High then
5153 Write_Line ("Starting to look for directories");
5154 end if;
5156 -- Set the object directory to its default which may be nil, if there
5157 -- is no sources in the project.
5159 if No_Sources then
5160 Project.Object_Directory := No_Path_Information;
5161 else
5162 Project.Object_Directory := Project.Directory;
5163 end if;
5165 -- Check the object directory
5167 if Object_Dir.Value /= Empty_String then
5168 Get_Name_String (Object_Dir.Value);
5170 if Name_Len = 0 then
5171 Error_Msg
5172 (Data.Flags,
5173 "Object_Dir cannot be empty",
5174 Object_Dir.Location, Project);
5176 elsif not No_Sources then
5178 -- We check that the specified object directory does exist.
5179 -- However, even when it doesn't exist, we set it to a default
5180 -- value. This is for the benefit of tools that recover from
5181 -- errors; for example, these tools could create the non existent
5182 -- directory. We always return an absolute directory name though.
5184 Locate_Directory
5185 (Project,
5186 File_Name_Type (Object_Dir.Value),
5187 Path => Project.Object_Directory,
5188 Create => "object",
5189 Dir_Exists => Dir_Exists,
5190 Data => Data,
5191 Location => Object_Dir.Location,
5192 Must_Exist => False,
5193 Externally_Built => Project.Externally_Built);
5195 if not Dir_Exists
5196 and then not Project.Externally_Built
5197 then
5198 -- The object directory does not exist, report an error if the
5199 -- project is not externally built.
5201 Err_Vars.Error_Msg_File_1 :=
5202 File_Name_Type (Object_Dir.Value);
5203 Error_Or_Warning
5204 (Data.Flags, Data.Flags.Require_Obj_Dirs,
5205 "object directory { not found", Project.Location, Project);
5206 end if;
5207 end if;
5209 elsif not No_Sources and then Subdirs /= null then
5210 Name_Len := 1;
5211 Name_Buffer (1) := '.';
5212 Locate_Directory
5213 (Project,
5214 Name_Find,
5215 Path => Project.Object_Directory,
5216 Create => "object",
5217 Dir_Exists => Dir_Exists,
5218 Data => Data,
5219 Location => Object_Dir.Location,
5220 Externally_Built => Project.Externally_Built);
5221 end if;
5223 if Current_Verbosity = High then
5224 if Project.Object_Directory = No_Path_Information then
5225 Write_Line ("No object directory");
5226 else
5227 Write_Attr
5228 ("Object directory",
5229 Get_Name_String (Project.Object_Directory.Display_Name));
5230 end if;
5231 end if;
5233 -- Check the exec directory
5235 -- We set the object directory to its default
5237 Project.Exec_Directory := Project.Object_Directory;
5239 if Exec_Dir.Value /= Empty_String then
5240 Get_Name_String (Exec_Dir.Value);
5242 if Name_Len = 0 then
5243 Error_Msg
5244 (Data.Flags,
5245 "Exec_Dir cannot be empty",
5246 Exec_Dir.Location, Project);
5248 elsif not No_Sources then
5250 -- We check that the specified exec directory does exist
5252 Locate_Directory
5253 (Project,
5254 File_Name_Type (Exec_Dir.Value),
5255 Path => Project.Exec_Directory,
5256 Dir_Exists => Dir_Exists,
5257 Data => Data,
5258 Create => "exec",
5259 Location => Exec_Dir.Location,
5260 Externally_Built => Project.Externally_Built);
5262 if not Dir_Exists then
5263 Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value);
5264 Error_Or_Warning
5265 (Data.Flags, Data.Flags.Missing_Source_Files,
5266 "exec directory { not found", Project.Location, Project);
5267 end if;
5268 end if;
5269 end if;
5271 if Current_Verbosity = High then
5272 if Project.Exec_Directory = No_Path_Information then
5273 Write_Line ("No exec directory");
5274 else
5275 Write_Str ("Exec directory: """);
5276 Write_Str (Get_Name_String (Project.Exec_Directory.Display_Name));
5277 Write_Line ("""");
5278 end if;
5279 end if;
5281 -- Look for the source directories
5283 if Current_Verbosity = High then
5284 Write_Line ("Starting to look for source directories");
5285 end if;
5287 pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list");
5289 if not Source_Files.Default
5290 and then Source_Files.Values = Nil_String
5291 then
5292 Project.Source_Dirs := Nil_String;
5294 if Project.Qualifier = Standard then
5295 Error_Msg
5296 (Data.Flags,
5297 "a standard project cannot have no sources",
5298 Source_Files.Location, Project);
5299 end if;
5301 elsif Source_Dirs.Default then
5303 -- No Source_Dirs specified: the single source directory is the one
5304 -- containing the project file.
5306 Remove_Source_Dirs := False;
5307 Add_To_Or_Remove_From_Source_Dirs
5308 (Path => (Name => Project.Directory.Name,
5309 Display_Name => Project.Directory.Display_Name),
5310 Rank => 1);
5312 else
5313 Remove_Source_Dirs := False;
5314 Find_Source_Dirs
5315 (Project => Project,
5316 Data => Data,
5317 Patterns => Source_Dirs.Values,
5318 Ignore => Ignore_Source_Sub_Dirs.Values,
5319 Search_For => Search_Directories,
5320 Resolve_Links => Opt.Follow_Links_For_Dirs);
5322 if Project.Source_Dirs = Nil_String
5323 and then Project.Qualifier = Standard
5324 then
5325 Error_Msg
5326 (Data.Flags,
5327 "a standard project cannot have no source directories",
5328 Source_Dirs.Location, Project);
5329 end if;
5330 end if;
5332 if not Excluded_Source_Dirs.Default
5333 and then Excluded_Source_Dirs.Values /= Nil_String
5334 then
5335 Remove_Source_Dirs := True;
5336 Find_Source_Dirs
5337 (Project => Project,
5338 Data => Data,
5339 Patterns => Excluded_Source_Dirs.Values,
5340 Ignore => Nil_String,
5341 Search_For => Search_Directories,
5342 Resolve_Links => Opt.Follow_Links_For_Dirs);
5343 end if;
5345 if Current_Verbosity = High then
5346 Write_Line ("Putting source directories in canonical cases");
5347 end if;
5349 declare
5350 Current : String_List_Id := Project.Source_Dirs;
5351 Element : String_Element;
5353 begin
5354 while Current /= Nil_String loop
5355 Element := Data.Tree.String_Elements.Table (Current);
5356 if Element.Value /= No_Name then
5357 Element.Value :=
5358 Name_Id (Canonical_Case_File_Name (Element.Value));
5359 Data.Tree.String_Elements.Table (Current) := Element;
5360 end if;
5362 Current := Element.Next;
5363 end loop;
5364 end;
5365 end Get_Directories;
5367 ---------------
5368 -- Get_Mains --
5369 ---------------
5371 procedure Get_Mains
5372 (Project : Project_Id;
5373 Data : in out Tree_Processing_Data)
5375 Mains : constant Variable_Value :=
5376 Prj.Util.Value_Of
5377 (Name_Main, Project.Decl.Attributes, Data.Tree);
5378 List : String_List_Id;
5379 Elem : String_Element;
5381 begin
5382 Project.Mains := Mains.Values;
5384 -- If no Mains were specified, and if we are an extending project,
5385 -- inherit the Mains from the project we are extending.
5387 if Mains.Default then
5388 if not Project.Library and then Project.Extends /= No_Project then
5389 Project.Mains := Project.Extends.Mains;
5390 end if;
5392 -- In a library project file, Main cannot be specified
5394 elsif Project.Library then
5395 Error_Msg
5396 (Data.Flags,
5397 "a library project file cannot have Main specified",
5398 Mains.Location, Project);
5400 else
5401 List := Mains.Values;
5402 while List /= Nil_String loop
5403 Elem := Data.Tree.String_Elements.Table (List);
5405 if Length_Of_Name (Elem.Value) = 0 then
5406 Error_Msg
5407 (Data.Flags,
5408 "?a main cannot have an empty name",
5409 Elem.Location, Project);
5410 exit;
5411 end if;
5413 List := Elem.Next;
5414 end loop;
5415 end if;
5416 end Get_Mains;
5418 ---------------------------
5419 -- Get_Sources_From_File --
5420 ---------------------------
5422 procedure Get_Sources_From_File
5423 (Path : String;
5424 Location : Source_Ptr;
5425 Project : in out Project_Processing_Data;
5426 Data : in out Tree_Processing_Data)
5428 File : Prj.Util.Text_File;
5429 Line : String (1 .. 250);
5430 Last : Natural;
5431 Source_Name : File_Name_Type;
5432 Name_Loc : Name_Location;
5434 begin
5435 if Current_Verbosity = High then
5436 Write_Str ("Opening """);
5437 Write_Str (Path);
5438 Write_Line (""".");
5439 end if;
5441 -- Open the file
5443 Prj.Util.Open (File, Path);
5445 if not Prj.Util.Is_Valid (File) then
5446 Error_Msg
5447 (Data.Flags, "file does not exist", Location, Project.Project);
5449 else
5450 -- Read the lines one by one
5452 while not Prj.Util.End_Of_File (File) loop
5453 Prj.Util.Get_Line (File, Line, Last);
5455 -- A non empty, non comment line should contain a file name
5457 if Last /= 0
5458 and then (Last = 1 or else Line (1 .. 2) /= "--")
5459 then
5460 Name_Len := Last;
5461 Name_Buffer (1 .. Name_Len) := Line (1 .. Last);
5462 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
5463 Source_Name := Name_Find;
5465 -- Check that there is no directory information
5467 for J in 1 .. Last loop
5468 if Line (J) = '/' or else Line (J) = Directory_Separator then
5469 Error_Msg_File_1 := Source_Name;
5470 Error_Msg
5471 (Data.Flags,
5472 "file name cannot include directory information ({)",
5473 Location, Project.Project);
5474 exit;
5475 end if;
5476 end loop;
5478 Name_Loc := Source_Names_Htable.Get
5479 (Project.Source_Names, Source_Name);
5481 if Name_Loc = No_Name_Location then
5482 Name_Loc :=
5483 (Name => Source_Name,
5484 Location => Location,
5485 Source => No_Source,
5486 Listed => True,
5487 Found => False);
5489 else
5490 Name_Loc.Listed := True;
5491 end if;
5493 Source_Names_Htable.Set
5494 (Project.Source_Names, Source_Name, Name_Loc);
5495 end if;
5496 end loop;
5498 Prj.Util.Close (File);
5500 end if;
5501 end Get_Sources_From_File;
5503 -----------------------
5504 -- Compute_Unit_Name --
5505 -----------------------
5507 procedure Compute_Unit_Name
5508 (File_Name : File_Name_Type;
5509 Naming : Lang_Naming_Data;
5510 Kind : out Source_Kind;
5511 Unit : out Name_Id;
5512 Project : Project_Processing_Data;
5513 In_Tree : Project_Tree_Ref)
5515 Filename : constant String := Get_Name_String (File_Name);
5516 Last : Integer := Filename'Last;
5517 Sep_Len : Integer;
5518 Body_Len : Integer;
5519 Spec_Len : Integer;
5521 Unit_Except : Unit_Exception;
5522 Masked : Boolean := False;
5524 begin
5525 Unit := No_Name;
5526 Kind := Spec;
5528 if Naming.Separate_Suffix = No_File
5529 or else Naming.Body_Suffix = No_File
5530 or else Naming.Spec_Suffix = No_File
5531 then
5532 return;
5533 end if;
5535 if Naming.Dot_Replacement = No_File then
5536 if Current_Verbosity = High then
5537 Write_Line (" No dot_replacement specified");
5538 end if;
5540 return;
5541 end if;
5543 Sep_Len := Integer (Length_Of_Name (Naming.Separate_Suffix));
5544 Spec_Len := Integer (Length_Of_Name (Naming.Spec_Suffix));
5545 Body_Len := Integer (Length_Of_Name (Naming.Body_Suffix));
5547 -- Choose the longest suffix that matches. If there are several matches,
5548 -- give priority to specs, then bodies, then separates.
5550 if Naming.Separate_Suffix /= Naming.Body_Suffix
5551 and then Suffix_Matches (Filename, Naming.Separate_Suffix)
5552 then
5553 Last := Filename'Last - Sep_Len;
5554 Kind := Sep;
5555 end if;
5557 if Filename'Last - Body_Len <= Last
5558 and then Suffix_Matches (Filename, Naming.Body_Suffix)
5559 then
5560 Last := Natural'Min (Last, Filename'Last - Body_Len);
5561 Kind := Impl;
5562 end if;
5564 if Filename'Last - Spec_Len <= Last
5565 and then Suffix_Matches (Filename, Naming.Spec_Suffix)
5566 then
5567 Last := Natural'Min (Last, Filename'Last - Spec_Len);
5568 Kind := Spec;
5569 end if;
5571 if Last = Filename'Last then
5572 if Current_Verbosity = High then
5573 Write_Line (" no matching suffix");
5574 end if;
5576 return;
5577 end if;
5579 -- Check that the casing matches
5581 if File_Names_Case_Sensitive then
5582 case Naming.Casing is
5583 when All_Lower_Case =>
5584 for J in Filename'First .. Last loop
5585 if Is_Letter (Filename (J))
5586 and then not Is_Lower (Filename (J))
5587 then
5588 if Current_Verbosity = High then
5589 Write_Line (" Invalid casing");
5590 end if;
5592 return;
5593 end if;
5594 end loop;
5596 when All_Upper_Case =>
5597 for J in Filename'First .. Last loop
5598 if Is_Letter (Filename (J))
5599 and then not Is_Upper (Filename (J))
5600 then
5601 if Current_Verbosity = High then
5602 Write_Line (" Invalid casing");
5603 end if;
5605 return;
5606 end if;
5607 end loop;
5609 when Mixed_Case | Unknown =>
5610 null;
5611 end case;
5612 end if;
5614 -- If Dot_Replacement is not a single dot, then there should not
5615 -- be any dot in the name.
5617 declare
5618 Dot_Repl : constant String :=
5619 Get_Name_String (Naming.Dot_Replacement);
5621 begin
5622 if Dot_Repl /= "." then
5623 for Index in Filename'First .. Last loop
5624 if Filename (Index) = '.' then
5625 if Current_Verbosity = High then
5626 Write_Line (" Invalid name, contains dot");
5627 end if;
5629 return;
5630 end if;
5631 end loop;
5633 Replace_Into_Name_Buffer
5634 (Filename (Filename'First .. Last), Dot_Repl, '.');
5636 else
5637 Name_Len := Last - Filename'First + 1;
5638 Name_Buffer (1 .. Name_Len) := Filename (Filename'First .. Last);
5639 Fixed.Translate
5640 (Source => Name_Buffer (1 .. Name_Len),
5641 Mapping => Lower_Case_Map);
5642 end if;
5643 end;
5645 -- In the standard GNAT naming scheme, check for special cases: children
5646 -- or separates of A, G, I or S, and run time sources.
5648 if Is_Standard_GNAT_Naming (Naming)
5649 and then Name_Len >= 3
5650 then
5651 declare
5652 S1 : constant Character := Name_Buffer (1);
5653 S2 : constant Character := Name_Buffer (2);
5654 S3 : constant Character := Name_Buffer (3);
5656 begin
5657 if S1 = 'a'
5658 or else S1 = 'g'
5659 or else S1 = 'i'
5660 or else S1 = 's'
5661 then
5662 -- Children or separates of packages A, G, I or S. These names
5663 -- are x__ ... or x~... (where x is a, g, i, or s). Both
5664 -- versions (x__... and x~...) are allowed in all platforms,
5665 -- because it is not possible to know the platform before
5666 -- processing of the project files.
5668 if S2 = '_' and then S3 = '_' then
5669 Name_Buffer (2) := '.';
5670 Name_Buffer (3 .. Name_Len - 1) :=
5671 Name_Buffer (4 .. Name_Len);
5672 Name_Len := Name_Len - 1;
5674 elsif S2 = '~' then
5675 Name_Buffer (2) := '.';
5677 elsif S2 = '.' then
5679 -- If it is potentially a run time source
5681 null;
5682 end if;
5683 end if;
5684 end;
5685 end if;
5687 -- Name_Buffer contains the name of the unit in lower-cases. Check
5688 -- that this is a valid unit name
5690 Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit);
5692 -- If there is a naming exception for the same unit, the file is not
5693 -- a source for the unit.
5695 if Unit /= No_Name then
5696 Unit_Except :=
5697 Unit_Exceptions_Htable.Get (Project.Unit_Exceptions, Unit);
5699 if Kind = Spec then
5700 Masked := Unit_Except.Spec /= No_File
5701 and then
5702 Unit_Except.Spec /= File_Name;
5703 else
5704 Masked := Unit_Except.Impl /= No_File
5705 and then
5706 Unit_Except.Impl /= File_Name;
5707 end if;
5709 if Masked then
5710 if Current_Verbosity = High then
5711 Write_Str (" """ & Filename & """ contains the ");
5713 if Kind = Spec then
5714 Write_Str ("spec of a unit found in """);
5715 Write_Str (Get_Name_String (Unit_Except.Spec));
5716 else
5717 Write_Str ("body of a unit found in """);
5718 Write_Str (Get_Name_String (Unit_Except.Impl));
5719 end if;
5721 Write_Line (""" (ignored)");
5722 end if;
5724 Unit := No_Name;
5725 end if;
5726 end if;
5728 if Unit /= No_Name
5729 and then Current_Verbosity = High
5730 then
5731 case Kind is
5732 when Spec => Write_Str (" spec of ");
5733 when Impl => Write_Str (" body of ");
5734 when Sep => Write_Str (" sep of ");
5735 end case;
5737 Write_Line (Get_Name_String (Unit));
5738 end if;
5739 end Compute_Unit_Name;
5741 --------------------------
5742 -- Check_Illegal_Suffix --
5743 --------------------------
5745 procedure Check_Illegal_Suffix
5746 (Project : Project_Id;
5747 Suffix : File_Name_Type;
5748 Dot_Replacement : File_Name_Type;
5749 Attribute_Name : String;
5750 Location : Source_Ptr;
5751 Data : in out Tree_Processing_Data)
5753 Suffix_Str : constant String := Get_Name_String (Suffix);
5755 begin
5756 if Suffix_Str'Length = 0 then
5758 -- Always valid
5760 return;
5762 elsif Index (Suffix_Str, ".") = 0 then
5763 Err_Vars.Error_Msg_File_1 := Suffix;
5764 Error_Msg
5765 (Data.Flags,
5766 "{ is illegal for " & Attribute_Name & ": must have a dot",
5767 Location, Project);
5768 return;
5769 end if;
5771 -- Case of dot replacement is a single dot, and first character of
5772 -- suffix is also a dot.
5774 if Dot_Replacement /= No_File
5775 and then Get_Name_String (Dot_Replacement) = "."
5776 and then Suffix_Str (Suffix_Str'First) = '.'
5777 then
5778 for Index in Suffix_Str'First + 1 .. Suffix_Str'Last loop
5780 -- If there are multiple dots in the name
5782 if Suffix_Str (Index) = '.' then
5784 -- It is illegal to have a letter following the initial dot
5786 if Is_Letter (Suffix_Str (Suffix_Str'First + 1)) then
5787 Err_Vars.Error_Msg_File_1 := Suffix;
5788 Error_Msg
5789 (Data.Flags,
5790 "{ is illegal for " & Attribute_Name
5791 & ": ambiguous prefix when Dot_Replacement is a dot",
5792 Location, Project);
5793 end if;
5794 return;
5795 end if;
5796 end loop;
5797 end if;
5798 end Check_Illegal_Suffix;
5800 ----------------------
5801 -- Locate_Directory --
5802 ----------------------
5804 procedure Locate_Directory
5805 (Project : Project_Id;
5806 Name : File_Name_Type;
5807 Path : out Path_Information;
5808 Dir_Exists : out Boolean;
5809 Data : in out Tree_Processing_Data;
5810 Create : String := "";
5811 Location : Source_Ptr := No_Location;
5812 Must_Exist : Boolean := True;
5813 Externally_Built : Boolean := False)
5815 Parent : constant Path_Name_Type :=
5816 Project.Directory.Display_Name;
5817 The_Parent : constant String :=
5818 Get_Name_String (Parent);
5819 The_Parent_Last : constant Natural :=
5820 Compute_Directory_Last (The_Parent);
5821 Full_Name : File_Name_Type;
5822 The_Name : File_Name_Type;
5824 begin
5825 Get_Name_String (Name);
5827 -- Add Subdirs.all if it is a directory that may be created and
5828 -- Subdirs is not null;
5830 if Create /= "" and then Subdirs /= null then
5831 if Name_Buffer (Name_Len) /= Directory_Separator then
5832 Add_Char_To_Name_Buffer (Directory_Separator);
5833 end if;
5835 Add_Str_To_Name_Buffer (Subdirs.all);
5836 end if;
5838 -- Convert '/' to directory separator (for Windows)
5840 for J in 1 .. Name_Len loop
5841 if Name_Buffer (J) = '/' then
5842 Name_Buffer (J) := Directory_Separator;
5843 end if;
5844 end loop;
5846 The_Name := Name_Find;
5848 if Current_Verbosity = High then
5849 Write_Str ("Locate_Directory (""");
5850 Write_Str (Get_Name_String (The_Name));
5851 Write_Str (""", """);
5852 Write_Str (The_Parent);
5853 Write_Line (""")");
5854 end if;
5856 Path := No_Path_Information;
5857 Dir_Exists := False;
5859 if Is_Absolute_Path (Get_Name_String (The_Name)) then
5860 Full_Name := The_Name;
5862 else
5863 Name_Len := 0;
5864 Add_Str_To_Name_Buffer
5865 (The_Parent (The_Parent'First .. The_Parent_Last));
5866 Add_Str_To_Name_Buffer (Get_Name_String (The_Name));
5867 Full_Name := Name_Find;
5868 end if;
5870 declare
5871 Full_Path_Name : String_Access :=
5872 new String'(Get_Name_String (Full_Name));
5874 begin
5875 if (Setup_Projects or else Subdirs /= null)
5876 and then Create'Length > 0
5877 then
5878 if not Is_Directory (Full_Path_Name.all) then
5880 -- If project is externally built, do not create a subdir,
5881 -- use the specified directory, without the subdir.
5883 if Externally_Built then
5884 if Is_Absolute_Path (Get_Name_String (Name)) then
5885 Get_Name_String (Name);
5887 else
5888 Name_Len := 0;
5889 Add_Str_To_Name_Buffer
5890 (The_Parent (The_Parent'First .. The_Parent_Last));
5891 Add_Str_To_Name_Buffer (Get_Name_String (Name));
5892 end if;
5894 Full_Path_Name := new String'(Name_Buffer (1 .. Name_Len));
5896 else
5897 begin
5898 Create_Path (Full_Path_Name.all);
5900 if not Quiet_Output then
5901 Write_Str (Create);
5902 Write_Str (" directory """);
5903 Write_Str (Full_Path_Name.all);
5904 Write_Str (""" created for project ");
5905 Write_Line (Get_Name_String (Project.Name));
5906 end if;
5908 exception
5909 when Use_Error =>
5910 Error_Msg
5911 (Data.Flags,
5912 "could not create " & Create &
5913 " directory " & Full_Path_Name.all,
5914 Location, Project);
5915 end;
5916 end if;
5917 end if;
5918 end if;
5920 Dir_Exists := Is_Directory (Full_Path_Name.all);
5922 if not Must_Exist or else Dir_Exists then
5923 declare
5924 Normed : constant String :=
5925 Normalize_Pathname
5926 (Full_Path_Name.all,
5927 Directory =>
5928 The_Parent (The_Parent'First .. The_Parent_Last),
5929 Resolve_Links => False,
5930 Case_Sensitive => True);
5932 Canonical_Path : constant String :=
5933 Normalize_Pathname
5934 (Normed,
5935 Directory =>
5936 The_Parent
5937 (The_Parent'First .. The_Parent_Last),
5938 Resolve_Links =>
5939 Opt.Follow_Links_For_Dirs,
5940 Case_Sensitive => False);
5942 begin
5943 Name_Len := Normed'Length;
5944 Name_Buffer (1 .. Name_Len) := Normed;
5946 -- Directories should always end with a directory separator
5948 if Name_Buffer (Name_Len) /= Directory_Separator then
5949 Add_Char_To_Name_Buffer (Directory_Separator);
5950 end if;
5952 Path.Display_Name := Name_Find;
5954 Name_Len := Canonical_Path'Length;
5955 Name_Buffer (1 .. Name_Len) := Canonical_Path;
5957 if Name_Buffer (Name_Len) /= Directory_Separator then
5958 Add_Char_To_Name_Buffer (Directory_Separator);
5959 end if;
5961 Path.Name := Name_Find;
5962 end;
5963 end if;
5965 Free (Full_Path_Name);
5966 end;
5967 end Locate_Directory;
5969 ---------------------------
5970 -- Find_Excluded_Sources --
5971 ---------------------------
5973 procedure Find_Excluded_Sources
5974 (Project : in out Project_Processing_Data;
5975 Data : in out Tree_Processing_Data)
5977 Excluded_Source_List_File : constant Variable_Value :=
5978 Util.Value_Of
5979 (Name_Excluded_Source_List_File,
5980 Project.Project.Decl.Attributes,
5981 Data.Tree);
5982 Excluded_Sources : Variable_Value := Util.Value_Of
5983 (Name_Excluded_Source_Files,
5984 Project.Project.Decl.Attributes,
5985 Data.Tree);
5987 Current : String_List_Id;
5988 Element : String_Element;
5989 Location : Source_Ptr;
5990 Name : File_Name_Type;
5991 File : Prj.Util.Text_File;
5992 Line : String (1 .. 300);
5993 Last : Natural;
5994 Locally_Removed : Boolean := False;
5996 begin
5997 -- If Excluded_Source_Files is not declared, check Locally_Removed_Files
5999 if Excluded_Sources.Default then
6000 Locally_Removed := True;
6001 Excluded_Sources :=
6002 Util.Value_Of
6003 (Name_Locally_Removed_Files,
6004 Project.Project.Decl.Attributes, Data.Tree);
6005 end if;
6007 -- If there are excluded sources, put them in the table
6009 if not Excluded_Sources.Default then
6010 if not Excluded_Source_List_File.Default then
6011 if Locally_Removed then
6012 Error_Msg
6013 (Data.Flags,
6014 "?both attributes Locally_Removed_Files and " &
6015 "Excluded_Source_List_File are present",
6016 Excluded_Source_List_File.Location, Project.Project);
6017 else
6018 Error_Msg
6019 (Data.Flags,
6020 "?both attributes Excluded_Source_Files and " &
6021 "Excluded_Source_List_File are present",
6022 Excluded_Source_List_File.Location, Project.Project);
6023 end if;
6024 end if;
6026 Current := Excluded_Sources.Values;
6027 while Current /= Nil_String loop
6028 Element := Data.Tree.String_Elements.Table (Current);
6029 Name := Canonical_Case_File_Name (Element.Value);
6031 -- If the element has no location, then use the location of
6032 -- Excluded_Sources to report possible errors.
6034 if Element.Location = No_Location then
6035 Location := Excluded_Sources.Location;
6036 else
6037 Location := Element.Location;
6038 end if;
6040 Excluded_Sources_Htable.Set
6041 (Project.Excluded, Name, (Name, False, Location));
6042 Current := Element.Next;
6043 end loop;
6045 elsif not Excluded_Source_List_File.Default then
6046 Location := Excluded_Source_List_File.Location;
6048 declare
6049 Source_File_Path_Name : constant String :=
6050 Path_Name_Of
6051 (File_Name_Type
6052 (Excluded_Source_List_File.Value),
6053 Project.Project.Directory.Name);
6055 begin
6056 if Source_File_Path_Name'Length = 0 then
6057 Err_Vars.Error_Msg_File_1 :=
6058 File_Name_Type (Excluded_Source_List_File.Value);
6059 Error_Msg
6060 (Data.Flags,
6061 "file with excluded sources { does not exist",
6062 Excluded_Source_List_File.Location, Project.Project);
6064 else
6065 -- Open the file
6067 Prj.Util.Open (File, Source_File_Path_Name);
6069 if not Prj.Util.Is_Valid (File) then
6070 Error_Msg
6071 (Data.Flags, "file does not exist",
6072 Location, Project.Project);
6073 else
6074 -- Read the lines one by one
6076 while not Prj.Util.End_Of_File (File) loop
6077 Prj.Util.Get_Line (File, Line, Last);
6079 -- Non empty, non comment line should contain a file name
6081 if Last /= 0
6082 and then (Last = 1 or else Line (1 .. 2) /= "--")
6083 then
6084 Name_Len := Last;
6085 Name_Buffer (1 .. Name_Len) := Line (1 .. Last);
6086 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
6087 Name := Name_Find;
6089 -- Check that there is no directory information
6091 for J in 1 .. Last loop
6092 if Line (J) = '/'
6093 or else Line (J) = Directory_Separator
6094 then
6095 Error_Msg_File_1 := Name;
6096 Error_Msg
6097 (Data.Flags,
6098 "file name cannot include " &
6099 "directory information ({)",
6100 Location, Project.Project);
6101 exit;
6102 end if;
6103 end loop;
6105 Excluded_Sources_Htable.Set
6106 (Project.Excluded, Name, (Name, False, Location));
6107 end if;
6108 end loop;
6110 Prj.Util.Close (File);
6111 end if;
6112 end if;
6113 end;
6114 end if;
6115 end Find_Excluded_Sources;
6117 ------------------
6118 -- Find_Sources --
6119 ------------------
6121 procedure Find_Sources
6122 (Project : in out Project_Processing_Data;
6123 Data : in out Tree_Processing_Data)
6125 Sources : constant Variable_Value :=
6126 Util.Value_Of
6127 (Name_Source_Files,
6128 Project.Project.Decl.Attributes,
6129 Data.Tree);
6131 Source_List_File : constant Variable_Value :=
6132 Util.Value_Of
6133 (Name_Source_List_File,
6134 Project.Project.Decl.Attributes,
6135 Data.Tree);
6137 Name_Loc : Name_Location;
6138 Has_Explicit_Sources : Boolean;
6140 begin
6141 pragma Assert (Sources.Kind = List, "Source_Files is not a list");
6142 pragma Assert
6143 (Source_List_File.Kind = Single,
6144 "Source_List_File is not a single string");
6146 Project.Source_List_File_Location := Source_List_File.Location;
6148 -- If the user has specified a Source_Files attribute
6150 if not Sources.Default then
6151 if not Source_List_File.Default then
6152 Error_Msg
6153 (Data.Flags,
6154 "?both attributes source_files and " &
6155 "source_list_file are present",
6156 Source_List_File.Location, Project.Project);
6157 end if;
6159 -- Sources is a list of file names
6161 declare
6162 Current : String_List_Id := Sources.Values;
6163 Element : String_Element;
6164 Location : Source_Ptr;
6165 Name : File_Name_Type;
6167 begin
6168 if Current = Nil_String then
6169 Project.Project.Languages := No_Language_Index;
6171 -- This project contains no source. For projects that don't
6172 -- extend other projects, this also means that there is no
6173 -- need for an object directory, if not specified.
6175 if Project.Project.Extends = No_Project
6176 and then Project.Project.Object_Directory =
6177 Project.Project.Directory
6178 then
6179 Project.Project.Object_Directory := No_Path_Information;
6180 end if;
6181 end if;
6183 while Current /= Nil_String loop
6184 Element := Data.Tree.String_Elements.Table (Current);
6185 Name := Canonical_Case_File_Name (Element.Value);
6186 Get_Name_String (Element.Value);
6188 -- If the element has no location, then use the location of
6189 -- Sources to report possible errors.
6191 if Element.Location = No_Location then
6192 Location := Sources.Location;
6193 else
6194 Location := Element.Location;
6195 end if;
6197 -- Check that there is no directory information
6199 for J in 1 .. Name_Len loop
6200 if Name_Buffer (J) = '/'
6201 or else Name_Buffer (J) = Directory_Separator
6202 then
6203 Error_Msg_File_1 := Name;
6204 Error_Msg
6205 (Data.Flags,
6206 "file name cannot include directory " &
6207 "information ({)",
6208 Location, Project.Project);
6209 exit;
6210 end if;
6211 end loop;
6213 -- Check whether the file is already there: the same file name
6214 -- may be in the list. If the source is missing, the error will
6215 -- be on the first mention of the source file name.
6217 Name_Loc := Source_Names_Htable.Get
6218 (Project.Source_Names, Name);
6220 if Name_Loc = No_Name_Location then
6221 Name_Loc :=
6222 (Name => Name,
6223 Location => Location,
6224 Source => No_Source,
6225 Listed => True,
6226 Found => False);
6228 else
6229 Name_Loc.Listed := True;
6230 end if;
6232 Source_Names_Htable.Set
6233 (Project.Source_Names, Name, Name_Loc);
6235 Current := Element.Next;
6236 end loop;
6238 Has_Explicit_Sources := True;
6239 end;
6241 -- If we have no Source_Files attribute, check the Source_List_File
6242 -- attribute.
6244 elsif not Source_List_File.Default then
6246 -- Source_List_File is the name of the file that contains the source
6247 -- file names.
6249 declare
6250 Source_File_Path_Name : constant String :=
6251 Path_Name_Of
6252 (File_Name_Type (Source_List_File.Value),
6253 Project.Project.Directory.Name);
6255 begin
6256 Has_Explicit_Sources := True;
6258 if Source_File_Path_Name'Length = 0 then
6259 Err_Vars.Error_Msg_File_1 :=
6260 File_Name_Type (Source_List_File.Value);
6261 Error_Msg
6262 (Data.Flags,
6263 "file with sources { does not exist",
6264 Source_List_File.Location, Project.Project);
6266 else
6267 Get_Sources_From_File
6268 (Source_File_Path_Name, Source_List_File.Location,
6269 Project, Data);
6270 end if;
6271 end;
6273 else
6274 -- Neither Source_Files nor Source_List_File has been specified. Find
6275 -- all the files that satisfy the naming scheme in all the source
6276 -- directories.
6278 Has_Explicit_Sources := False;
6279 end if;
6281 -- Remove any exception that is not in the specified list of sources
6283 if Has_Explicit_Sources then
6284 declare
6285 Source : Source_Id;
6286 Iter : Source_Iterator;
6287 NL : Name_Location;
6288 Again : Boolean;
6289 begin
6290 Iter_Loop :
6291 loop
6292 Again := False;
6293 Iter := For_Each_Source (Data.Tree, Project.Project);
6295 Source_Loop :
6296 loop
6297 Source := Prj.Element (Iter);
6298 exit Source_Loop when Source = No_Source;
6300 if Source.Naming_Exception then
6301 NL := Source_Names_Htable.Get
6302 (Project.Source_Names, Source.File);
6304 if NL /= No_Name_Location and then not NL.Listed then
6305 -- Remove the exception
6306 Source_Names_Htable.Set
6307 (Project.Source_Names,
6308 Source.File,
6309 No_Name_Location);
6310 Remove_Source (Data.Tree, Source, No_Source);
6312 Error_Msg_Name_1 := Name_Id (Source.File);
6313 Error_Msg
6314 (Data.Flags,
6315 "? unknown source file %%",
6316 NL.Location,
6317 Project.Project);
6319 Again := True;
6320 exit Source_Loop;
6321 end if;
6322 end if;
6324 Next (Iter);
6325 end loop Source_Loop;
6327 exit Iter_Loop when not Again;
6328 end loop Iter_Loop;
6329 end;
6330 end if;
6332 Search_Directories
6333 (Project,
6334 Data => Data,
6335 For_All_Sources => Sources.Default and then Source_List_File.Default);
6337 -- Check if all exceptions have been found
6339 declare
6340 Source : Source_Id;
6341 Iter : Source_Iterator;
6342 Found : Boolean := False;
6343 Path : Path_Information;
6345 begin
6346 Iter := For_Each_Source (Data.Tree, Project.Project);
6347 loop
6348 Source := Prj.Element (Iter);
6349 exit when Source = No_Source;
6351 if Source.Naming_Exception
6352 and then Source.Path = No_Path_Information
6353 then
6354 if Source.Unit /= No_Unit_Index then
6355 Found := False;
6357 -- For multi-unit source files, source_id gets duplicated
6358 -- once for every unit. Only the first source_id got its
6359 -- full path set.
6361 if Source.Index /= 0 then
6362 Path := Files_Htable.Get
6363 (Data.File_To_Source, Source.File).Path;
6365 if Path /= No_Path_Information then
6366 Found := True;
6367 end if;
6368 end if;
6370 if not Found then
6371 Error_Msg_Name_1 := Name_Id (Source.Display_File);
6372 Error_Msg_Name_2 := Source.Unit.Name;
6373 Error_Or_Warning
6374 (Data.Flags, Data.Flags.Missing_Source_Files,
6375 "source file %% for unit %% not found",
6376 No_Location, Project.Project);
6378 else
6379 Source.Path := Path;
6381 if Current_Verbosity = High then
6382 if Source.Path /= No_Path_Information then
6383 Write_Line ("Setting full path for "
6384 & Get_Name_String (Source.File)
6385 & " at" & Source.Index'Img
6386 & " to "
6387 & Get_Name_String (Path.Name));
6388 end if;
6389 end if;
6390 end if;
6391 end if;
6393 if Source.Path = No_Path_Information then
6394 Remove_Source (Data.Tree, Source, No_Source);
6395 end if;
6396 end if;
6398 Next (Iter);
6399 end loop;
6400 end;
6402 -- It is an error if a source file name in a source list or in a source
6403 -- list file is not found.
6405 if Has_Explicit_Sources then
6406 declare
6407 NL : Name_Location;
6408 First_Error : Boolean;
6410 begin
6411 NL := Source_Names_Htable.Get_First (Project.Source_Names);
6412 First_Error := True;
6413 while NL /= No_Name_Location loop
6414 if not NL.Found then
6415 Err_Vars.Error_Msg_File_1 := NL.Name;
6416 if First_Error then
6417 Error_Or_Warning
6418 (Data.Flags, Data.Flags.Missing_Source_Files,
6419 "source file { not found",
6420 NL.Location, Project.Project);
6421 First_Error := False;
6422 else
6423 Error_Or_Warning
6424 (Data.Flags, Data.Flags.Missing_Source_Files,
6425 "\source file { not found",
6426 NL.Location, Project.Project);
6427 end if;
6428 end if;
6430 NL := Source_Names_Htable.Get_Next (Project.Source_Names);
6431 end loop;
6432 end;
6433 end if;
6434 end Find_Sources;
6436 ----------------
6437 -- Initialize --
6438 ----------------
6440 procedure Initialize
6441 (Data : out Tree_Processing_Data;
6442 Tree : Project_Tree_Ref;
6443 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
6444 Flags : Prj.Processing_Flags)
6446 begin
6447 Files_Htable.Reset (Data.File_To_Source);
6448 Data.Tree := Tree;
6449 Data.Node_Tree := Node_Tree;
6450 Data.Flags := Flags;
6451 end Initialize;
6453 ----------
6454 -- Free --
6455 ----------
6457 procedure Free (Data : in out Tree_Processing_Data) is
6458 begin
6459 Files_Htable.Reset (Data.File_To_Source);
6460 end Free;
6462 ----------------
6463 -- Initialize --
6464 ----------------
6466 procedure Initialize
6467 (Data : in out Project_Processing_Data;
6468 Project : Project_Id)
6470 begin
6471 Data.Project := Project;
6472 end Initialize;
6474 ----------
6475 -- Free --
6476 ----------
6478 procedure Free (Data : in out Project_Processing_Data) is
6479 begin
6480 Source_Names_Htable.Reset (Data.Source_Names);
6481 Unit_Exceptions_Htable.Reset (Data.Unit_Exceptions);
6482 Excluded_Sources_Htable.Reset (Data.Excluded);
6483 end Free;
6485 -------------------------------
6486 -- Check_File_Naming_Schemes --
6487 -------------------------------
6489 procedure Check_File_Naming_Schemes
6490 (In_Tree : Project_Tree_Ref;
6491 Project : Project_Processing_Data;
6492 File_Name : File_Name_Type;
6493 Alternate_Languages : out Language_List;
6494 Language : out Language_Ptr;
6495 Display_Language_Name : out Name_Id;
6496 Unit : out Name_Id;
6497 Lang_Kind : out Language_Kind;
6498 Kind : out Source_Kind)
6500 Filename : constant String := Get_Name_String (File_Name);
6501 Config : Language_Config;
6502 Tmp_Lang : Language_Ptr;
6504 Header_File : Boolean := False;
6505 -- True if we found at least one language for which the file is a header
6506 -- In such a case, we search for all possible languages where this is
6507 -- also a header (C and C++ for instance), since the file might be used
6508 -- for several such languages.
6510 procedure Check_File_Based_Lang;
6511 -- Does the naming scheme test for file-based languages. For those,
6512 -- there is no Unit. Just check if the file name has the implementation
6513 -- or, if it is specified, the template suffix of the language.
6515 -- Returns True if the file belongs to the current language and we
6516 -- should stop searching for matching languages. Not that a given header
6517 -- file could belong to several languages (C and C++ for instance). Thus
6518 -- if we found a header we'll check whether it matches other languages.
6520 ---------------------------
6521 -- Check_File_Based_Lang --
6522 ---------------------------
6524 procedure Check_File_Based_Lang is
6525 begin
6526 if not Header_File
6527 and then Suffix_Matches (Filename, Config.Naming_Data.Body_Suffix)
6528 then
6529 Unit := No_Name;
6530 Kind := Impl;
6531 Language := Tmp_Lang;
6533 if Current_Verbosity = High then
6534 Write_Str (" implementation of language ");
6535 Write_Line (Get_Name_String (Display_Language_Name));
6536 end if;
6538 elsif Suffix_Matches (Filename, Config.Naming_Data.Spec_Suffix) then
6539 if Current_Verbosity = High then
6540 Write_Str (" header of language ");
6541 Write_Line (Get_Name_String (Display_Language_Name));
6542 end if;
6544 if Header_File then
6545 Alternate_Languages := new Language_List_Element'
6546 (Language => Language,
6547 Next => Alternate_Languages);
6549 else
6550 Header_File := True;
6551 Kind := Spec;
6552 Unit := No_Name;
6553 Language := Tmp_Lang;
6554 end if;
6555 end if;
6556 end Check_File_Based_Lang;
6558 -- Start of processing for Check_File_Naming_Schemes
6560 begin
6561 Language := No_Language_Index;
6562 Alternate_Languages := null;
6563 Display_Language_Name := No_Name;
6564 Unit := No_Name;
6565 Lang_Kind := File_Based;
6566 Kind := Spec;
6568 Tmp_Lang := Project.Project.Languages;
6569 while Tmp_Lang /= No_Language_Index loop
6570 if Current_Verbosity = High then
6571 Write_Line
6572 (" Testing language "
6573 & Get_Name_String (Tmp_Lang.Name)
6574 & " Header_File=" & Header_File'Img);
6575 end if;
6577 Display_Language_Name := Tmp_Lang.Display_Name;
6578 Config := Tmp_Lang.Config;
6579 Lang_Kind := Config.Kind;
6581 case Config.Kind is
6582 when File_Based =>
6583 Check_File_Based_Lang;
6584 exit when Kind = Impl;
6586 when Unit_Based =>
6588 -- We know it belongs to a least a file_based language, no
6589 -- need to check unit-based ones.
6591 if not Header_File then
6592 Compute_Unit_Name
6593 (File_Name => File_Name,
6594 Naming => Config.Naming_Data,
6595 Kind => Kind,
6596 Unit => Unit,
6597 Project => Project,
6598 In_Tree => In_Tree);
6600 if Unit /= No_Name then
6601 Language := Tmp_Lang;
6602 exit;
6603 end if;
6604 end if;
6605 end case;
6607 Tmp_Lang := Tmp_Lang.Next;
6608 end loop;
6610 if Language = No_Language_Index
6611 and then Current_Verbosity = High
6612 then
6613 Write_Line (" not a source of any language");
6614 end if;
6615 end Check_File_Naming_Schemes;
6617 -------------------
6618 -- Override_Kind --
6619 -------------------
6621 procedure Override_Kind (Source : Source_Id; Kind : Source_Kind) is
6622 begin
6623 -- If the file was previously already associated with a unit, change it
6625 if Source.Unit /= null
6626 and then Source.Kind in Spec_Or_Body
6627 and then Source.Unit.File_Names (Source.Kind) /= null
6628 then
6629 -- If we had another file referencing the same unit (for instance it
6630 -- was in an extended project), that source file is in fact invisible
6631 -- from now on, and in particular doesn't belong to the same unit.
6633 if Source.Unit.File_Names (Source.Kind) /= Source then
6634 Source.Unit.File_Names (Source.Kind).Unit := No_Unit_Index;
6635 end if;
6637 Source.Unit.File_Names (Source.Kind) := null;
6638 end if;
6640 Source.Kind := Kind;
6642 if Current_Verbosity = High
6643 and then Source.File /= No_File
6644 then
6645 Write_Line ("Override kind for "
6646 & Get_Name_String (Source.File)
6647 & " kind=" & Source.Kind'Img);
6648 end if;
6650 if Source.Kind in Spec_Or_Body and then Source.Unit /= null then
6651 Source.Unit.File_Names (Source.Kind) := Source;
6652 end if;
6653 end Override_Kind;
6655 ----------------
6656 -- Check_File --
6657 ----------------
6659 procedure Check_File
6660 (Project : in out Project_Processing_Data;
6661 Data : in out Tree_Processing_Data;
6662 Source_Dir_Rank : Natural;
6663 Path : Path_Name_Type;
6664 Display_Path : Path_Name_Type;
6665 File_Name : File_Name_Type;
6666 Display_File_Name : File_Name_Type;
6667 Locally_Removed : Boolean;
6668 For_All_Sources : Boolean)
6670 Name_Loc : Name_Location :=
6671 Source_Names_Htable.Get
6672 (Project.Source_Names, File_Name);
6673 Check_Name : Boolean := False;
6674 Alternate_Languages : Language_List;
6675 Language : Language_Ptr;
6676 Source : Source_Id;
6677 Src_Ind : Source_File_Index;
6678 Unit : Name_Id;
6679 Display_Language_Name : Name_Id;
6680 Lang_Kind : Language_Kind;
6681 Kind : Source_Kind := Spec;
6683 begin
6684 if Current_Verbosity = High then
6685 Write_Line ("Checking file:");
6686 Write_Str (" Path = ");
6687 Write_Line (Get_Name_String (Path));
6688 Write_Str (" Rank =");
6689 Write_Line (Source_Dir_Rank'Img);
6690 end if;
6692 if Name_Loc = No_Name_Location then
6693 Check_Name := For_All_Sources;
6695 else
6696 if Name_Loc.Found then
6698 -- Check if it is OK to have the same file name in several
6699 -- source directories.
6701 if Source_Dir_Rank = Name_Loc.Source.Source_Dir_Rank then
6702 Error_Msg_File_1 := File_Name;
6703 Error_Msg
6704 (Data.Flags,
6705 "{ is found in several source directories",
6706 Name_Loc.Location, Project.Project);
6707 end if;
6709 else
6710 Name_Loc.Found := True;
6712 Source_Names_Htable.Set
6713 (Project.Source_Names, File_Name, Name_Loc);
6715 if Name_Loc.Source = No_Source then
6716 Check_Name := True;
6718 else
6719 Name_Loc.Source.Path := (Path, Display_Path);
6721 Source_Paths_Htable.Set
6722 (Data.Tree.Source_Paths_HT,
6723 Path,
6724 Name_Loc.Source);
6726 -- Check if this is a subunit
6728 if Name_Loc.Source.Unit /= No_Unit_Index
6729 and then Name_Loc.Source.Kind = Impl
6730 then
6731 Src_Ind := Sinput.P.Load_Project_File
6732 (Get_Name_String (Display_Path));
6734 if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
6735 Override_Kind (Name_Loc.Source, Sep);
6736 end if;
6737 end if;
6739 Files_Htable.Set
6740 (Data.File_To_Source, File_Name, Name_Loc.Source);
6741 end if;
6742 end if;
6743 end if;
6745 if Check_Name then
6746 Check_File_Naming_Schemes
6747 (In_Tree => Data.Tree,
6748 Project => Project,
6749 File_Name => File_Name,
6750 Alternate_Languages => Alternate_Languages,
6751 Language => Language,
6752 Display_Language_Name => Display_Language_Name,
6753 Unit => Unit,
6754 Lang_Kind => Lang_Kind,
6755 Kind => Kind);
6757 if Language = No_Language_Index then
6759 -- A file name in a list must be a source of a language
6761 if Data.Flags.Error_On_Unknown_Language
6762 and then Name_Loc.Found
6763 then
6764 Error_Msg_File_1 := File_Name;
6765 Error_Msg
6766 (Data.Flags,
6767 "language unknown for {",
6768 Name_Loc.Location, Project.Project);
6769 end if;
6771 else
6772 Add_Source
6773 (Id => Source,
6774 Project => Project.Project,
6775 Source_Dir_Rank => Source_Dir_Rank,
6776 Lang_Id => Language,
6777 Kind => Kind,
6778 Data => Data,
6779 Alternate_Languages => Alternate_Languages,
6780 File_Name => File_Name,
6781 Display_File => Display_File_Name,
6782 Unit => Unit,
6783 Locally_Removed => Locally_Removed,
6784 Path => (Path, Display_Path));
6786 -- If it is a source specified in a list, update the entry in
6787 -- the Source_Names table.
6789 if Name_Loc.Found and then Name_Loc.Source = No_Source then
6790 Name_Loc.Source := Source;
6791 Source_Names_Htable.Set
6792 (Project.Source_Names, File_Name, Name_Loc);
6793 end if;
6794 end if;
6795 end if;
6796 end Check_File;
6798 ---------------------------------
6799 -- Expand_Subdirectory_Pattern --
6800 ---------------------------------
6802 procedure Expand_Subdirectory_Pattern
6803 (Project : Project_Id;
6804 Data : in out Tree_Processing_Data;
6805 Patterns : String_List_Id;
6806 Ignore : String_List_Id;
6807 Search_For : Search_Type;
6808 Resolve_Links : Boolean)
6810 package Recursive_Dirs is new GNAT.Dynamic_HTables.Simple_HTable
6811 (Header_Num => Header_Num,
6812 Element => Boolean,
6813 No_Element => False,
6814 Key => Path_Name_Type,
6815 Hash => Hash,
6816 Equal => "=");
6817 -- Hash table stores recursive source directories, to avoid looking
6818 -- several times, and to avoid cycles that may be introduced by symbolic
6819 -- links.
6821 File_Pattern : GNAT.Regexp.Regexp;
6822 -- Pattern to use when matching file names.
6824 Visited : Recursive_Dirs.Instance;
6826 procedure Find_Pattern
6827 (Pattern_Id : Name_Id;
6828 Rank : Natural;
6829 Location : Source_Ptr);
6830 -- Find a specific pattern
6832 function Recursive_Find_Dirs
6833 (Path : Path_Information;
6834 Rank : Natural) return Boolean;
6835 -- Search all the subdirectories (recursively) of Path.
6836 -- Return True if at least one file or directory was processed
6838 function Subdirectory_Matches
6839 (Path : Path_Information;
6840 Rank : Natural) return Boolean;
6841 -- Called when a matching directory was found. If the user is in fact
6842 -- searching for files, we then search for those files matching the
6843 -- pattern within the directory.
6844 -- Return True if at least one file or directory was processed
6846 --------------------------
6847 -- Subdirectory_Matches --
6848 --------------------------
6850 function Subdirectory_Matches
6851 (Path : Path_Information;
6852 Rank : Natural) return Boolean
6854 Dir : Dir_Type;
6855 Name : String (1 .. 250);
6856 Last : Natural;
6857 Found : Path_Information;
6858 Success : Boolean := False;
6860 begin
6861 case Search_For is
6862 when Search_Directories =>
6863 Callback (Path, Rank);
6864 return True;
6866 when Search_Files =>
6867 Open (Dir, Get_Name_String (Path.Display_Name));
6868 loop
6869 Read (Dir, Name, Last);
6870 exit when Last = 0;
6872 if Name (Name'First .. Last) /= "."
6873 and then Name (Name'First .. Last) /= ".."
6874 and then Match (Name (Name'First .. Last), File_Pattern)
6875 then
6876 Get_Name_String (Path.Display_Name);
6877 Add_Str_To_Name_Buffer (Name (Name'First .. Last));
6879 Found.Display_Name := Name_Find;
6880 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
6881 Found.Name := Name_Find;
6883 Callback (Found, Rank);
6884 Success := True;
6885 end if;
6886 end loop;
6888 Close (Dir);
6890 return Success;
6891 end case;
6892 end Subdirectory_Matches;
6894 -------------------------
6895 -- Recursive_Find_Dirs --
6896 -------------------------
6898 function Recursive_Find_Dirs
6899 (Path : Path_Information;
6900 Rank : Natural) return Boolean
6902 Path_Str : constant String := Get_Name_String (Path.Display_Name);
6903 Dir : Dir_Type;
6904 Name : String (1 .. 250);
6905 Last : Natural;
6906 Success : Boolean := False;
6908 begin
6909 if Current_Verbosity = High then
6910 Write_Str (" Looking for subdirs of """);
6911 Write_Str (Path_Str);
6912 Write_Line ("""");
6913 end if;
6915 if Recursive_Dirs.Get (Visited, Path.Name) then
6916 return Success;
6917 end if;
6919 Recursive_Dirs.Set (Visited, Path.Name, True);
6921 Success := Subdirectory_Matches (Path, Rank) or Success;
6923 Open (Dir, Path_Str);
6925 loop
6926 Read (Dir, Name, Last);
6927 exit when Last = 0;
6929 if Name (1 .. Last) /= "."
6930 and then Name (1 .. Last) /= ".."
6931 then
6932 declare
6933 Path_Name : constant String :=
6934 Normalize_Pathname
6935 (Name => Name (1 .. Last),
6936 Directory => Path_Str,
6937 Resolve_Links => Resolve_Links)
6938 & Directory_Separator;
6939 Path2 : Path_Information;
6940 OK : Boolean := True;
6942 begin
6943 if Is_Directory (Path_Name) then
6944 if Ignore /= Nil_String then
6945 declare
6946 Dir_Name : String := Name (1 .. Last);
6947 List : String_List_Id := Ignore;
6949 begin
6950 Canonical_Case_File_Name (Dir_Name);
6952 while List /= Nil_String loop
6953 Get_Name_String
6954 (Data.Tree.String_Elements.Table (List).Value);
6955 Canonical_Case_File_Name
6956 (Name_Buffer (1 .. Name_Len));
6957 OK := Name_Buffer (1 .. Name_Len) /= Dir_Name;
6958 exit when not OK;
6959 List :=
6960 Data.Tree.String_Elements.Table (List).Next;
6961 end loop;
6962 end;
6963 end if;
6965 if OK then
6966 Name_Len := 0;
6967 Add_Str_To_Name_Buffer (Path_Name);
6968 Path2.Display_Name := Name_Find;
6970 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
6971 Path2.Name := Name_Find;
6973 Success :=
6974 Recursive_Find_Dirs (Path2, Rank) or Success;
6975 end if;
6976 end if;
6977 end;
6978 end if;
6979 end loop;
6981 Close (Dir);
6983 return Success;
6985 exception
6986 when Directory_Error =>
6987 return Success;
6988 end Recursive_Find_Dirs;
6990 ------------------
6991 -- Find_Pattern --
6992 ------------------
6994 procedure Find_Pattern
6995 (Pattern_Id : Name_Id;
6996 Rank : Natural;
6997 Location : Source_Ptr)
6999 Pattern : constant String := Get_Name_String (Pattern_Id);
7000 Pattern_End : Natural := Pattern'Last;
7001 Recursive : Boolean;
7002 Dir : File_Name_Type;
7003 Path_Name : Path_Information;
7004 Dir_Exists : Boolean;
7005 Has_Error : Boolean := False;
7006 Success : Boolean;
7008 begin
7009 if Current_Verbosity = High then
7010 Write_Str ("Expand_Subdirectory_Pattern (""");
7011 Write_Str (Pattern);
7012 Write_Line (""")");
7013 end if;
7015 -- If we are looking for files, find the pattern for the files
7017 if Search_For = Search_Files then
7018 while Pattern_End >= Pattern'First
7019 and then Pattern (Pattern_End) /= '/'
7020 and then Pattern (Pattern_End) /= Directory_Separator
7021 loop
7022 Pattern_End := Pattern_End - 1;
7023 end loop;
7025 if Pattern_End = Pattern'Last then
7026 Err_Vars.Error_Msg_File_1 := File_Name_Type (Pattern_Id);
7027 Error_Or_Warning
7028 (Data.Flags, Data.Flags.Missing_Source_Files,
7029 "Missing file name or pattern in {", Location, Project);
7030 return;
7031 end if;
7033 if Current_Verbosity = High then
7034 Write_Str (" file pattern=");
7035 Write_Line (Pattern (Pattern_End + 1 .. Pattern'Last));
7036 Write_Str (" Expand directory pattern=");
7037 Write_Line (Pattern (Pattern'First .. Pattern_End));
7038 end if;
7040 File_Pattern := Compile
7041 (Pattern (Pattern_End + 1 .. Pattern'Last),
7042 Glob => True,
7043 Case_Sensitive => File_Names_Case_Sensitive);
7045 -- If we had just "*.gpr", this is equivalent to "./*.gpr"
7047 if Pattern_End > Pattern'First then
7048 Pattern_End := Pattern_End - 1; -- Skip directory separator
7049 end if;
7050 end if;
7052 Recursive :=
7053 Pattern_End - 1 >= Pattern'First
7054 and then Pattern (Pattern_End - 1 .. Pattern_End) = "**"
7055 and then (Pattern_End - 1 = Pattern'First
7056 or else Pattern (Pattern_End - 2) = '/'
7057 or else Pattern (Pattern_End - 2) = Directory_Separator);
7059 if Recursive then
7060 Pattern_End := Pattern_End - 2;
7061 if Pattern_End > Pattern'First then
7062 Pattern_End := Pattern_End - 1; -- Skip '/'
7063 end if;
7064 end if;
7066 Name_Len := Pattern_End - Pattern'First + 1;
7067 Name_Buffer (1 .. Name_Len) := Pattern (Pattern'First .. Pattern_End);
7068 Dir := Name_Find;
7070 Locate_Directory
7071 (Project => Project,
7072 Name => Dir,
7073 Path => Path_Name,
7074 Dir_Exists => Dir_Exists,
7075 Data => Data,
7076 Must_Exist => False);
7078 if not Dir_Exists then
7079 Err_Vars.Error_Msg_File_1 := Dir;
7080 Error_Or_Warning
7081 (Data.Flags, Data.Flags.Missing_Source_Files,
7082 "{ is not a valid directory", Location, Project);
7083 Has_Error := Data.Flags.Missing_Source_Files = Error;
7084 end if;
7086 if not Has_Error then
7087 -- Links have been resolved if necessary, and Path_Name
7088 -- always ends with a directory separator.
7090 if Recursive then
7091 Success := Recursive_Find_Dirs (Path_Name, Rank);
7092 else
7093 Success := Subdirectory_Matches (Path_Name, Rank);
7094 end if;
7096 if not Success then
7097 case Search_For is
7098 when Search_Directories =>
7099 null; -- Error can't occur
7101 when Search_Files =>
7102 Err_Vars.Error_Msg_File_1 := File_Name_Type (Pattern_Id);
7103 Error_Or_Warning
7104 (Data.Flags, Data.Flags.Missing_Source_Files,
7105 "file { not found", Location, Project);
7106 end case;
7107 end if;
7108 end if;
7109 end Find_Pattern;
7111 -- Local variables
7113 Pattern_Id : String_List_Id := Patterns;
7114 Element : String_Element;
7115 Rank : Natural := 1;
7117 -- Start of processing for Expand_Subdirectory_Pattern
7119 begin
7120 while Pattern_Id /= Nil_String loop
7121 Element := Data.Tree.String_Elements.Table (Pattern_Id);
7122 Find_Pattern (Element.Value, Rank, Element.Location);
7123 Rank := Rank + 1;
7124 Pattern_Id := Element.Next;
7125 end loop;
7127 Recursive_Dirs.Reset (Visited);
7128 end Expand_Subdirectory_Pattern;
7130 ------------------------
7131 -- Search_Directories --
7132 ------------------------
7134 procedure Search_Directories
7135 (Project : in out Project_Processing_Data;
7136 Data : in out Tree_Processing_Data;
7137 For_All_Sources : Boolean)
7139 Source_Dir : String_List_Id;
7140 Element : String_Element;
7141 Src_Dir_Rank : Number_List_Index;
7142 Num_Nod : Number_Node;
7143 Dir : Dir_Type;
7144 Name : String (1 .. 1_000);
7145 Last : Natural;
7146 File_Name : File_Name_Type;
7147 Display_File_Name : File_Name_Type;
7149 begin
7150 if Current_Verbosity = High then
7151 Write_Line ("Looking for sources:");
7152 end if;
7154 -- Loop through subdirectories
7156 Source_Dir := Project.Project.Source_Dirs;
7157 Src_Dir_Rank := Project.Project.Source_Dir_Ranks;
7158 while Source_Dir /= Nil_String loop
7159 begin
7160 Num_Nod := Data.Tree.Number_Lists.Table (Src_Dir_Rank);
7161 Element := Data.Tree.String_Elements.Table (Source_Dir);
7163 -- Use Element.Value in this test, not Display_Value, because we
7164 -- want the symbolic links to be resolved when appropriate.
7166 if Element.Value /= No_Name then
7167 declare
7168 Source_Directory : constant String :=
7169 Get_Name_String (Element.Value)
7170 & Directory_Separator;
7172 Dir_Last : constant Natural :=
7173 Compute_Directory_Last (Source_Directory);
7175 Display_Source_Directory : constant String :=
7176 Get_Name_String
7177 (Element.Display_Value)
7178 & Directory_Separator;
7179 -- Display_Source_Directory is to allow us to open a UTF-8
7180 -- encoded directory on Windows.
7182 begin
7183 if Current_Verbosity = High then
7184 Write_Attr
7185 ("Source_Dir",
7186 Source_Directory (Source_Directory'First .. Dir_Last));
7187 Write_Line (Num_Nod.Number'Img);
7188 end if;
7190 -- We look to every entry in the source directory
7192 Open (Dir, Display_Source_Directory);
7194 loop
7195 Read (Dir, Name, Last);
7197 exit when Last = 0;
7199 -- In fast project loading mode (without -eL), the user
7200 -- guarantees that no directory has a name which is a
7201 -- valid source name, so we can avoid doing a system call
7202 -- here. This provides a very significant speed up on
7203 -- slow file systems (remote files for instance).
7205 if not Opt.Follow_Links_For_Files
7206 or else Is_Regular_File
7207 (Display_Source_Directory & Name (1 .. Last))
7208 then
7209 if Current_Verbosity = High then
7210 Write_Str (" Checking ");
7211 Write_Line (Name (1 .. Last));
7212 end if;
7214 Name_Len := Last;
7215 Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
7216 Display_File_Name := Name_Find;
7218 if Osint.File_Names_Case_Sensitive then
7219 File_Name := Display_File_Name;
7220 else
7221 Canonical_Case_File_Name
7222 (Name_Buffer (1 .. Name_Len));
7223 File_Name := Name_Find;
7224 end if;
7226 declare
7227 Path_Name : constant String :=
7228 Normalize_Pathname
7229 (Name (1 .. Last),
7230 Directory =>
7231 Source_Directory
7232 (Source_Directory'First ..
7233 Dir_Last),
7234 Resolve_Links =>
7235 Opt.Follow_Links_For_Files,
7236 Case_Sensitive => True);
7238 Path : Path_Name_Type;
7239 FF : File_Found :=
7240 Excluded_Sources_Htable.Get
7241 (Project.Excluded, File_Name);
7242 To_Remove : Boolean := False;
7244 begin
7245 Name_Len := Path_Name'Length;
7246 Name_Buffer (1 .. Name_Len) := Path_Name;
7248 if Osint.File_Names_Case_Sensitive then
7249 Path := Name_Find;
7250 else
7251 Canonical_Case_File_Name
7252 (Name_Buffer (1 .. Name_Len));
7253 Path := Name_Find;
7254 end if;
7256 if FF /= No_File_Found then
7257 if not FF.Found then
7258 FF.Found := True;
7259 Excluded_Sources_Htable.Set
7260 (Project.Excluded, File_Name, FF);
7262 if Current_Verbosity = High then
7263 Write_Str (" excluded source """);
7264 Write_Str
7265 (Get_Name_String (Display_File_Name));
7266 Write_Line ("""");
7267 end if;
7269 -- Will mark the file as removed, but we
7270 -- still need to add it to the list: if we
7271 -- don't, the file will not appear in the
7272 -- mapping file and will cause the compiler
7273 -- to fail.
7275 To_Remove := True;
7276 end if;
7277 end if;
7279 -- Preserve the user's original casing and use of
7280 -- links. The display_value (a directory) already
7281 -- ends with a directory separator by construction,
7282 -- so no need to add one.
7284 Get_Name_String (Element.Display_Value);
7285 Get_Name_String_And_Append (Display_File_Name);
7287 Check_File
7288 (Project => Project,
7289 Source_Dir_Rank => Num_Nod.Number,
7290 Data => Data,
7291 Path => Path,
7292 Display_Path => Name_Find,
7293 File_Name => File_Name,
7294 Locally_Removed => To_Remove,
7295 Display_File_Name => Display_File_Name,
7296 For_All_Sources => For_All_Sources);
7297 end;
7298 end if;
7299 end loop;
7301 Close (Dir);
7302 end;
7303 end if;
7305 exception
7306 when Directory_Error =>
7307 null;
7308 end;
7310 Source_Dir := Element.Next;
7311 Src_Dir_Rank := Num_Nod.Next;
7312 end loop;
7314 if Current_Verbosity = High then
7315 Write_Line ("end Looking for sources.");
7316 end if;
7317 end Search_Directories;
7319 ----------------------------
7320 -- Load_Naming_Exceptions --
7321 ----------------------------
7323 procedure Load_Naming_Exceptions
7324 (Project : in out Project_Processing_Data;
7325 Data : in out Tree_Processing_Data)
7327 Source : Source_Id;
7328 Iter : Source_Iterator;
7330 begin
7331 Iter := For_Each_Source (Data.Tree, Project.Project);
7332 loop
7333 Source := Prj.Element (Iter);
7334 exit when Source = No_Source;
7336 -- An excluded file cannot also be an exception file name
7338 if Excluded_Sources_Htable.Get (Project.Excluded, Source.File) /=
7339 No_File_Found
7340 then
7341 Error_Msg_File_1 := Source.File;
7342 Error_Msg
7343 (Data.Flags,
7344 "{ cannot be both excluded and an exception file name",
7345 No_Location, Project.Project);
7346 end if;
7348 if Current_Verbosity = High then
7349 Write_Str ("Naming exception: Putting source file ");
7350 Write_Str (Get_Name_String (Source.File));
7351 Write_Line (" in Source_Names");
7352 end if;
7354 Source_Names_Htable.Set
7355 (Project.Source_Names,
7356 K => Source.File,
7357 E => Name_Location'
7358 (Name => Source.File,
7359 Location => Source.Location,
7360 Source => Source,
7361 Listed => False,
7362 Found => False));
7364 -- If this is an Ada exception, record in table Unit_Exceptions
7366 if Source.Unit /= No_Unit_Index then
7367 declare
7368 Unit_Except : Unit_Exception :=
7369 Unit_Exceptions_Htable.Get
7370 (Project.Unit_Exceptions, Source.Unit.Name);
7372 begin
7373 Unit_Except.Name := Source.Unit.Name;
7375 if Source.Kind = Spec then
7376 Unit_Except.Spec := Source.File;
7377 else
7378 Unit_Except.Impl := Source.File;
7379 end if;
7381 Unit_Exceptions_Htable.Set
7382 (Project.Unit_Exceptions, Source.Unit.Name, Unit_Except);
7383 end;
7384 end if;
7386 Next (Iter);
7387 end loop;
7388 end Load_Naming_Exceptions;
7390 ----------------------
7391 -- Look_For_Sources --
7392 ----------------------
7394 procedure Look_For_Sources
7395 (Project : in out Project_Processing_Data;
7396 Data : in out Tree_Processing_Data)
7398 Object_Files : Object_File_Names_Htable.Instance;
7399 Iter : Source_Iterator;
7400 Src : Source_Id;
7402 procedure Check_Object (Src : Source_Id);
7403 -- Check if object file name of Src is already used in the project tree,
7404 -- and report an error if so.
7406 procedure Check_Object_Files;
7407 -- Check that no two sources of this project have the same object file
7409 procedure Mark_Excluded_Sources;
7410 -- Mark as such the sources that are declared as excluded
7412 procedure Check_Missing_Sources;
7413 -- Check whether one of the languages has no sources, and report an
7414 -- error when appropriate
7416 procedure Get_Sources_From_Source_Info;
7417 -- Get the source information from the tables that were created when a
7418 -- source info fie was read.
7420 ---------------------------
7421 -- Check_Missing_Sources --
7422 ---------------------------
7424 procedure Check_Missing_Sources is
7425 Extending : constant Boolean :=
7426 Project.Project.Extends /= No_Project;
7427 Language : Language_Ptr;
7428 Source : Source_Id;
7429 Alt_Lang : Language_List;
7430 Continuation : Boolean := False;
7431 Iter : Source_Iterator;
7432 begin
7433 if not Project.Project.Externally_Built
7434 and then not Extending
7435 then
7436 Language := Project.Project.Languages;
7437 while Language /= No_Language_Index loop
7439 -- If there are no sources for this language, check if there
7440 -- are sources for which this is an alternate language.
7442 if Language.First_Source = No_Source
7443 and then (Data.Flags.Require_Sources_Other_Lang
7444 or else Language.Name = Name_Ada)
7445 then
7446 Iter := For_Each_Source (In_Tree => Data.Tree,
7447 Project => Project.Project);
7448 Source_Loop : loop
7449 Source := Element (Iter);
7450 exit Source_Loop when Source = No_Source
7451 or else Source.Language = Language;
7453 Alt_Lang := Source.Alternate_Languages;
7454 while Alt_Lang /= null loop
7455 exit Source_Loop when Alt_Lang.Language = Language;
7456 Alt_Lang := Alt_Lang.Next;
7457 end loop;
7459 Next (Iter);
7460 end loop Source_Loop;
7462 if Source = No_Source then
7463 Report_No_Sources
7464 (Project.Project,
7465 Get_Name_String (Language.Display_Name),
7466 Data,
7467 Project.Source_List_File_Location,
7468 Continuation);
7469 Continuation := True;
7470 end if;
7471 end if;
7473 Language := Language.Next;
7474 end loop;
7475 end if;
7476 end Check_Missing_Sources;
7478 ------------------
7479 -- Check_Object --
7480 ------------------
7482 procedure Check_Object (Src : Source_Id) is
7483 Source : Source_Id;
7485 begin
7486 Source := Object_File_Names_Htable.Get (Object_Files, Src.Object);
7488 -- We cannot just check on "Source /= Src", since we might have
7489 -- two different entries for the same file (and since that's
7490 -- the same file it is expected that it has the same object)
7492 if Source /= No_Source
7493 and then Source.Path /= Src.Path
7494 then
7495 Error_Msg_File_1 := Src.File;
7496 Error_Msg_File_2 := Source.File;
7497 Error_Msg
7498 (Data.Flags,
7499 "{ and { have the same object file name",
7500 No_Location, Project.Project);
7502 else
7503 Object_File_Names_Htable.Set (Object_Files, Src.Object, Src);
7504 end if;
7505 end Check_Object;
7507 ---------------------------
7508 -- Mark_Excluded_Sources --
7509 ---------------------------
7511 procedure Mark_Excluded_Sources is
7512 Source : Source_Id := No_Source;
7513 Excluded : File_Found;
7514 Proj : Project_Id;
7516 begin
7517 -- Minor optimization: if there are no excluded files, no need to
7518 -- traverse the list of sources. We cannot however also check whether
7519 -- the existing exceptions have ".Found" set to True (indicating we
7520 -- found them before) because we need to do some final processing on
7521 -- them in any case.
7523 if Excluded_Sources_Htable.Get_First (Project.Excluded) /=
7524 No_File_Found
7525 then
7526 Proj := Project.Project;
7527 while Proj /= No_Project loop
7528 Iter := For_Each_Source (Data.Tree, Proj);
7529 while Prj.Element (Iter) /= No_Source loop
7530 Source := Prj.Element (Iter);
7531 Excluded := Excluded_Sources_Htable.Get
7532 (Project.Excluded, Source.File);
7534 if Excluded /= No_File_Found then
7535 Source.Locally_Removed := True;
7536 Source.In_Interfaces := False;
7538 if Current_Verbosity = High then
7539 Write_Str ("Removing file ");
7540 Write_Line
7541 (Get_Name_String (Excluded.File)
7542 & " " & Get_Name_String (Source.Project.Name));
7543 end if;
7545 Excluded_Sources_Htable.Remove
7546 (Project.Excluded, Source.File);
7547 end if;
7549 Next (Iter);
7550 end loop;
7552 Proj := Proj.Extends;
7553 end loop;
7554 end if;
7556 -- If we have any excluded element left, that means we did not find
7557 -- the source file
7559 Excluded := Excluded_Sources_Htable.Get_First (Project.Excluded);
7560 while Excluded /= No_File_Found loop
7561 if not Excluded.Found then
7563 -- Check if the file belongs to another imported project to
7564 -- provide a better error message.
7566 Src := Find_Source
7567 (In_Tree => Data.Tree,
7568 Project => Project.Project,
7569 In_Imported_Only => True,
7570 Base_Name => Excluded.File);
7572 Err_Vars.Error_Msg_File_1 := Excluded.File;
7574 if Src = No_Source then
7575 Error_Msg
7576 (Data.Flags,
7577 "unknown file {", Excluded.Location, Project.Project);
7578 else
7579 Error_Msg
7580 (Data.Flags,
7581 "cannot remove a source from an imported project: {",
7582 Excluded.Location, Project.Project);
7583 end if;
7584 end if;
7586 Excluded := Excluded_Sources_Htable.Get_Next (Project.Excluded);
7587 end loop;
7588 end Mark_Excluded_Sources;
7590 ------------------------
7591 -- Check_Object_Files --
7592 ------------------------
7594 procedure Check_Object_Files is
7595 Iter : Source_Iterator;
7596 Src_Id : Source_Id;
7597 Src_Ind : Source_File_Index;
7599 begin
7600 Iter := For_Each_Source (Data.Tree);
7601 loop
7602 Src_Id := Prj.Element (Iter);
7603 exit when Src_Id = No_Source;
7605 if Is_Compilable (Src_Id)
7606 and then Src_Id.Language.Config.Object_Generated
7607 and then Is_Extending (Project.Project, Src_Id.Project)
7608 then
7609 if Src_Id.Unit = No_Unit_Index then
7610 if Src_Id.Kind = Impl then
7611 Check_Object (Src_Id);
7612 end if;
7614 else
7615 case Src_Id.Kind is
7616 when Spec =>
7617 if Other_Part (Src_Id) = No_Source then
7618 Check_Object (Src_Id);
7619 end if;
7621 when Sep =>
7622 null;
7624 when Impl =>
7625 if Other_Part (Src_Id) /= No_Source then
7626 Check_Object (Src_Id);
7628 else
7629 -- Check if it is a subunit
7631 Src_Ind :=
7632 Sinput.P.Load_Project_File
7633 (Get_Name_String (Src_Id.Path.Display_Name));
7635 if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
7636 Override_Kind (Src_Id, Sep);
7637 else
7638 Check_Object (Src_Id);
7639 end if;
7640 end if;
7641 end case;
7642 end if;
7643 end if;
7645 Next (Iter);
7646 end loop;
7647 end Check_Object_Files;
7649 ----------------------------------
7650 -- Get_Sources_From_Source_Info --
7651 ----------------------------------
7653 procedure Get_Sources_From_Source_Info is
7654 Iter : Source_Info_Iterator;
7655 Src : Source_Info;
7656 Id : Source_Id;
7657 Lang_Id : Language_Ptr;
7658 begin
7659 Initialize (Iter, Project.Project.Name);
7661 loop
7662 Src := Source_Info_Of (Iter);
7664 exit when Src = No_Source_Info;
7666 Id := new Source_Data;
7668 Id.Project := Project.Project;
7670 Lang_Id := Project.Project.Languages;
7671 while Lang_Id /= No_Language_Index and then
7672 Lang_Id.Name /= Src.Language
7673 loop
7674 Lang_Id := Lang_Id.Next;
7675 end loop;
7677 if Lang_Id = No_Language_Index then
7678 Prj.Com.Fail
7679 ("unknown language " &
7680 Get_Name_String (Src.Language) &
7681 " for project " &
7682 Get_Name_String (Src.Project) &
7683 " in source info file");
7684 end if;
7686 Id.Language := Lang_Id;
7687 Id.Kind := Src.Kind;
7689 Id.Index := Src.Index;
7691 Id.Path :=
7692 (Path_Name_Type (Src.Display_Path_Name),
7693 Path_Name_Type (Src.Path_Name));
7695 Name_Len := 0;
7696 Add_Str_To_Name_Buffer
7697 (Ada.Directories.Simple_Name
7698 (Get_Name_String (Src.Path_Name)));
7699 Id.File := Name_Find;
7701 Id.Next_With_File_Name :=
7702 Source_Files_Htable.Get (Data.Tree.Source_Files_HT, Id.File);
7703 Source_Files_Htable.Set (Data.Tree.Source_Files_HT, Id.File, Id);
7705 Name_Len := 0;
7706 Add_Str_To_Name_Buffer
7707 (Ada.Directories.Simple_Name
7708 (Get_Name_String (Src.Display_Path_Name)));
7709 Id.Display_File := Name_Find;
7711 Id.Dep_Name := Dependency_Name
7712 (Id.File, Id.Language.Config.Dependency_Kind);
7713 Id.Naming_Exception := Src.Naming_Exception;
7714 Id.Object := Object_Name
7715 (Id.File, Id.Language.Config.Object_File_Suffix);
7716 Id.Switches := Switches_Name (Id.File);
7718 -- Add the source id to the Unit_Sources_HT hash table, if the
7719 -- unit name is not null.
7721 if Src.Kind /= Sep and then Src.Unit_Name /= No_Name then
7723 declare
7724 UData : Unit_Index :=
7725 Units_Htable.Get (Data.Tree.Units_HT, Src.Unit_Name);
7726 begin
7727 if UData = No_Unit_Index then
7728 UData := new Unit_Data;
7729 UData.Name := Src.Unit_Name;
7730 Units_Htable.Set
7731 (Data.Tree.Units_HT, Src.Unit_Name, UData);
7732 end if;
7734 Id.Unit := UData;
7735 end;
7737 -- Note that this updates Unit information as well
7739 Override_Kind (Id, Id.Kind);
7740 end if;
7742 if Src.Index /= 0 then
7743 Project.Project.Has_Multi_Unit_Sources := True;
7744 end if;
7746 -- Add the source to the language list
7748 Id.Next_In_Lang := Id.Language.First_Source;
7749 Id.Language.First_Source := Id;
7751 Files_Htable.Set (Data.File_To_Source, Id.File, Id);
7753 Next (Iter);
7754 end loop;
7755 end Get_Sources_From_Source_Info;
7757 -- Start of processing for Look_For_Sources
7759 begin
7760 if Data.Tree.Source_Info_File_Exists then
7761 Get_Sources_From_Source_Info;
7763 else
7764 if Project.Project.Source_Dirs /= Nil_String then
7765 Find_Excluded_Sources (Project, Data);
7767 if Project.Project.Languages /= No_Language_Index then
7768 Load_Naming_Exceptions (Project, Data);
7769 Find_Sources (Project, Data);
7770 Mark_Excluded_Sources;
7771 Check_Object_Files;
7772 Check_Missing_Sources;
7773 end if;
7774 end if;
7776 Object_File_Names_Htable.Reset (Object_Files);
7777 end if;
7778 end Look_For_Sources;
7780 ------------------
7781 -- Path_Name_Of --
7782 ------------------
7784 function Path_Name_Of
7785 (File_Name : File_Name_Type;
7786 Directory : Path_Name_Type) return String
7788 Result : String_Access;
7789 The_Directory : constant String := Get_Name_String (Directory);
7791 begin
7792 Get_Name_String (File_Name);
7793 Result :=
7794 Locate_Regular_File
7795 (File_Name => Name_Buffer (1 .. Name_Len),
7796 Path => The_Directory);
7798 if Result = null then
7799 return "";
7800 else
7801 declare
7802 R : String := Result.all;
7803 begin
7804 Free (Result);
7805 Canonical_Case_File_Name (R);
7806 return R;
7807 end;
7808 end if;
7809 end Path_Name_Of;
7811 -------------------
7812 -- Remove_Source --
7813 -------------------
7815 procedure Remove_Source
7816 (Tree : Project_Tree_Ref;
7817 Id : Source_Id;
7818 Replaced_By : Source_Id)
7820 Source : Source_Id;
7822 begin
7823 if Current_Verbosity = High then
7824 Write_Str ("Removing source ");
7825 Write_Str (Get_Name_String (Id.File));
7827 if Id.Index /= 0 then
7828 Write_Str (" at" & Id.Index'Img);
7829 end if;
7831 Write_Eol;
7832 end if;
7834 if Replaced_By /= No_Source then
7835 Id.Replaced_By := Replaced_By;
7836 Replaced_By.Declared_In_Interfaces := Id.Declared_In_Interfaces;
7838 if Id.File /= Replaced_By.File then
7839 declare
7840 Replacement : constant File_Name_Type :=
7841 Replaced_Source_HTable.Get
7842 (Tree.Replaced_Sources, Id.File);
7844 begin
7845 Replaced_Source_HTable.Set
7846 (Tree.Replaced_Sources, Id.File, Replaced_By.File);
7848 if Replacement = No_File then
7849 Tree.Replaced_Source_Number :=
7850 Tree.Replaced_Source_Number + 1;
7851 end if;
7852 end;
7853 end if;
7854 end if;
7856 Id.In_Interfaces := False;
7857 Id.Locally_Removed := True;
7859 -- ??? Should we remove the source from the unit ? The file is not used,
7860 -- so probably should not be referenced from the unit. On the other hand
7861 -- it might give useful additional info
7862 -- if Id.Unit /= null then
7863 -- Id.Unit.File_Names (Id.Kind) := null;
7864 -- end if;
7866 Source := Id.Language.First_Source;
7868 if Source = Id then
7869 Id.Language.First_Source := Id.Next_In_Lang;
7871 else
7872 while Source.Next_In_Lang /= Id loop
7873 Source := Source.Next_In_Lang;
7874 end loop;
7876 Source.Next_In_Lang := Id.Next_In_Lang;
7877 end if;
7878 end Remove_Source;
7880 -----------------------
7881 -- Report_No_Sources --
7882 -----------------------
7884 procedure Report_No_Sources
7885 (Project : Project_Id;
7886 Lang_Name : String;
7887 Data : Tree_Processing_Data;
7888 Location : Source_Ptr;
7889 Continuation : Boolean := False)
7891 begin
7892 case Data.Flags.When_No_Sources is
7893 when Silent =>
7894 null;
7896 when Warning | Error =>
7897 declare
7898 Msg : constant String :=
7899 "<there are no " &
7900 Lang_Name &
7901 " sources in this project";
7903 begin
7904 Error_Msg_Warn := Data.Flags.When_No_Sources = Warning;
7906 if Continuation then
7907 Error_Msg (Data.Flags, "\" & Msg, Location, Project);
7908 else
7909 Error_Msg (Data.Flags, Msg, Location, Project);
7910 end if;
7911 end;
7912 end case;
7913 end Report_No_Sources;
7915 ----------------------
7916 -- Show_Source_Dirs --
7917 ----------------------
7919 procedure Show_Source_Dirs
7920 (Project : Project_Id;
7921 In_Tree : Project_Tree_Ref)
7923 Current : String_List_Id;
7924 Element : String_Element;
7926 begin
7927 Write_Line ("Source_Dirs:");
7929 Current := Project.Source_Dirs;
7930 while Current /= Nil_String loop
7931 Element := In_Tree.String_Elements.Table (Current);
7932 Write_Str (" ");
7933 Write_Line (Get_Name_String (Element.Display_Value));
7934 Current := Element.Next;
7935 end loop;
7937 Write_Line ("end Source_Dirs.");
7938 end Show_Source_Dirs;
7940 ---------------------------
7941 -- Process_Naming_Scheme --
7942 ---------------------------
7944 procedure Process_Naming_Scheme
7945 (Tree : Project_Tree_Ref;
7946 Root_Project : Project_Id;
7947 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
7948 Flags : Processing_Flags)
7950 procedure Recursive_Check
7951 (Project : Project_Id;
7952 Data : in out Tree_Processing_Data);
7953 -- Check_Naming_Scheme for the project
7955 ---------------------
7956 -- Recursive_Check --
7957 ---------------------
7959 procedure Recursive_Check
7960 (Project : Project_Id;
7961 Data : in out Tree_Processing_Data)
7963 begin
7964 if Verbose_Mode then
7965 Write_Str ("Processing_Naming_Scheme for project """);
7966 Write_Str (Get_Name_String (Project.Name));
7967 Write_Line ("""");
7968 end if;
7970 Prj.Nmsc.Check (Project, Data);
7971 end Recursive_Check;
7973 procedure Check_All_Projects is new
7974 For_Every_Project_Imported (Tree_Processing_Data, Recursive_Check);
7976 Data : Tree_Processing_Data;
7978 -- Start of processing for Process_Naming_Scheme
7979 begin
7980 Lib_Data_Table.Init;
7981 Initialize (Data, Tree => Tree, Node_Tree => Node_Tree, Flags => Flags);
7982 Check_All_Projects (Root_Project, Data, Imported_First => True);
7983 Free (Data);
7985 -- Adjust language configs for projects that are extended
7987 declare
7988 List : Project_List;
7989 Proj : Project_Id;
7990 Exte : Project_Id;
7991 Lang : Language_Ptr;
7992 Elng : Language_Ptr;
7994 begin
7995 List := Tree.Projects;
7996 while List /= null loop
7997 Proj := List.Project;
7998 Exte := Proj;
7999 while Exte.Extended_By /= No_Project loop
8000 Exte := Exte.Extended_By;
8001 end loop;
8003 if Exte /= Proj then
8004 Lang := Proj.Languages;
8006 if Lang /= No_Language_Index then
8007 loop
8008 Elng := Get_Language_From_Name
8009 (Exte, Get_Name_String (Lang.Name));
8010 exit when Elng /= No_Language_Index;
8011 Exte := Exte.Extends;
8012 end loop;
8014 if Elng /= Lang then
8015 Lang.Config := Elng.Config;
8016 end if;
8017 end if;
8018 end if;
8020 List := List.Next;
8021 end loop;
8022 end;
8023 end Process_Naming_Scheme;
8025 end Prj.Nmsc;