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