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