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