| blob | a224e7d038448808e5c4c0fa1bbe4bd2941712cd |
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-2016, 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 ------------------------------------------------------------------------------
55 -- Used in Check_Library for continuation error messages at the same
56 -- location.
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.
63 Location : Source_Ptr;
64 Source : Source_Id := No_Source;
65 Listed : Boolean := False;
66 Found : Boolean := False;
67 end record;
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);
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,
83 -- File name information found in string list attribute (Source_Files or
84 -- Source_List_File). Used to check that all referenced files were indeed
85 -- found on the disk.
87 type Unit_Exception is record
88 Name : Name_Id;
89 -- Key is duplicated, so that it is known when using functions Get_First
90 -- and Get_Next, as these functions only return an Element.
92 Spec : File_Name_Type;
93 Impl : File_Name_Type;
94 end record;
96 No_Unit_Exception : constant Unit_Exception := (No_Name, No_File, No_File);
98 package Unit_Exceptions_Htable is new GNAT.Dynamic_HTables.Simple_HTable
99 (Header_Num => Header_Num,
100 Element => Unit_Exception,
101 No_Element => No_Unit_Exception,
102 Key => Name_Id,
103 Hash => Hash,
105 -- Record special naming schemes for Ada units (name of spec file and name
106 -- of implementation file). The elements in this list come from the naming
107 -- exceptions specified in the project files.
109 type File_Found is record
110 File : File_Name_Type := No_File;
111 Excl_File : File_Name_Type := No_File;
112 Excl_Line : Natural := 0;
113 Found : Boolean := False;
114 Location : Source_Ptr := No_Location;
115 end record;
117 No_File_Found : constant File_Found :=
118 (No_File, No_File, 0, False, No_Location);
120 package Excluded_Sources_Htable is new GNAT.Dynamic_HTables.Simple_HTable
121 (Header_Num => Header_Num,
122 Element => File_Found,
123 No_Element => No_File_Found,
124 Key => File_Name_Type,
125 Hash => Hash,
127 -- A hash table to store the base names of excluded files, if any
129 package Object_File_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
130 (Header_Num => Header_Num,
131 Element => Source_Id,
132 No_Element => No_Source,
133 Key => File_Name_Type,
134 Hash => Hash,
136 -- A hash table to store the object file names for a project, to check that
137 -- two different sources have different object file names.
139 type Project_Processing_Data is record
140 Project : Project_Id;
141 Source_Names : Source_Names_Htable.Instance;
142 Unit_Exceptions : Unit_Exceptions_Htable.Instance;
143 Excluded : Excluded_Sources_Htable.Instance;
145 Source_List_File_Location : Source_Ptr;
146 -- Location of the Source_List_File attribute, for error messages
147 end record;
148 -- This is similar to Tree_Processing_Data, but contains project-specific
149 -- information which is only useful while processing the project, and can
150 -- be discarded as soon as we have finished processing the project
152 type Tree_Processing_Data is record
153 Tree : Project_Tree_Ref;
154 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
155 Flags : Prj.Processing_Flags;
156 In_Aggregate_Lib : Boolean;
157 end record;
158 -- Temporary data which is needed while parsing a project. It does not need
159 -- to be kept in memory once a project has been fully loaded, but is
160 -- necessary while performing consistency checks (duplicate sources,...)
161 -- This data must be initialized before processing any project, and the
162 -- same data is used for processing all projects in the tree.
164 type Lib_Data is record
165 Name : Name_Id;
166 Proj : Project_Id;
167 Tree : Project_Tree_Ref;
168 end record;
170 package Lib_Data_Table is new GNAT.Table
171 (Table_Component_Type => Lib_Data,
172 Table_Index_Type => Natural,
173 Table_Low_Bound => 1,
174 Table_Initial => 10,
175 Table_Increment => 100);
176 -- A table to record library names in order to check that two library
177 -- projects do not have the same library names.
179 procedure Initialize
180 (Data : out Tree_Processing_Data;
181 Tree : Project_Tree_Ref;
182 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
183 Flags : Prj.Processing_Flags);
184 -- Initialize Data
186 procedure Free (Data : in out Tree_Processing_Data);
187 -- Free the memory occupied by Data
189 procedure Initialize
190 (Data : in out Project_Processing_Data;
191 Project : Project_Id);
192 procedure Free (Data : in out Project_Processing_Data);
193 -- Initialize or free memory for a project-specific data
195 procedure Find_Excluded_Sources
196 (Project : in out Project_Processing_Data;
197 Data : in out Tree_Processing_Data);
198 -- Find the list of files that should not be considered as source files
199 -- for this project. Sets the list in the Project.Excluded_Sources_Htable.
201 procedure Override_Kind (Source : Source_Id; Kind : Source_Kind);
202 -- Override the reference kind for a source file. This properly updates
203 -- the unit data if necessary.
205 procedure Load_Naming_Exceptions
206 (Project : in out Project_Processing_Data;
207 Data : in out Tree_Processing_Data);
208 -- All source files in Data.First_Source are considered as naming
209 -- exceptions, and copied into the Source_Names and Unit_Exceptions tables
210 -- as appropriate.
212 type Search_Type is (Search_Files, Search_Directories);
214 generic
215 with procedure Callback
216 (Path : Path_Information;
217 Pattern_Index : Natural);
218 procedure Expand_Subdirectory_Pattern
219 (Project : Project_Id;
220 Data : in out Tree_Processing_Data;
221 Patterns : String_List_Id;
222 Ignore : String_List_Id;
223 Search_For : Search_Type;
224 Resolve_Links : Boolean);
225 -- Search the subdirectories of Project's directory for files or
226 -- directories that match the globbing patterns found in Patterns (for
228 -- Source_Dirs or Excluded_Source_Dirs attributes.
229 --
230 -- Every time such a file or directory is found, the callback is called.
231 -- Resolve_Links indicates whether we should resolve links while
232 -- normalizing names.
233 --
234 -- In the callback, Pattern_Index is the index within Patterns where the
235 -- expanded pattern was found (1 for the first element of Patterns and
236 -- all its matching directories, then 2,...).
237 --
238 -- We use a generic and not an access-to-subprogram because in some cases
239 -- this code is compiled with the restriction No_Implicit_Dynamic_Code.
240 -- An error message is raised if a pattern does not match any file.
242 procedure Add_Source
243 (Id : out Source_Id;
244 Data : in out Tree_Processing_Data;
245 Project : Project_Id;
246 Source_Dir_Rank : Natural;
247 Lang_Id : Language_Ptr;
248 Kind : Source_Kind;
249 File_Name : File_Name_Type;
250 Display_File : File_Name_Type;
251 Naming_Exception : Naming_Exception_Type := No;
252 Path : Path_Information := No_Path_Information;
253 Alternate_Languages : Language_List := null;
254 Unit : Name_Id := No_Name;
255 Index : Int := 0;
256 Locally_Removed : Boolean := False;
257 Location : Source_Ptr := No_Location);
258 -- Add a new source to the different lists: list of all sources in the
259 -- project tree, list of source of a project and list of sources of a
260 -- language. If Path is specified, the file is also added to
261 -- Source_Paths_HT. Location is used for error messages
263 function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type;
264 -- Same as Osint.Canonical_Case_File_Name but applies to Name_Id.
265 -- This alters Name_Buffer.
267 function Suffix_Matches
268 (Filename : String;
269 Suffix : File_Name_Type) return Boolean;
270 -- True if the file name ends with the given suffix. Always returns False
271 -- if Suffix is No_Name.
273 procedure Replace_Into_Name_Buffer
274 (Str : String;
275 Pattern : String;
276 Replacement : Character);
277 -- Copy Str into Name_Buffer, replacing Pattern with Replacement. Str is
278 -- converted to lower-case at the same time.
280 procedure Check_Abstract_Project
281 (Project : Project_Id;
282 Data : in out Tree_Processing_Data);
283 -- Check abstract projects attributes
285 procedure Check_Configuration
286 (Project : Project_Id;
287 Data : in out Tree_Processing_Data);
288 -- Check the configuration attributes for the project
290 procedure Check_If_Externally_Built
291 (Project : Project_Id;
292 Data : in out Tree_Processing_Data);
293 -- Check attribute Externally_Built of project Project in project tree
296 procedure Check_Interfaces
297 (Project : Project_Id;
298 Data : in out Tree_Processing_Data);
299 -- If a list of sources is specified in attribute Interfaces, set
300 -- In_Interfaces only for the sources specified in the list.
302 procedure Check_Library_Attributes
303 (Project : Project_Id;
304 Data : in out Tree_Processing_Data);
305 -- Check the library attributes of project Project in project tree
306 -- and modify its data Data accordingly.
308 procedure Check_Package_Naming
309 (Project : Project_Id;
310 Data : in out Tree_Processing_Data);
311 -- Check the naming scheme part of Data, and initialize the naming scheme
312 -- data in the config of the various languages.
314 procedure Check_Programming_Languages
315 (Project : Project_Id;
316 Data : in out Tree_Processing_Data);
317 -- Check attribute Languages for the project with data Data in project
318 -- tree Data.Tree and set the components of Data for all the programming
319 -- languages indicated in attribute Languages, if any.
321 procedure Check_Stand_Alone_Library
322 (Project : Project_Id;
323 Data : in out Tree_Processing_Data);
324 -- Check if project Project in project tree Data.Tree is a Stand-Alone
325 -- Library project, and modify its data Data accordingly if it is one.
327 procedure Check_Unit_Name (Name : String; Unit : out Name_Id);
328 -- Check that a name is a valid unit name
330 function Compute_Directory_Last (Dir : String) return Natural;
331 -- Return the index of the last significant character in Dir. This is used
332 -- to avoid duplicate '/' (slash) characters at the end of directory names.
334 procedure Search_Directories
335 (Project : in out Project_Processing_Data;
336 Data : in out Tree_Processing_Data;
337 For_All_Sources : Boolean);
338 -- Search the source directories to find the sources. If For_All_Sources is
339 -- True, check each regular file name against the naming schemes of the
340 -- various languages. Otherwise consider only the file names in hash table
341 -- Source_Names. If Allow_Duplicate_Basenames then files with identical
342 -- base names are permitted within a project for source-based languages
343 -- (never for unit based languages).
345 procedure Check_File
346 (Project : in out Project_Processing_Data;
347 Data : in out Tree_Processing_Data;
348 Source_Dir_Rank : Natural;
349 Path : Path_Name_Type;
350 Display_Path : Path_Name_Type;
351 File_Name : File_Name_Type;
352 Display_File_Name : File_Name_Type;
353 Locally_Removed : Boolean;
354 For_All_Sources : Boolean);
355 -- Check if file File_Name is a valid source of the project. This is used
356 -- in multi-language mode only. When the file matches one of the naming
357 -- schemes, it is added to various htables through Add_Source and to
358 -- Source_Paths_Htable.
359 --
360 -- File_Name is the same as Display_File_Name, but has been normalized.
361 -- They do not include the directory information.
362 --
363 -- Path and Display_Path on the other hand are the full path to the file.
364 -- Path must have been normalized (canonical casing and possibly links
365 -- resolved).
366 --
367 -- Source_Directory is the directory in which the file was found. It is
368 -- neither normalized nor has had links resolved, and must not end with a
369 -- a directory separator, to avoid duplicates later on.
370 --
371 -- If For_All_Sources is True, then all possible file names are analyzed
372 -- otherwise only those currently set in the Source_Names hash table.
374 procedure Check_File_Naming_Schemes
375 (Project : Project_Processing_Data;
376 File_Name : File_Name_Type;
377 Alternate_Languages : out Language_List;
378 Language : out Language_Ptr;
379 Display_Language_Name : out Name_Id;
380 Unit : out Name_Id;
381 Lang_Kind : out Language_Kind;
382 Kind : out Source_Kind);
383 -- Check if the file name File_Name conforms to one of the naming schemes
384 -- of the project. If the file does not match one of the naming schemes,
385 -- set Language to No_Language_Index. Filename is the name of the file
386 -- being investigated. It has been normalized (case-folded). File_Name is
387 -- the same value.
389 procedure Get_Directories
390 (Project : Project_Id;
391 Data : in out Tree_Processing_Data);
392 -- Get the object directory, the exec directory and the source directories
393 -- of a project.
395 procedure Get_Mains
396 (Project : Project_Id;
397 Data : in out Tree_Processing_Data);
398 -- Get the mains of a project from attribute Main, if it exists, and put
399 -- them in the project data.
401 procedure Get_Sources_From_File
402 (Path : String;
403 Location : Source_Ptr;
404 Project : in out Project_Processing_Data;
405 Data : in out Tree_Processing_Data);
406 -- Get the list of sources from a text file and put them in hash table
407 -- Source_Names.
409 procedure Find_Sources
410 (Project : in out Project_Processing_Data;
411 Data : in out Tree_Processing_Data);
412 -- Process the Source_Files and Source_List_File attributes, and store the
413 -- list of source files into the Source_Names htable. When these attributes
414 -- are not defined, find all files matching the naming schemes in the
415 -- source directories. If Allow_Duplicate_Basenames, then files with the
416 -- same base names are authorized within a project for source-based
417 -- languages (never for unit based languages)
419 procedure Compute_Unit_Name
420 (File_Name : File_Name_Type;
421 Naming : Lang_Naming_Data;
422 Kind : out Source_Kind;
423 Unit : out Name_Id;
424 Project : Project_Processing_Data);
425 -- Check whether the file matches the naming scheme. If it does,
426 -- compute its unit name. If Unit is set to No_Name on exit, none of the
427 -- other out parameters are relevant.
429 procedure Check_Illegal_Suffix
430 (Project : Project_Id;
431 Suffix : File_Name_Type;
432 Dot_Replacement : File_Name_Type;
433 Attribute_Name : String;
434 Location : Source_Ptr;
435 Data : in out Tree_Processing_Data);
436 -- Display an error message if the given suffix is illegal for some reason.
437 -- The name of the attribute we are testing is specified in Attribute_Name,
438 -- which is used in the error message. Location is the location where the
439 -- suffix is defined.
441 procedure Locate_Directory
442 (Project : Project_Id;
443 Name : File_Name_Type;
444 Path : out Path_Information;
445 Dir_Exists : out Boolean;
446 Data : in out Tree_Processing_Data;
448 Location : Source_Ptr := No_Location;
449 Must_Exist : Boolean := True;
450 Externally_Built : Boolean := False);
451 -- Locate a directory. Name is the directory name. Relative paths are
452 -- resolved relative to the project's directory. If the directory does not
453 -- exist and Setup_Projects is True and Create is a non null string, an
454 -- attempt is made to create the directory. If the directory does not
455 -- exist, it is either created if Setup_Projects is False (and then
456 -- returned), or simply returned without checking for its existence (if
457 -- Must_Exist is False) or No_Path_Information is returned. In all cases,
458 -- Dir_Exists indicates whether the directory now exists. Create is also
459 -- used for debugging traces to show which path we are computing.
461 procedure Look_For_Sources
462 (Project : in out Project_Processing_Data;
463 Data : in out Tree_Processing_Data);
464 -- Find all the sources of project Project in project tree Data.Tree and
465 -- update its Data accordingly. This assumes that the special naming
466 -- exceptions have already been processed.
468 function Path_Name_Of
469 (File_Name : File_Name_Type;
470 Directory : Path_Name_Type) return String;
471 -- Returns the path name of a (non project) file. Returns an empty string
472 -- if file cannot be found.
474 procedure Remove_Source
475 (Tree : Project_Tree_Ref;
476 Id : Source_Id;
477 Replaced_By : Source_Id);
478 -- Remove a file from the list of sources of a project. This might be
479 -- because the file is replaced by another one in an extending project,
480 -- or because a file was added as a naming exception but was not found
481 -- in the end.
483 procedure Report_No_Sources
484 (Project : Project_Id;
485 Lang_Name : String;
486 Data : Tree_Processing_Data;
487 Location : Source_Ptr;
488 Continuation : Boolean := False);
489 -- Report an error or a warning depending on the value of When_No_Sources
490 -- when there are no sources for language Lang_Name.
492 procedure Show_Source_Dirs
493 (Project : Project_Id;
494 Shared : Shared_Project_Tree_Data_Access);
495 -- List all the source directories of a project
497 procedure Write_Attr (Name, Value : String);
498 -- Debug print a value for a specific property. Does nothing when not in
499 -- debug mode
501 procedure Error_Or_Warning
502 (Flags : Processing_Flags;
503 Kind : Error_Warning;
504 Msg : String;
505 Location : Source_Ptr;
506 Project : Project_Id);
507 -- Emits either an error or warning message (or nothing), depending on Kind
509 function No_Space_Img (N : Natural) return String;
510 -- Image of a Natural without the initial space
512 ----------------------
513 -- Error_Or_Warning --
514 ----------------------
516 procedure Error_Or_Warning
517 (Flags : Processing_Flags;
518 Kind : Error_Warning;
519 Msg : String;
520 Location : Source_Ptr;
521 Project : Project_Id) is
522 begin
523 case Kind is
524 when Error => Error_Msg (Flags, Msg, Location, Project);
526 when Silent => null;
527 end case;
528 end Error_Or_Warning;
530 ------------------------------
531 -- Replace_Into_Name_Buffer --
532 ------------------------------
534 procedure Replace_Into_Name_Buffer
535 (Str : String;
536 Pattern : String;
537 Replacement : Character)
538 is
539 Max : constant Integer := Str'Last - Pattern'Length + 1;
540 J : Positive;
542 begin
543 Name_Len := 0;
545 J := Str'First;
546 while J <= Str'Last loop
547 Name_Len := Name_Len + 1;
549 if J <= Max and then Str (J .. J + Pattern'Length - 1) = Pattern then
550 Name_Buffer (Name_Len) := Replacement;
551 J := J + Pattern'Length;
552 else
553 Name_Buffer (Name_Len) := GNAT.Case_Util.To_Lower (Str (J));
554 J := J + 1;
555 end if;
556 end loop;
557 end Replace_Into_Name_Buffer;
559 --------------------
560 -- Suffix_Matches --
561 --------------------
563 function Suffix_Matches
564 (Filename : String;
565 Suffix : File_Name_Type) return Boolean
566 is
567 Min_Prefix_Length : Natural := 0;
569 begin
570 if Suffix = No_File or else Suffix = Empty_File then
571 return False;
572 end if;
574 declare
575 Suf : String := Get_Name_String (Suffix);
577 begin
578 -- On non case-sensitive systems, use proper suffix casing
580 Canonical_Case_File_Name (Suf);
582 -- The file name must end with the suffix (which is not an extension)
584 -- same name. To avoid dummy cases, though, a suffix starting with
585 -- '.' requires a file that is at least one character longer ('.cpp'
586 -- should not match a file with the same name).
588 if Suf (Suf'First) = '.' then
589 Min_Prefix_Length := 1;
590 end if;
592 return Filename'Length >= Suf'Length + Min_Prefix_Length
593 and then
594 Filename (Filename'Last - Suf'Length + 1 .. Filename'Last) = Suf;
595 end;
596 end Suffix_Matches;
598 ----------------
599 -- Write_Attr --
600 ----------------
602 procedure Write_Attr (Name, Value : String) is
603 begin
604 if Current_Verbosity = High then
606 end if;
607 end Write_Attr;
609 ----------------
610 -- Add_Source --
611 ----------------
613 procedure Add_Source
614 (Id : out Source_Id;
615 Data : in out Tree_Processing_Data;
616 Project : Project_Id;
617 Source_Dir_Rank : Natural;
618 Lang_Id : Language_Ptr;
619 Kind : Source_Kind;
620 File_Name : File_Name_Type;
621 Display_File : File_Name_Type;
622 Naming_Exception : Naming_Exception_Type := No;
623 Path : Path_Information := No_Path_Information;
624 Alternate_Languages : Language_List := null;
625 Unit : Name_Id := No_Name;
626 Index : Int := 0;
627 Locally_Removed : Boolean := False;
628 Location : Source_Ptr := No_Location)
629 is
630 Config : constant Language_Config := Lang_Id.Config;
631 UData : Unit_Index;
632 Add_Src : Boolean;
633 Source : Source_Id;
634 Prev_Unit : Unit_Index := No_Unit_Index;
635 Source_To_Replace : Source_Id := No_Source;
637 begin
638 -- Check if the same file name or unit is used in the prj tree
640 Add_Src := True;
642 if Unit /= No_Name then
643 Prev_Unit := Units_Htable.Get (Data.Tree.Units_HT, Unit);
644 end if;
646 if Prev_Unit /= No_Unit_Index
647 and then (Kind = Impl or else Kind = Spec)
648 and then Prev_Unit.File_Names (Kind) /= null
649 then
650 -- Suspicious, we need to check later whether this is authorized
652 Add_Src := False;
653 Source := Prev_Unit.File_Names (Kind);
655 else
656 Source := Source_Files_Htable.Get
657 (Data.Tree.Source_Files_HT, File_Name);
659 if Source /= No_Source and then Source.Index = Index then
660 Add_Src := False;
661 end if;
662 end if;
664 -- Always add the source if it is locally removed, to avoid incorrect
665 -- duplicate checks.
667 if Locally_Removed then
668 Add_Src := True;
670 -- A locally removed source may first replace a source in a project
671 -- being extended.
673 if Source /= No_Source
674 and then Is_Extending (Project, Source.Project)
675 and then Naming_Exception /= Inherited
676 then
677 Source_To_Replace := Source;
678 end if;
680 else
681 -- Duplication of file/unit in same project is allowed if order of
682 -- source directories is known, or if there is no compiler for the
683 -- language.
685 if Add_Src = False then
686 Add_Src := True;
688 if Project = Source.Project then
689 if Prev_Unit = No_Unit_Index then
690 if Data.Flags.Allow_Duplicate_Basenames then
691 Add_Src := True;
693 elsif Lang_Id.Config.Compiler_Driver = Empty_File then
694 Add_Src := True;
696 elsif Source_Dir_Rank /= Source.Source_Dir_Rank then
697 Add_Src := False;
699 else
700 Error_Msg_File_1 := File_Name;
701 Error_Msg
702 (Data.Flags, "duplicate source file name {",
703 Location, Project);
704 Add_Src := False;
705 end if;
707 else
708 if Source_Dir_Rank /= Source.Source_Dir_Rank then
709 Add_Src := False;
711 -- We might be seeing the same file through a different
712 -- path (for instance because of symbolic links).
714 elsif Source.Path.Name /= Path.Name then
715 if not Source.Duplicate_Unit then
716 Error_Msg_Name_1 := Unit;
717 Error_Msg
718 (Data.Flags,
720 Location,
721 Project);
722 Source.Duplicate_Unit := True;
723 end if;
725 Add_Src := False;
726 end if;
727 end if;
729 -- Do not allow the same unit name in different projects,
730 -- except if one is extending the other.
732 -- For a file based language, the same file name replaces a
733 -- file in a project being extended, but it is allowed to have
734 -- the same file name in unrelated projects.
736 elsif Is_Extending (Project, Source.Project) then
737 if not Locally_Removed and then Naming_Exception /= Inherited
738 then
739 Source_To_Replace := Source;
740 end if;
742 elsif Prev_Unit /= No_Unit_Index
743 and then Prev_Unit.File_Names (Kind) /= null
744 and then not Source.Locally_Removed
745 and then Source.Replaced_By = No_Source
746 and then not Data.In_Aggregate_Lib
747 then
748 -- Path is set if this is a source we found on the disk, in
749 -- which case we can provide more explicit error message. Path
750 -- is unset when the source is added from one of the naming
751 -- exceptions in the project.
753 if Path /= No_Path_Information then
754 Error_Msg_Name_1 := Unit;
755 Error_Msg
756 (Data.Flags,
757 "unit %% cannot belong to several projects",
758 Location, Project);
760 Error_Msg_Name_1 := Project.Name;
761 Error_Msg_Name_2 := Name_Id (Path.Display_Name);
762 Error_Msg
765 Error_Msg_Name_1 := Source.Project.Name;
766 Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name);
767 Error_Msg
770 else
771 Error_Msg_Name_1 := Unit;
772 Error_Msg_Name_2 := Source.Project.Name;
773 Error_Msg
774 (Data.Flags, "unit %% already belongs to project %%",
775 Location, Project);
776 end if;
778 Add_Src := False;
780 elsif not Source.Locally_Removed
781 and then Source.Replaced_By /= No_Source
782 and then not Data.Flags.Allow_Duplicate_Basenames
783 and then Lang_Id.Config.Kind = Unit_Based
784 and then Source.Language.Config.Kind = Unit_Based
785 and then not Data.In_Aggregate_Lib
786 then
787 Error_Msg_File_1 := File_Name;
788 Error_Msg_File_2 := File_Name_Type (Source.Project.Name);
789 Error_Msg
790 (Data.Flags,
791 "{ is already a source of project {", Location, Project);
793 -- Add the file anyway, to avoid further warnings like
794 -- "language unknown".
796 Add_Src := True;
797 end if;
798 end if;
799 end if;
801 if not Add_Src then
802 return;
803 end if;
805 -- Add the new file
807 Id := new Source_Data;
809 if Current_Verbosity = High then
810 Debug_Indent;
811 Write_Str ("adding source File: ");
812 Write_Str (Get_Name_String (Display_File));
814 if Index /= 0 then
815 Write_Str (" at" & Index'Img);
816 end if;
818 if Lang_Id.Config.Kind = Unit_Based then
819 Write_Str (" Unit: ");
821 -- ??? in gprclean, it seems we sometimes pass an empty Unit name
822 -- (see test extended_projects).
824 if Unit /= No_Name then
825 Write_Str (Get_Name_String (Unit));
826 end if;
828 Write_Str (" Kind: ");
829 Write_Str (Source_Kind'Image (Kind));
830 end if;
832 Write_Eol;
833 end if;
835 Id.Project := Project;
836 Id.Location := Location;
837 Id.Source_Dir_Rank := Source_Dir_Rank;
838 Id.Language := Lang_Id;
839 Id.Kind := Kind;
840 Id.Alternate_Languages := Alternate_Languages;
841 Id.Locally_Removed := Locally_Removed;
842 Id.Index := Index;
843 Id.File := File_Name;
844 Id.Display_File := Display_File;
845 Id.Dep_Name := Dependency_Name
846 (File_Name, Lang_Id.Config.Dependency_Kind);
847 Id.Naming_Exception := Naming_Exception;
848 Id.Object := Object_Name
849 (File_Name, Config.Object_File_Suffix);
850 Id.Switches := Switches_Name (File_Name);
852 -- Add the source id to the Unit_Sources_HT hash table, if the unit name
853 -- is not null.
855 if Unit /= No_Name then
857 -- Note: we might be creating a dummy unit here, when we in fact have
858 -- a separate. For instance, file file-bar.adb will initially be
859 -- assumed to be the IMPL of unit "file.bar". Only later on (in
860 -- Check_Object_Files) will we parse those units that only have an
861 -- impl and no spec to make sure whether we have a Separate in fact
862 -- (that significantly reduces the number of times we need to parse
863 -- the files, since we are then only interested in those with no
864 -- spec). We still need those dummy units in the table, since that's
865 -- the name we find in the ALI file
867 UData := Units_Htable.Get (Data.Tree.Units_HT, Unit);
869 if UData = No_Unit_Index then
870 UData := new Unit_Data;
871 UData.Name := Unit;
873 if Naming_Exception /= Inherited then
874 Units_Htable.Set (Data.Tree.Units_HT, Unit, UData);
875 end if;
876 end if;
878 Id.Unit := UData;
880 -- Note that this updates Unit information as well
882 if Naming_Exception /= Inherited and then not Locally_Removed then
883 Override_Kind (Id, Kind);
884 end if;
885 end if;
887 if Path /= No_Path_Information then
888 Id.Path := Path;
889 Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path.Name, Id);
890 end if;
892 Id.Next_With_File_Name :=
893 Source_Files_Htable.Get (Data.Tree.Source_Files_HT, File_Name);
894 Source_Files_Htable.Set (Data.Tree.Source_Files_HT, File_Name, Id);
896 if Index /= 0 then
897 Project.Has_Multi_Unit_Sources := True;
898 end if;
900 -- Add the source to the language list
902 Id.Next_In_Lang := Lang_Id.First_Source;
903 Lang_Id.First_Source := Id;
905 if Source_To_Replace /= No_Source then
906 Remove_Source (Data.Tree, Source_To_Replace, Id);
907 end if;
909 if Data.Tree.Replaced_Source_Number > 0
910 and then
911 Replaced_Source_HTable.Get
912 (Data.Tree.Replaced_Sources, Id.File) /= No_File
913 then
914 Replaced_Source_HTable.Remove (Data.Tree.Replaced_Sources, Id.File);
915 Data.Tree.Replaced_Source_Number :=
916 Data.Tree.Replaced_Source_Number - 1;
917 end if;
918 end Add_Source;
920 ------------------------------
921 -- Canonical_Case_File_Name --
922 ------------------------------
924 function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type is
925 begin
926 if Osint.File_Names_Case_Sensitive then
927 return File_Name_Type (Name);
928 else
929 Get_Name_String (Name);
930 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
931 return Name_Find;
932 end if;
933 end Canonical_Case_File_Name;
935 ---------------------------------
936 -- Process_Aggregated_Projects --
937 ---------------------------------
939 procedure Process_Aggregated_Projects
940 (Tree : Project_Tree_Ref;
941 Project : Project_Id;
942 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
943 Flags : Processing_Flags)
944 is
945 Data : Tree_Processing_Data :=
946 (Tree => Tree,
947 Node_Tree => Node_Tree,
948 Flags => Flags,
949 In_Aggregate_Lib => False);
951 Project_Files : constant Prj.Variable_Value :=
952 Prj.Util.Value_Of
953 (Snames.Name_Project_Files,
954 Project.Decl.Attributes,
955 Tree.Shared);
957 Project_Path_For_Aggregate : Prj.Env.Project_Search_Path;
959 procedure Found_Project_File (Path : Path_Information; Rank : Natural);
960 -- Called for each project file aggregated by Project
962 procedure Expand_Project_Files is
963 new Expand_Subdirectory_Pattern (Callback => Found_Project_File);
964 -- Search for all project files referenced by the patterns given in
965 -- parameter. Calls Found_Project_File for each of them.
967 ------------------------
968 -- Found_Project_File --
969 ------------------------
971 procedure Found_Project_File (Path : Path_Information; Rank : Natural) is
972 pragma Unreferenced (Rank);
974 begin
975 if Path.Name /= Project.Path.Name then
976 Debug_Output ("aggregates: ", Name_Id (Path.Display_Name));
978 -- For usual "with" statement, this phase will have been done when
979 -- parsing the project itself. However, for aggregate projects, we
980 -- can only do this when processing the aggregate project, since
981 -- the exact list of project files or project directories can
982 -- depend on scenario variables.
983 --
984 -- We only load the projects explicitly here, but do not process
985 -- them. For the processing, Prj.Proc will take care of processing
986 -- them, within the same call to Recursive_Process (thus avoiding
987 -- the processing of a given project multiple times).
988 --
989 -- ??? We might already have loaded the project
991 Add_Aggregated_Project (Project, Path => Path.Name);
993 else
994 Debug_Output ("pattern returned the aggregate itself, ignored");
995 end if;
996 end Found_Project_File;
998 -- Start of processing for Check_Aggregate_Project
1000 begin
1001 pragma Assert (Project.Qualifier in Aggregate_Project);
1003 if Project_Files.Default then
1004 Error_Msg_Name_1 := Snames.Name_Project_Files;
1005 Error_Msg
1006 (Flags,
1007 "Attribute %% must be specified in aggregate project",
1008 Project.Location, Project);
1009 return;
1010 end if;
1012 -- The aggregated projects are only searched relative to the directory
1013 -- of the aggregate project, not in the default project path.
1015 Initialize_Empty (Project_Path_For_Aggregate);
1017 Free (Project.Aggregated_Projects);
1019 -- Look for aggregated projects. For similarity with source files and
1020 -- dirs, the aggregated project files are not searched for on the
1021 -- project path, and are only found through the path specified in
1022 -- the Project_Files attribute.
1024 Expand_Project_Files
1025 (Project => Project,
1026 Data => Data,
1027 Patterns => Project_Files.Values,
1028 Ignore => Nil_String,
1029 Search_For => Search_Files,
1030 Resolve_Links => Opt.Follow_Links_For_Files);
1032 Free (Project_Path_For_Aggregate);
1033 end Process_Aggregated_Projects;
1035 ----------------------------
1036 -- Check_Abstract_Project --
1037 ----------------------------
1039 procedure Check_Abstract_Project
1040 (Project : Project_Id;
1041 Data : in out Tree_Processing_Data)
1042 is
1043 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
1045 Source_Dirs : constant Variable_Value :=
1046 Util.Value_Of
1047 (Name_Source_Dirs,
1048 Project.Decl.Attributes, Shared);
1049 Source_Files : constant Variable_Value :=
1050 Util.Value_Of
1051 (Name_Source_Files,
1052 Project.Decl.Attributes, Shared);
1053 Source_List_File : constant Variable_Value :=
1054 Util.Value_Of
1055 (Name_Source_List_File,
1056 Project.Decl.Attributes, Shared);
1057 Languages : constant Variable_Value :=
1058 Util.Value_Of
1059 (Name_Languages,
1060 Project.Decl.Attributes, Shared);
1062 begin
1063 if Project.Source_Dirs /= Nil_String then
1064 if Source_Dirs.Values = Nil_String
1065 and then Source_Files.Values = Nil_String
1066 and then Languages.Values = Nil_String
1067 and then Source_List_File.Default
1068 then
1069 Project.Source_Dirs := Nil_String;
1071 else
1072 Error_Msg
1073 (Data.Flags,
1074 "at least one of Source_Files, Source_Dirs or Languages "
1075 & "must be declared empty for an abstract project",
1076 Project.Location, Project);
1077 end if;
1078 end if;
1079 end Check_Abstract_Project;
1081 -------------------------
1082 -- Check_Configuration --
1083 -------------------------
1085 procedure Check_Configuration
1086 (Project : Project_Id;
1087 Data : in out Tree_Processing_Data)
1088 is
1089 Shared : constant Shared_Project_Tree_Data_Access :=
1090 Data.Tree.Shared;
1092 Dot_Replacement : File_Name_Type := No_File;
1093 Casing : Casing_Type := All_Lower_Case;
1094 Separate_Suffix : File_Name_Type := No_File;
1096 Lang_Index : Language_Ptr := No_Language_Index;
1097 -- The index of the language data being checked
1099 Prev_Index : Language_Ptr := No_Language_Index;
1100 -- The index of the previous language
1102 procedure Process_Project_Level_Simple_Attributes;
1103 -- Process the simple attributes at the project level
1105 procedure Process_Project_Level_Array_Attributes;
1106 -- Process the associate array attributes at the project level
1108 procedure Process_Packages;
1109 -- Read the packages of the project
1111 ----------------------
1112 -- Process_Packages --
1113 ----------------------
1115 procedure Process_Packages is
1116 Packages : Package_Id;
1117 Element : Package_Element;
1119 procedure Process_Binder (Arrays : Array_Id);
1120 -- Process the associated array attributes of package Binder
1122 procedure Process_Builder (Attributes : Variable_Id);
1123 -- Process the simple attributes of package Builder
1125 procedure Process_Clean (Attributes : Variable_Id);
1126 -- Process the simple attributes of package Clean
1128 procedure Process_Clean (Arrays : Array_Id);
1129 -- Process the associated array attributes of package Clean
1131 procedure Process_Compiler (Arrays : Array_Id);
1132 -- Process the associated array attributes of package Compiler
1134 procedure Process_Naming (Attributes : Variable_Id);
1135 -- Process the simple attributes of package Naming
1137 procedure Process_Naming (Arrays : Array_Id);
1138 -- Process the associated array attributes of package Naming
1140 procedure Process_Linker (Attributes : Variable_Id);
1141 -- Process the simple attributes of package Linker of a
1142 -- configuration project.
1144 --------------------
1145 -- Process_Binder --
1146 --------------------
1148 procedure Process_Binder (Arrays : Array_Id) is
1149 Current_Array_Id : Array_Id;
1150 Current_Array : Array_Data;
1151 Element_Id : Array_Element_Id;
1152 Element : Array_Element;
1154 begin
1155 -- Process the associative array attribute of package Binder
1157 Current_Array_Id := Arrays;
1158 while Current_Array_Id /= No_Array loop
1159 Current_Array := Shared.Arrays.Table (Current_Array_Id);
1161 Element_Id := Current_Array.Value;
1162 while Element_Id /= No_Array_Element loop
1163 Element := Shared.Array_Elements.Table (Element_Id);
1165 if Element.Index /= All_Other_Names then
1167 -- Get the name of the language
1169 Lang_Index :=
1170 Get_Language_From_Name
1171 (Project, Get_Name_String (Element.Index));
1173 if Lang_Index /= No_Language_Index then
1174 case Current_Array.Name is
1175 when Name_Driver =>
1177 -- Attribute Driver (<language>)
1179 Lang_Index.Config.Binder_Driver :=
1180 File_Name_Type (Element.Value.Value);
1182 when Name_Required_Switches =>
1183 Put
1184 (Into_List =>
1185 Lang_Index.Config.Binder_Required_Switches,
1186 From_List => Element.Value.Values,
1187 In_Tree => Data.Tree);
1189 when Name_Prefix =>
1191 -- Attribute Prefix (<language>)
1193 Lang_Index.Config.Binder_Prefix :=
1194 Element.Value.Value;
1196 when Name_Objects_Path =>
1198 -- Attribute Objects_Path (<language>)
1200 Lang_Index.Config.Objects_Path :=
1201 Element.Value.Value;
1203 when Name_Objects_Path_File =>
1205 -- Attribute Objects_Path (<language>)
1207 Lang_Index.Config.Objects_Path_File :=
1208 Element.Value.Value;
1210 when others =>
1211 null;
1212 end case;
1213 end if;
1214 end if;
1216 Element_Id := Element.Next;
1217 end loop;
1219 Current_Array_Id := Current_Array.Next;
1220 end loop;
1221 end Process_Binder;
1223 ---------------------
1224 -- Process_Builder --
1225 ---------------------
1227 procedure Process_Builder (Attributes : Variable_Id) is
1228 Attribute_Id : Variable_Id;
1229 Attribute : Variable;
1231 begin
1232 -- Process non associated array attribute from package Builder
1234 Attribute_Id := Attributes;
1235 while Attribute_Id /= No_Variable loop
1236 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
1238 if not Attribute.Value.Default then
1239 if Attribute.Name = Name_Executable_Suffix then
1241 -- Attribute Executable_Suffix: the suffix of the
1242 -- executables.
1244 Project.Config.Executable_Suffix :=
1245 Attribute.Value.Value;
1246 end if;
1247 end if;
1249 Attribute_Id := Attribute.Next;
1250 end loop;
1251 end Process_Builder;
1253 -------------------
1254 -- Process_Clean --
1255 -------------------
1257 procedure Process_Clean (Attributes : Variable_Id) is
1258 Attribute_Id : Variable_Id;
1259 Attribute : Variable;
1260 List : String_List_Id;
1262 begin
1263 -- Process non associated array attributes from package Clean
1265 Attribute_Id := Attributes;
1266 while Attribute_Id /= No_Variable loop
1267 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
1269 if not Attribute.Value.Default then
1270 if Attribute.Name = Name_Artifacts_In_Exec_Dir then
1272 -- Attribute Artifacts_In_Exec_Dir: the list of file
1273 -- names to be cleaned in the exec dir of the main
1274 -- project.
1276 List := Attribute.Value.Values;
1278 if List /= Nil_String then
1279 Put (Into_List =>
1280 Project.Config.Artifacts_In_Exec_Dir,
1281 From_List => List,
1282 In_Tree => Data.Tree);
1283 end if;
1285 elsif Attribute.Name = Name_Artifacts_In_Object_Dir then
1287 -- Attribute Artifacts_In_Exec_Dir: the list of file
1288 -- names to be cleaned in the object dir of every
1289 -- project.
1291 List := Attribute.Value.Values;
1293 if List /= Nil_String then
1294 Put (Into_List =>
1295 Project.Config.Artifacts_In_Object_Dir,
1296 From_List => List,
1297 In_Tree => Data.Tree);
1298 end if;
1299 end if;
1300 end if;
1302 Attribute_Id := Attribute.Next;
1303 end loop;
1304 end Process_Clean;
1306 procedure Process_Clean (Arrays : Array_Id) is
1307 Current_Array_Id : Array_Id;
1308 Current_Array : Array_Data;
1309 Element_Id : Array_Element_Id;
1310 Element : Array_Element;
1311 List : String_List_Id;
1313 begin
1314 -- Process the associated array attributes of package Clean
1316 Current_Array_Id := Arrays;
1317 while Current_Array_Id /= No_Array loop
1318 Current_Array := Shared.Arrays.Table (Current_Array_Id);
1320 Element_Id := Current_Array.Value;
1321 while Element_Id /= No_Array_Element loop
1322 Element := Shared.Array_Elements.Table (Element_Id);
1324 -- Get the name of the language
1326 Lang_Index :=
1327 Get_Language_From_Name
1328 (Project, Get_Name_String (Element.Index));
1330 if Lang_Index /= No_Language_Index then
1331 case Current_Array.Name is
1333 -- Attribute Object_Artifact_Extensions (<language>)
1335 when Name_Object_Artifact_Extensions =>
1336 List := Element.Value.Values;
1338 if List /= Nil_String then
1339 Put (Into_List =>
1340 Lang_Index.Config.Clean_Object_Artifacts,
1341 From_List => List,
1342 In_Tree => Data.Tree);
1343 end if;
1345 -- Attribute Source_Artifact_Extensions (<language>)
1347 when Name_Source_Artifact_Extensions =>
1348 List := Element.Value.Values;
1350 if List /= Nil_String then
1351 Put (Into_List =>
1352 Lang_Index.Config.Clean_Source_Artifacts,
1353 From_List => List,
1354 In_Tree => Data.Tree);
1355 end if;
1357 when others =>
1358 null;
1359 end case;
1360 end if;
1362 Element_Id := Element.Next;
1363 end loop;
1365 Current_Array_Id := Current_Array.Next;
1366 end loop;
1367 end Process_Clean;
1369 ----------------------
1370 -- Process_Compiler --
1371 ----------------------
1373 procedure Process_Compiler (Arrays : Array_Id) is
1374 Current_Array_Id : Array_Id;
1375 Current_Array : Array_Data;
1376 Element_Id : Array_Element_Id;
1377 Element : Array_Element;
1378 List : String_List_Id;
1380 begin
1381 -- Process the associative array attribute of package Compiler
1383 Current_Array_Id := Arrays;
1384 while Current_Array_Id /= No_Array loop
1385 Current_Array := Shared.Arrays.Table (Current_Array_Id);
1387 Element_Id := Current_Array.Value;
1388 while Element_Id /= No_Array_Element loop
1389 Element := Shared.Array_Elements.Table (Element_Id);
1391 if Element.Index /= All_Other_Names then
1393 -- Get the name of the language
1395 Lang_Index := Get_Language_From_Name
1396 (Project, Get_Name_String (Element.Index));
1398 if Lang_Index /= No_Language_Index then
1399 case Current_Array.Name is
1401 -- Attribute Dependency_Kind (<language>)
1403 when Name_Dependency_Kind =>
1404 Get_Name_String (Element.Value.Value);
1406 begin
1407 Lang_Index.Config.Dependency_Kind :=
1408 Dependency_File_Kind'Value
1409 (Name_Buffer (1 .. Name_Len));
1411 exception
1412 when Constraint_Error =>
1413 Error_Msg
1414 (Data.Flags,
1415 "illegal value for Dependency_Kind",
1416 Element.Value.Location,
1417 Project);
1418 end;
1420 -- Attribute Dependency_Switches (<language>)
1422 when Name_Dependency_Switches =>
1423 if Lang_Index.Config.Dependency_Kind = None then
1424 Lang_Index.Config.Dependency_Kind := Makefile;
1425 end if;
1427 List := Element.Value.Values;
1429 if List /= Nil_String then
1430 Put (Into_List =>
1431 Lang_Index.Config.Dependency_Option,
1432 From_List => List,
1433 In_Tree => Data.Tree);
1434 end if;
1436 -- Attribute Dependency_Driver (<language>)
1438 when Name_Dependency_Driver =>
1439 if Lang_Index.Config.Dependency_Kind = None then
1440 Lang_Index.Config.Dependency_Kind := Makefile;
1441 end if;
1443 List := Element.Value.Values;
1445 if List /= Nil_String then
1446 Put (Into_List =>
1447 Lang_Index.Config.Compute_Dependency,
1448 From_List => List,
1449 In_Tree => Data.Tree);
1450 end if;
1452 -- Attribute Language_Kind (<language>)
1454 when Name_Language_Kind =>
1455 Get_Name_String (Element.Value.Value);
1457 begin
1458 Lang_Index.Config.Kind :=
1459 Language_Kind'Value
1460 (Name_Buffer (1 .. Name_Len));
1462 exception
1463 when Constraint_Error =>
1464 Error_Msg
1465 (Data.Flags,
1466 "illegal value for Language_Kind",
1467 Element.Value.Location,
1468 Project);
1469 end;
1471 -- Attribute Include_Switches (<language>)
1473 when Name_Include_Switches =>
1474 List := Element.Value.Values;
1476 if List = Nil_String then
1477 Error_Msg
1478 (Data.Flags, "include option cannot be null",
1479 Element.Value.Location, Project);
1480 end if;
1482 Put (Into_List => Lang_Index.Config.Include_Option,
1483 From_List => List,
1484 In_Tree => Data.Tree);
1486 -- Attribute Include_Path (<language>)
1488 when Name_Include_Path =>
1489 Lang_Index.Config.Include_Path :=
1490 Element.Value.Value;
1492 -- Attribute Include_Path_File (<language>)
1494 when Name_Include_Path_File =>
1495 Lang_Index.Config.Include_Path_File :=
1496 Element.Value.Value;
1498 -- Attribute Driver (<language>)
1500 when Name_Driver =>
1501 Lang_Index.Config.Compiler_Driver :=
1502 File_Name_Type (Element.Value.Value);
1504 when Name_Leading_Required_Switches
1505 | Name_Required_Switches
1506 =>
1507 Put (Into_List =>
1508 Lang_Index.Config.
1509 Compiler_Leading_Required_Switches,
1510 From_List => Element.Value.Values,
1511 In_Tree => Data.Tree);
1513 when Name_Trailing_Required_Switches =>
1514 Put (Into_List =>
1515 Lang_Index.Config.
1516 Compiler_Trailing_Required_Switches,
1517 From_List => Element.Value.Values,
1518 In_Tree => Data.Tree);
1520 when Name_Multi_Unit_Switches =>
1521 Put (Into_List =>
1522 Lang_Index.Config.Multi_Unit_Switches,
1523 From_List => Element.Value.Values,
1524 In_Tree => Data.Tree);
1526 when Name_Multi_Unit_Object_Separator =>
1527 Get_Name_String (Element.Value.Value);
1529 if Name_Len /= 1 then
1530 Error_Msg
1531 (Data.Flags,
1532 "multi-unit object separator must have " &
1533 "a single character",
1534 Element.Value.Location, Project);
1537 Error_Msg
1538 (Data.Flags,
1539 "multi-unit object separator cannot be " &
1540 "a space",
1541 Element.Value.Location, Project);
1543 else
1544 Lang_Index.Config.Multi_Unit_Object_Separator :=
1545 Name_Buffer (1);
1546 end if;
1548 when Name_Path_Syntax =>
1549 begin
1550 Lang_Index.Config.Path_Syntax :=
1551 Path_Syntax_Kind'Value
1552 (Get_Name_String (Element.Value.Value));
1554 exception
1555 when Constraint_Error =>
1556 Error_Msg
1557 (Data.Flags,
1558 "invalid value for Path_Syntax",
1559 Element.Value.Location, Project);
1560 end;
1562 when Name_Source_File_Switches =>
1563 Put (Into_List =>
1564 Lang_Index.Config.Source_File_Switches,
1565 From_List => Element.Value.Values,
1566 In_Tree => Data.Tree);
1568 when Name_Object_File_Suffix =>
1569 if Get_Name_String (Element.Value.Value) = "" then
1570 Error_Msg
1571 (Data.Flags,
1572 "object file suffix cannot be empty",
1573 Element.Value.Location, Project);
1575 else
1576 Lang_Index.Config.Object_File_Suffix :=
1577 Element.Value.Value;
1578 end if;
1580 when Name_Object_File_Switches =>
1581 Put (Into_List =>
1582 Lang_Index.Config.Object_File_Switches,
1583 From_List => Element.Value.Values,
1584 In_Tree => Data.Tree);
1586 when Name_Object_Path_Switches =>
1587 Put (Into_List =>
1588 Lang_Index.Config.Object_Path_Switches,
1589 From_List => Element.Value.Values,
1590 In_Tree => Data.Tree);
1592 -- Attribute Compiler_Pic_Option (<language>)
1594 when Name_Pic_Option =>
1595 List := Element.Value.Values;
1597 if List = Nil_String then
1598 Error_Msg
1599 (Data.Flags,
1600 "compiler PIC option cannot be null",
1601 Element.Value.Location, Project);
1602 end if;
1604 Put (Into_List =>
1605 Lang_Index.Config.Compilation_PIC_Option,
1606 From_List => List,
1607 In_Tree => Data.Tree);
1609 -- Attribute Mapping_File_Switches (<language>)
1611 when Name_Mapping_File_Switches =>
1612 List := Element.Value.Values;
1614 if List = Nil_String then
1615 Error_Msg
1616 (Data.Flags,
1617 "mapping file switches cannot be null",
1618 Element.Value.Location, Project);
1619 end if;
1621 Put (Into_List =>
1622 Lang_Index.Config.Mapping_File_Switches,
1623 From_List => List,
1624 In_Tree => Data.Tree);
1626 -- Attribute Mapping_Spec_Suffix (<language>)
1628 when Name_Mapping_Spec_Suffix =>
1629 Lang_Index.Config.Mapping_Spec_Suffix :=
1630 File_Name_Type (Element.Value.Value);
1632 -- Attribute Mapping_Body_Suffix (<language>)
1634 when Name_Mapping_Body_Suffix =>
1635 Lang_Index.Config.Mapping_Body_Suffix :=
1636 File_Name_Type (Element.Value.Value);
1638 -- Attribute Config_File_Switches (<language>)
1640 when Name_Config_File_Switches =>
1641 List := Element.Value.Values;
1643 if List = Nil_String then
1644 Error_Msg
1645 (Data.Flags,
1646 "config file switches cannot be null",
1647 Element.Value.Location, Project);
1648 end if;
1650 Put (Into_List =>
1651 Lang_Index.Config.Config_File_Switches,
1652 From_List => List,
1653 In_Tree => Data.Tree);
1655 -- Attribute Objects_Path (<language>)
1657 when Name_Objects_Path =>
1658 Lang_Index.Config.Objects_Path :=
1659 Element.Value.Value;
1661 -- Attribute Objects_Path_File (<language>)
1663 when Name_Objects_Path_File =>
1664 Lang_Index.Config.Objects_Path_File :=
1665 Element.Value.Value;
1667 -- Attribute Config_Body_File_Name (<language>)
1669 when Name_Config_Body_File_Name =>
1670 Lang_Index.Config.Config_Body :=
1671 Element.Value.Value;
1673 -- Attribute Config_Body_File_Name_Index (< Language>)
1675 when Name_Config_Body_File_Name_Index =>
1676 Lang_Index.Config.Config_Body_Index :=
1677 Element.Value.Value;
1679 -- Attribute Config_Body_File_Name_Pattern(<language>)
1681 when Name_Config_Body_File_Name_Pattern =>
1682 Lang_Index.Config.Config_Body_Pattern :=
1683 Element.Value.Value;
1685 -- Attribute Config_Spec_File_Name (<language>)
1687 when Name_Config_Spec_File_Name =>
1688 Lang_Index.Config.Config_Spec :=
1689 Element.Value.Value;
1691 -- Attribute Config_Spec_File_Name_Index (<language>)
1693 when Name_Config_Spec_File_Name_Index =>
1694 Lang_Index.Config.Config_Spec_Index :=
1695 Element.Value.Value;
1697 -- Attribute Config_Spec_File_Name_Pattern(<language>)
1699 when Name_Config_Spec_File_Name_Pattern =>
1700 Lang_Index.Config.Config_Spec_Pattern :=
1701 Element.Value.Value;
1703 -- Attribute Config_File_Unique (<language>)
1705 when Name_Config_File_Unique =>
1706 begin
1707 Lang_Index.Config.Config_File_Unique :=
1708 Boolean'Value
1709 (Get_Name_String (Element.Value.Value));
1710 exception
1711 when Constraint_Error =>
1712 Error_Msg
1713 (Data.Flags,
1714 "illegal value for Config_File_Unique",
1715 Element.Value.Location, Project);
1716 end;
1718 when others =>
1719 null;
1720 end case;
1721 end if;
1722 end if;
1724 Element_Id := Element.Next;
1725 end loop;
1727 Current_Array_Id := Current_Array.Next;
1728 end loop;
1729 end Process_Compiler;
1731 --------------------
1732 -- Process_Naming --
1733 --------------------
1735 procedure Process_Naming (Attributes : Variable_Id) is
1736 Attribute_Id : Variable_Id;
1737 Attribute : Variable;
1739 begin
1740 -- Process non associated array attribute from package Naming
1742 Attribute_Id := Attributes;
1743 while Attribute_Id /= No_Variable loop
1744 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
1746 if not Attribute.Value.Default then
1747 if Attribute.Name = Name_Separate_Suffix then
1749 -- Attribute Separate_Suffix
1751 Get_Name_String (Attribute.Value.Value);
1752 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1753 Separate_Suffix := Name_Find;
1755 elsif Attribute.Name = Name_Casing then
1757 -- Attribute Casing
1759 begin
1760 Casing :=
1761 Value (Get_Name_String (Attribute.Value.Value));
1763 exception
1764 when Constraint_Error =>
1765 Error_Msg
1766 (Data.Flags,
1767 "invalid value for Casing",
1768 Attribute.Value.Location, Project);
1769 end;
1771 elsif Attribute.Name = Name_Dot_Replacement then
1773 -- Attribute Dot_Replacement
1775 Dot_Replacement := File_Name_Type (Attribute.Value.Value);
1777 end if;
1778 end if;
1780 Attribute_Id := Attribute.Next;
1781 end loop;
1782 end Process_Naming;
1784 procedure Process_Naming (Arrays : Array_Id) is
1785 Current_Array_Id : Array_Id;
1786 Current_Array : Array_Data;
1787 Element_Id : Array_Element_Id;
1788 Element : Array_Element;
1790 begin
1791 -- Process the associative array attribute of package Naming
1793 Current_Array_Id := Arrays;
1794 while Current_Array_Id /= No_Array loop
1795 Current_Array := Shared.Arrays.Table (Current_Array_Id);
1797 Element_Id := Current_Array.Value;
1798 while Element_Id /= No_Array_Element loop
1799 Element := Shared.Array_Elements.Table (Element_Id);
1801 -- Get the name of the language
1803 Lang_Index := Get_Language_From_Name
1804 (Project, Get_Name_String (Element.Index));
1806 if Lang_Index /= No_Language_Index
1807 and then Element.Value.Kind = Single
1808 and then Element.Value.Value /= No_Name
1809 then
1810 case Current_Array.Name is
1811 when Name_Spec_Suffix
1812 | Name_Specification_Suffix
1813 =>
1814 -- Attribute Spec_Suffix (<language>)
1816 Get_Name_String (Element.Value.Value);
1817 Canonical_Case_File_Name
1818 (Name_Buffer (1 .. Name_Len));
1819 Lang_Index.Config.Naming_Data.Spec_Suffix :=
1820 Name_Find;
1822 when Name_Body_Suffix
1823 | Name_Implementation_Suffix
1824 =>
1825 Get_Name_String (Element.Value.Value);
1826 Canonical_Case_File_Name
1827 (Name_Buffer (1 .. Name_Len));
1829 -- Attribute Body_Suffix (<language>)
1831 Lang_Index.Config.Naming_Data.Body_Suffix :=
1832 Name_Find;
1833 Lang_Index.Config.Naming_Data.Separate_Suffix :=
1834 Lang_Index.Config.Naming_Data.Body_Suffix;
1836 when others =>
1837 null;
1838 end case;
1839 end if;
1841 Element_Id := Element.Next;
1842 end loop;
1844 Current_Array_Id := Current_Array.Next;
1845 end loop;
1846 end Process_Naming;
1848 --------------------
1849 -- Process_Linker --
1850 --------------------
1852 procedure Process_Linker (Attributes : Variable_Id) is
1853 Attribute_Id : Variable_Id;
1854 Attribute : Variable;
1856 begin
1857 -- Process non associated array attribute from package Linker
1859 Attribute_Id := Attributes;
1860 while Attribute_Id /= No_Variable loop
1861 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
1863 if not Attribute.Value.Default then
1864 if Attribute.Name = Name_Driver then
1866 -- Attribute Linker'Driver: the default linker to use
1868 Project.Config.Linker :=
1869 Path_Name_Type (Attribute.Value.Value);
1871 -- Linker'Driver is also used to link shared libraries
1872 -- if the obsolescent attribute Library_GCC has not been
1873 -- specified.
1875 if Project.Config.Shared_Lib_Driver = No_File then
1876 Project.Config.Shared_Lib_Driver :=
1877 File_Name_Type (Attribute.Value.Value);
1878 end if;
1880 elsif Attribute.Name = Name_Required_Switches then
1882 -- Attribute Required_Switches: the minimum trailing
1883 -- options to use when invoking the linker
1885 Put (Into_List =>
1886 Project.Config.Trailing_Linker_Required_Switches,
1887 From_List => Attribute.Value.Values,
1888 In_Tree => Data.Tree);
1890 elsif Attribute.Name = Name_Map_File_Option then
1891 Project.Config.Map_File_Option := Attribute.Value.Value;
1893 elsif Attribute.Name = Name_Max_Command_Line_Length then
1894 begin
1895 Project.Config.Max_Command_Line_Length :=
1896 Natural'Value (Get_Name_String
1897 (Attribute.Value.Value));
1899 exception
1900 when Constraint_Error =>
1901 Error_Msg
1902 (Data.Flags,
1903 "value must be positive or equal to 0",
1904 Attribute.Value.Location, Project);
1905 end;
1907 elsif Attribute.Name = Name_Response_File_Format then
1908 declare
1909 Name : Name_Id;
1911 begin
1912 Get_Name_String (Attribute.Value.Value);
1913 To_Lower (Name_Buffer (1 .. Name_Len));
1914 Name := Name_Find;
1916 if Name = Name_None then
1917 Project.Config.Resp_File_Format := None;
1919 elsif Name = Name_Gnu then
1920 Project.Config.Resp_File_Format := GNU;
1922 elsif Name = Name_Object_List then
1923 Project.Config.Resp_File_Format := Object_List;
1925 elsif Name = Name_Option_List then
1926 Project.Config.Resp_File_Format := Option_List;
1928 elsif Name_Buffer (1 .. Name_Len) = "gcc" then
1929 Project.Config.Resp_File_Format := GCC;
1931 elsif Name_Buffer (1 .. Name_Len) = "gcc_gnu" then
1932 Project.Config.Resp_File_Format := GCC_GNU;
1934 elsif
1935 Name_Buffer (1 .. Name_Len) = "gcc_option_list"
1936 then
1937 Project.Config.Resp_File_Format := GCC_Option_List;
1939 elsif
1940 Name_Buffer (1 .. Name_Len) = "gcc_object_list"
1941 then
1942 Project.Config.Resp_File_Format := GCC_Object_List;
1944 else
1945 Error_Msg
1946 (Data.Flags,
1947 "illegal response file format",
1948 Attribute.Value.Location, Project);
1949 end if;
1950 end;
1952 elsif Attribute.Name = Name_Response_File_Switches then
1953 Put (Into_List => Project.Config.Resp_File_Options,
1954 From_List => Attribute.Value.Values,
1955 In_Tree => Data.Tree);
1956 end if;
1957 end if;
1959 Attribute_Id := Attribute.Next;
1960 end loop;
1961 end Process_Linker;
1963 -- Start of processing for Process_Packages
1965 begin
1966 Packages := Project.Decl.Packages;
1967 while Packages /= No_Package loop
1968 Element := Shared.Packages.Table (Packages);
1970 case Element.Name is
1971 when Name_Binder =>
1973 -- Process attributes of package Binder
1975 Process_Binder (Element.Decl.Arrays);
1977 when Name_Builder =>
1979 -- Process attributes of package Builder
1981 Process_Builder (Element.Decl.Attributes);
1983 when Name_Clean =>
1985 -- Process attributes of package Clean
1987 Process_Clean (Element.Decl.Attributes);
1988 Process_Clean (Element.Decl.Arrays);
1990 when Name_Compiler =>
1992 -- Process attributes of package Compiler
1994 Process_Compiler (Element.Decl.Arrays);
1996 when Name_Linker =>
1998 -- Process attributes of package Linker
2000 Process_Linker (Element.Decl.Attributes);
2002 when Name_Naming =>
2004 -- Process attributes of package Naming
2006 Process_Naming (Element.Decl.Attributes);
2007 Process_Naming (Element.Decl.Arrays);
2009 when others =>
2010 null;
2011 end case;
2013 Packages := Element.Next;
2014 end loop;
2015 end Process_Packages;
2017 ---------------------------------------------
2018 -- Process_Project_Level_Simple_Attributes --
2019 ---------------------------------------------
2021 procedure Process_Project_Level_Simple_Attributes is
2022 Attribute_Id : Variable_Id;
2023 Attribute : Variable;
2024 List : String_List_Id;
2026 begin
2027 -- Process non associated array attribute at project level
2029 Attribute_Id := Project.Decl.Attributes;
2030 while Attribute_Id /= No_Variable loop
2031 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
2033 if not Attribute.Value.Default then
2034 if Attribute.Name = Name_Target then
2036 -- Attribute Target: the target specified
2038 Project.Config.Target := Attribute.Value.Value;
2040 elsif Attribute.Name = Name_Library_Builder then
2042 -- Attribute Library_Builder: the application to invoke
2043 -- to build libraries.
2045 Project.Config.Library_Builder :=
2046 Path_Name_Type (Attribute.Value.Value);
2048 elsif Attribute.Name = Name_Archive_Builder then
2050 -- Attribute Archive_Builder: the archive builder
2051 -- (usually "ar") and its minimum options (usually "cr").
2053 List := Attribute.Value.Values;
2055 if List = Nil_String then
2056 Error_Msg
2057 (Data.Flags,
2058 "archive builder cannot be null",
2059 Attribute.Value.Location, Project);
2060 end if;
2062 Put (Into_List => Project.Config.Archive_Builder,
2063 From_List => List,
2064 In_Tree => Data.Tree);
2066 elsif Attribute.Name = Name_Archive_Builder_Append_Option then
2068 -- Attribute Archive_Builder: the archive builder
2069 -- (usually "ar") and its minimum options (usually "cr").
2071 List := Attribute.Value.Values;
2073 if List /= Nil_String then
2074 Put
2075 (Into_List =>
2076 Project.Config.Archive_Builder_Append_Option,
2077 From_List => List,
2078 In_Tree => Data.Tree);
2079 end if;
2081 elsif Attribute.Name = Name_Archive_Indexer then
2083 -- Attribute Archive_Indexer: the optional archive
2084 -- indexer (usually "ranlib") with its minimum options
2085 -- (usually none).
2087 List := Attribute.Value.Values;
2089 if List = Nil_String then
2090 Error_Msg
2091 (Data.Flags,
2092 "archive indexer cannot be null",
2093 Attribute.Value.Location, Project);
2094 end if;
2096 Put (Into_List => Project.Config.Archive_Indexer,
2097 From_List => List,
2098 In_Tree => Data.Tree);
2100 elsif Attribute.Name = Name_Library_Partial_Linker then
2102 -- Attribute Library_Partial_Linker: the optional linker
2103 -- driver with its minimum options, to partially link
2104 -- archives.
2106 List := Attribute.Value.Values;
2108 if List = Nil_String then
2109 Error_Msg
2110 (Data.Flags,
2111 "partial linker cannot be null",
2112 Attribute.Value.Location, Project);
2113 end if;
2115 Put (Into_List => Project.Config.Lib_Partial_Linker,
2116 From_List => List,
2117 In_Tree => Data.Tree);
2119 elsif Attribute.Name = Name_Library_GCC then
2120 Project.Config.Shared_Lib_Driver :=
2121 File_Name_Type (Attribute.Value.Value);
2122 Error_Msg
2123 (Data.Flags,
2126 Attribute.Value.Location, Project);
2128 elsif Attribute.Name = Name_Archive_Suffix then
2129 Project.Config.Archive_Suffix :=
2130 File_Name_Type (Attribute.Value.Value);
2132 elsif Attribute.Name = Name_Linker_Executable_Option then
2134 -- Attribute Linker_Executable_Option: optional options
2137 List := Attribute.Value.Values;
2139 if List = Nil_String then
2140 Error_Msg
2141 (Data.Flags,
2143 Attribute.Value.Location, Project);
2144 end if;
2146 Put (Into_List => Project.Config.Linker_Executable_Option,
2147 From_List => List,
2148 In_Tree => Data.Tree);
2150 elsif Attribute.Name = Name_Linker_Lib_Dir_Option then
2152 -- Attribute Linker_Lib_Dir_Option: optional options
2153 -- to specify a library search directory. Defaults to
2156 Get_Name_String (Attribute.Value.Value);
2158 if Name_Len = 0 then
2159 Error_Msg
2160 (Data.Flags,
2162 Attribute.Value.Location, Project);
2163 end if;
2165 Project.Config.Linker_Lib_Dir_Option :=
2166 Attribute.Value.Value;
2168 elsif Attribute.Name = Name_Linker_Lib_Name_Option then
2170 -- Attribute Linker_Lib_Name_Option: optional options
2171 -- to specify the name of a library to be linked in.
2174 Get_Name_String (Attribute.Value.Value);
2176 if Name_Len = 0 then
2177 Error_Msg
2178 (Data.Flags,
2180 Attribute.Value.Location, Project);
2181 end if;
2183 Project.Config.Linker_Lib_Name_Option :=
2184 Attribute.Value.Value;
2186 elsif Attribute.Name = Name_Run_Path_Option then
2188 -- Attribute Run_Path_Option: optional options to
2189 -- specify a path for libraries.
2191 List := Attribute.Value.Values;
2193 if List /= Nil_String then
2194 Put (Into_List => Project.Config.Run_Path_Option,
2195 From_List => List,
2196 In_Tree => Data.Tree);
2197 end if;
2199 elsif Attribute.Name = Name_Run_Path_Origin then
2200 Get_Name_String (Attribute.Value.Value);
2202 if Name_Len = 0 then
2203 Error_Msg
2204 (Data.Flags,
2206 Attribute.Value.Location, Project);
2207 end if;
2209 Project.Config.Run_Path_Origin := Attribute.Value.Value;
2211 elsif Attribute.Name = Name_Library_Install_Name_Option then
2212 Project.Config.Library_Install_Name_Option :=
2213 Attribute.Value.Value;
2215 elsif Attribute.Name = Name_Separate_Run_Path_Options then
2216 declare
2217 pragma Unsuppress (All_Checks);
2218 begin
2219 Project.Config.Separate_Run_Path_Options :=
2220 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2221 exception
2222 when Constraint_Error =>
2223 Error_Msg
2224 (Data.Flags,
2226 Get_Name_String (Attribute.Value.Value) &
2228 Attribute.Value.Location, Project);
2229 end;
2231 elsif Attribute.Name = Name_Library_Support then
2232 declare
2233 pragma Unsuppress (All_Checks);
2234 begin
2235 Project.Config.Lib_Support :=
2236 Library_Support'Value (Get_Name_String
2237 (Attribute.Value.Value));
2238 exception
2239 when Constraint_Error =>
2240 Error_Msg
2241 (Data.Flags,
2243 Get_Name_String (Attribute.Value.Value) &
2245 Attribute.Value.Location, Project);
2246 end;
2248 elsif
2249 Attribute.Name = Name_Library_Encapsulated_Supported
2250 then
2251 declare
2252 pragma Unsuppress (All_Checks);
2253 begin
2254 Project.Config.Lib_Encapsulated_Supported :=
2255 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2256 exception
2257 when Constraint_Error =>
2258 Error_Msg
2259 (Data.Flags,
2261 & Get_Name_String (Attribute.Value.Value)
2263 Attribute.Value.Location, Project);
2264 end;
2266 elsif Attribute.Name = Name_Shared_Library_Prefix then
2267 Project.Config.Shared_Lib_Prefix :=
2268 File_Name_Type (Attribute.Value.Value);
2270 elsif Attribute.Name = Name_Shared_Library_Suffix then
2271 Project.Config.Shared_Lib_Suffix :=
2272 File_Name_Type (Attribute.Value.Value);
2274 elsif Attribute.Name = Name_Symbolic_Link_Supported then
2275 declare
2276 pragma Unsuppress (All_Checks);
2277 begin
2278 Project.Config.Symbolic_Link_Supported :=
2279 Boolean'Value (Get_Name_String
2280 (Attribute.Value.Value));
2281 exception
2282 when Constraint_Error =>
2283 Error_Msg
2284 (Data.Flags,
2286 & Get_Name_String (Attribute.Value.Value)
2288 Attribute.Value.Location, Project);
2289 end;
2291 elsif
2292 Attribute.Name = Name_Library_Major_Minor_Id_Supported
2293 then
2294 declare
2295 pragma Unsuppress (All_Checks);
2296 begin
2297 Project.Config.Lib_Maj_Min_Id_Supported :=
2298 Boolean'Value (Get_Name_String
2299 (Attribute.Value.Value));
2300 exception
2301 when Constraint_Error =>
2302 Error_Msg
2303 (Data.Flags,
2305 Get_Name_String (Attribute.Value.Value) &
2307 Attribute.Value.Location, Project);
2308 end;
2310 elsif Attribute.Name = Name_Library_Auto_Init_Supported then
2311 declare
2312 pragma Unsuppress (All_Checks);
2313 begin
2314 Project.Config.Auto_Init_Supported :=
2315 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2316 exception
2317 when Constraint_Error =>
2318 Error_Msg
2319 (Data.Flags,
2321 & Get_Name_String (Attribute.Value.Value)
2323 Attribute.Value.Location, Project);
2324 end;
2326 elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then
2327 List := Attribute.Value.Values;
2329 if List /= Nil_String then
2330 Put (Into_List => Project.Config.Shared_Lib_Min_Options,
2331 From_List => List,
2332 In_Tree => Data.Tree);
2333 end if;
2335 elsif Attribute.Name = Name_Library_Version_Switches then
2336 List := Attribute.Value.Values;
2338 if List /= Nil_String then
2339 Put (Into_List => Project.Config.Lib_Version_Options,
2340 From_List => List,
2341 In_Tree => Data.Tree);
2342 end if;
2343 end if;
2344 end if;
2346 Attribute_Id := Attribute.Next;
2347 end loop;
2348 end Process_Project_Level_Simple_Attributes;
2350 --------------------------------------------
2351 -- Process_Project_Level_Array_Attributes --
2352 --------------------------------------------
2354 procedure Process_Project_Level_Array_Attributes is
2355 Current_Array_Id : Array_Id;
2356 Current_Array : Array_Data;
2357 Element_Id : Array_Element_Id;
2358 Element : Array_Element;
2359 List : String_List_Id;
2361 begin
2362 -- Process the associative array attributes at project level
2364 Current_Array_Id := Project.Decl.Arrays;
2365 while Current_Array_Id /= No_Array loop
2366 Current_Array := Shared.Arrays.Table (Current_Array_Id);
2368 Element_Id := Current_Array.Value;
2369 while Element_Id /= No_Array_Element loop
2370 Element := Shared.Array_Elements.Table (Element_Id);
2372 -- Get the name of the language
2374 Lang_Index :=
2375 Get_Language_From_Name
2376 (Project, Get_Name_String (Element.Index));
2378 if Lang_Index /= No_Language_Index then
2379 case Current_Array.Name is
2380 when Name_Inherit_Source_Path =>
2381 List := Element.Value.Values;
2383 if List /= Nil_String then
2384 Put
2385 (Into_List =>
2386 Lang_Index.Config.Include_Compatible_Languages,
2387 From_List => List,
2388 In_Tree => Data.Tree,
2389 Lower_Case => True);
2390 end if;
2392 when Name_Toolchain_Description =>
2394 -- Attribute Toolchain_Description (<language>)
2396 Lang_Index.Config.Toolchain_Description :=
2397 Element.Value.Value;
2399 when Name_Toolchain_Version =>
2401 -- Attribute Toolchain_Version (<language>)
2403 Lang_Index.Config.Toolchain_Version :=
2404 Element.Value.Value;
2406 -- For Ada, set proper checksum computation mode,
2407 -- which has changed from version to version.
2409 if Lang_Index.Name = Name_Ada then
2410 declare
2411 Vers : constant String :=
2412 Get_Name_String (Element.Value.Value);
2413 pragma Assert (Vers'First = 1);
2415 begin
2416 -- Version 6.3 or earlier
2418 if Vers'Length >= 8
2420 and then Vers (7) = '.'
2421 and then
2422 (Vers (6) < '6'
2423 or else
2424 (Vers (6) = '6' and then Vers (8) < '4'))
2425 then
2426 Checksum_GNAT_6_3 := True;
2428 -- Version 5.03 or earlier
2430 if Vers (6) < '5'
2431 or else (Vers (6) = '5'
2432 and then Vers (Vers'Last) < '4')
2433 then
2434 Checksum_GNAT_5_03 := True;
2436 -- Version 5.02 or earlier (no checksums)
2438 if Vers (6) /= '5'
2439 or else Vers (Vers'Last) < '3'
2440 then
2441 Checksum_Accumulate_Token_Checksum :=
2442 False;
2443 end if;
2444 end if;
2445 end if;
2446 end;
2447 end if;
2449 when Name_Runtime_Library_Dir =>
2451 -- Attribute Runtime_Library_Dir (<language>)
2453 Lang_Index.Config.Runtime_Library_Dir :=
2454 Element.Value.Value;
2456 when Name_Runtime_Source_Dir =>
2458 -- Attribute Runtime_Source_Dir (<language>)
2460 Lang_Index.Config.Runtime_Source_Dir :=
2461 Element.Value.Value;
2463 when Name_Object_Generated =>
2464 declare
2465 pragma Unsuppress (All_Checks);
2466 Value : Boolean;
2468 begin
2469 Value :=
2470 Boolean'Value
2471 (Get_Name_String (Element.Value.Value));
2473 Lang_Index.Config.Object_Generated := Value;
2475 -- If no object is generated, no object may be
2476 -- linked.
2478 if not Value then
2479 Lang_Index.Config.Objects_Linked := False;
2480 end if;
2482 exception
2483 when Constraint_Error =>
2484 Error_Msg
2485 (Data.Flags,
2487 & Get_Name_String (Element.Value.Value)
2489 Element.Value.Location, Project);
2490 end;
2492 when Name_Objects_Linked =>
2493 declare
2494 pragma Unsuppress (All_Checks);
2495 Value : Boolean;
2497 begin
2498 Value :=
2499 Boolean'Value
2500 (Get_Name_String (Element.Value.Value));
2502 -- No change if Object_Generated is False, as this
2503 -- forces Objects_Linked to be False too.
2505 if Lang_Index.Config.Object_Generated then
2506 Lang_Index.Config.Objects_Linked := Value;
2507 end if;
2509 exception
2510 when Constraint_Error =>
2511 Error_Msg
2512 (Data.Flags,
2514 & Get_Name_String (Element.Value.Value)
2516 Element.Value.Location, Project);
2517 end;
2519 when others =>
2520 null;
2521 end case;
2522 end if;
2524 Element_Id := Element.Next;
2525 end loop;
2527 Current_Array_Id := Current_Array.Next;
2528 end loop;
2529 end Process_Project_Level_Array_Attributes;
2531 -- Start of processing for Check_Configuration
2533 begin
2534 Process_Project_Level_Simple_Attributes;
2535 Process_Project_Level_Array_Attributes;
2536 Process_Packages;
2538 -- For unit based languages, set Casing, Dot_Replacement and
2539 -- Separate_Suffix in Naming_Data.
2541 Lang_Index := Project.Languages;
2542 while Lang_Index /= No_Language_Index loop
2543 if Lang_Index.Config.Kind = Unit_Based then
2544 Lang_Index.Config.Naming_Data.Casing := Casing;
2545 Lang_Index.Config.Naming_Data.Dot_Replacement := Dot_Replacement;
2547 if Separate_Suffix /= No_File then
2548 Lang_Index.Config.Naming_Data.Separate_Suffix :=
2549 Separate_Suffix;
2550 end if;
2552 exit;
2553 end if;
2555 Lang_Index := Lang_Index.Next;
2556 end loop;
2558 -- Give empty names to various prefixes/suffixes, if they have not
2559 -- been specified in the configuration.
2561 if Project.Config.Archive_Suffix = No_File then
2562 Project.Config.Archive_Suffix := Empty_File;
2563 end if;
2565 if Project.Config.Shared_Lib_Prefix = No_File then
2566 Project.Config.Shared_Lib_Prefix := Empty_File;
2567 end if;
2569 if Project.Config.Shared_Lib_Suffix = No_File then
2570 Project.Config.Shared_Lib_Suffix := Empty_File;
2571 end if;
2573 Lang_Index := Project.Languages;
2574 while Lang_Index /= No_Language_Index loop
2576 -- For all languages, Compiler_Driver needs to be specified. This is
2577 -- only needed if we do intend to compile (not in GPS for instance).
2579 if Data.Flags.Compiler_Driver_Mandatory
2580 and then Lang_Index.Config.Compiler_Driver = No_File
2581 and then not Project.Externally_Built
2582 then
2583 Error_Msg_Name_1 := Lang_Index.Display_Name;
2584 Error_Msg
2585 (Data.Flags,
2588 No_Location, Project);
2590 if Lang_Index = Project.Languages then
2591 Project.Languages := Lang_Index.Next;
2592 else
2593 Prev_Index.Next := Lang_Index.Next;
2594 end if;
2596 elsif Lang_Index.Config.Kind = Unit_Based then
2597 Prev_Index := Lang_Index;
2599 -- For unit based languages, Dot_Replacement, Spec_Suffix and
2600 -- Body_Suffix need to be specified.
2602 if Lang_Index.Config.Naming_Data.Dot_Replacement = No_File then
2603 Error_Msg
2604 (Data.Flags,
2606 Get_Name_String (Lang_Index.Name),
2607 No_Location, Project);
2608 end if;
2610 if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then
2611 Error_Msg
2612 (Data.Flags,
2614 Get_Name_String (Lang_Index.Name),
2615 No_Location, Project);
2616 end if;
2618 if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then
2619 Error_Msg
2620 (Data.Flags,
2622 Get_Name_String (Lang_Index.Name),
2623 No_Location, Project);
2624 end if;
2626 else
2627 Prev_Index := Lang_Index;
2629 -- For file based languages, either Spec_Suffix or Body_Suffix
2630 -- need to be specified.
2632 if Data.Flags.Require_Sources_Other_Lang
2633 and then Lang_Index.Config.Naming_Data.Spec_Suffix = No_File
2634 and then Lang_Index.Config.Naming_Data.Body_Suffix = No_File
2635 then
2636 Error_Msg_Name_1 := Lang_Index.Display_Name;
2637 Error_Msg
2638 (Data.Flags,
2640 No_Location, Project);
2641 end if;
2642 end if;
2644 Lang_Index := Lang_Index.Next;
2645 end loop;
2646 end Check_Configuration;
2648 -------------------------------
2649 -- Check_If_Externally_Built --
2650 -------------------------------
2652 procedure Check_If_Externally_Built
2653 (Project : Project_Id;
2654 Data : in out Tree_Processing_Data)
2655 is
2656 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
2657 Externally_Built : constant Variable_Value :=
2658 Util.Value_Of
2659 (Name_Externally_Built,
2660 Project.Decl.Attributes, Shared);
2662 begin
2663 if not Externally_Built.Default then
2664 Get_Name_String (Externally_Built.Value);
2665 To_Lower (Name_Buffer (1 .. Name_Len));
2668 Project.Externally_Built := True;
2671 Error_Msg (Data.Flags,
2673 Externally_Built.Location, Project);
2674 end if;
2675 end if;
2677 -- A virtual project extending an externally built project is itself
2678 -- externally built.
2680 if Project.Virtual and then Project.Extends /= No_Project then
2681 Project.Externally_Built := Project.Extends.Externally_Built;
2682 end if;
2684 if Project.Externally_Built then
2686 else
2688 end if;
2689 end Check_If_Externally_Built;
2691 ----------------------
2692 -- Check_Interfaces --
2693 ----------------------
2695 procedure Check_Interfaces
2696 (Project : Project_Id;
2697 Data : in out Tree_Processing_Data)
2698 is
2699 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
2701 Interfaces : constant Prj.Variable_Value :=
2702 Prj.Util.Value_Of
2703 (Snames.Name_Interfaces,
2704 Project.Decl.Attributes,
2705 Shared);
2707 Library_Interface : constant Prj.Variable_Value :=
2708 Prj.Util.Value_Of
2709 (Snames.Name_Library_Interface,
2710 Project.Decl.Attributes,
2711 Shared);
2713 List : String_List_Id;
2714 Element : String_Element;
2715 Name : File_Name_Type;
2716 Iter : Source_Iterator;
2717 Source : Source_Id;
2718 Project_2 : Project_Id;
2719 Other : Source_Id;
2720 Unit_Found : Boolean;
2722 Interface_ALIs : String_List_Id := Nil_String;
2723 Other_Interfaces : String_List_Id := Nil_String;
2725 begin
2726 if not Interfaces.Default then
2728 -- Set In_Interfaces to False for all sources. It will be set to True
2729 -- later for the sources in the Interfaces list.
2731 Project_2 := Project;
2732 while Project_2 /= No_Project loop
2733 Iter := For_Each_Source (Data.Tree, Project_2);
2734 loop
2735 Source := Prj.Element (Iter);
2736 exit when Source = No_Source;
2737 Source.In_Interfaces := False;
2738 Next (Iter);
2739 end loop;
2741 Project_2 := Project_2.Extends;
2742 end loop;
2744 List := Interfaces.Values;
2745 while List /= Nil_String loop
2746 Element := Shared.String_Elements.Table (List);
2747 Name := Canonical_Case_File_Name (Element.Value);
2749 Project_2 := Project;
2750 Big_Loop : while Project_2 /= No_Project loop
2751 if Project.Qualifier = Aggregate_Library then
2753 -- For an aggregate library we want to consider sources of
2754 -- all aggregated projects.
2756 Iter := For_Each_Source (Data.Tree);
2758 else
2759 Iter := For_Each_Source (Data.Tree, Project_2);
2760 end if;
2762 loop
2763 Source := Prj.Element (Iter);
2764 exit when Source = No_Source;
2766 if Source.File = Name then
2767 if not Source.Locally_Removed then
2768 Source.In_Interfaces := True;
2769 Source.Declared_In_Interfaces := True;
2771 Other := Other_Part (Source);
2773 if Other /= No_Source then
2774 Other.In_Interfaces := True;
2775 Other.Declared_In_Interfaces := True;
2776 end if;
2778 -- Unit based case
2780 if Source.Language.Config.Kind = Unit_Based then
2781 if Source.Kind = Spec
2782 and then Other_Part (Source) /= No_Source
2783 then
2784 Source := Other_Part (Source);
2785 end if;
2787 String_Element_Table.Increment_Last
2788 (Shared.String_Elements);
2790 Shared.String_Elements.Table
2791 (String_Element_Table.Last
2792 (Shared.String_Elements)) :=
2793 (Value => Name_Id (Source.Dep_Name),
2794 Index => 0,
2795 Display_Value => Name_Id (Source.Dep_Name),
2796 Location => No_Location,
2797 Flag => False,
2798 Next => Interface_ALIs);
2800 Interface_ALIs :=
2801 String_Element_Table.Last
2802 (Shared.String_Elements);
2804 -- File based case
2806 else
2807 String_Element_Table.Increment_Last
2808 (Shared.String_Elements);
2810 Shared.String_Elements.Table
2811 (String_Element_Table.Last
2812 (Shared.String_Elements)) :=
2813 (Value => Name_Id (Source.File),
2814 Index => 0,
2815 Display_Value => Name_Id (Source.Display_File),
2816 Location => No_Location,
2817 Flag => False,
2818 Next => Other_Interfaces);
2820 Other_Interfaces :=
2821 String_Element_Table.Last
2822 (Shared.String_Elements);
2823 end if;
2825 Debug_Output
2827 end if;
2829 exit Big_Loop;
2830 end if;
2832 Next (Iter);
2833 end loop;
2835 Project_2 := Project_2.Extends;
2836 end loop Big_Loop;
2838 if Source = No_Source then
2839 Error_Msg_File_1 := File_Name_Type (Element.Value);
2840 Error_Msg_Name_1 := Project.Name;
2842 Error_Msg
2843 (Data.Flags,
2846 Element.Location, Project);
2847 end if;
2849 List := Element.Next;
2850 end loop;
2852 Project.Interfaces_Defined := True;
2853 Project.Lib_Interface_ALIs := Interface_ALIs;
2854 Project.Other_Interfaces := Other_Interfaces;
2856 elsif Project.Library and then not Library_Interface.Default then
2858 -- Set In_Interfaces to False for all sources. It will be set to True
2859 -- later for the sources in the Library_Interface list.
2861 Project_2 := Project;
2862 while Project_2 /= No_Project loop
2863 Iter := For_Each_Source (Data.Tree, Project_2);
2864 loop
2865 Source := Prj.Element (Iter);
2866 exit when Source = No_Source;
2867 Source.In_Interfaces := False;
2868 Next (Iter);
2869 end loop;
2871 Project_2 := Project_2.Extends;
2872 end loop;
2874 List := Library_Interface.Values;
2875 while List /= Nil_String loop
2876 Element := Shared.String_Elements.Table (List);
2877 Get_Name_String (Element.Value);
2878 To_Lower (Name_Buffer (1 .. Name_Len));
2879 Name := Name_Find;
2880 Unit_Found := False;
2882 Project_2 := Project;
2883 Big_Loop_2 : while Project_2 /= No_Project loop
2884 if Project.Qualifier = Aggregate_Library then
2886 -- For an aggregate library we want to consider sources of
2887 -- all aggregated projects.
2889 Iter := For_Each_Source (Data.Tree);
2891 else
2892 Iter := For_Each_Source (Data.Tree, Project_2);
2893 end if;
2895 loop
2896 Source := Prj.Element (Iter);
2897 exit when Source = No_Source;
2899 if Source.Unit /= No_Unit_Index
2900 and then Source.Unit.Name = Name_Id (Name)
2901 then
2902 if not Source.Locally_Removed then
2903 Source.In_Interfaces := True;
2904 Source.Declared_In_Interfaces := True;
2905 Project.Interfaces_Defined := True;
2907 Other := Other_Part (Source);
2909 if Other /= No_Source then
2910 Other.In_Interfaces := True;
2911 Other.Declared_In_Interfaces := True;
2912 end if;
2914 Debug_Output
2917 if Source.Kind = Spec
2918 and then Other_Part (Source) /= No_Source
2919 then
2920 Source := Other_Part (Source);
2921 end if;
2923 String_Element_Table.Increment_Last
2924 (Shared.String_Elements);
2926 Shared.String_Elements.Table
2927 (String_Element_Table.Last
2928 (Shared.String_Elements)) :=
2929 (Value => Name_Id (Source.Dep_Name),
2930 Index => 0,
2931 Display_Value => Name_Id (Source.Dep_Name),
2932 Location => No_Location,
2933 Flag => False,
2934 Next => Interface_ALIs);
2936 Interface_ALIs :=
2937 String_Element_Table.Last (Shared.String_Elements);
2938 end if;
2940 Unit_Found := True;
2941 exit Big_Loop_2;
2942 end if;
2944 Next (Iter);
2945 end loop;
2947 Project_2 := Project_2.Extends;
2948 end loop Big_Loop_2;
2950 if not Unit_Found then
2951 Error_Msg_Name_1 := Name_Id (Name);
2953 Error_Msg
2954 (Data.Flags,
2956 Element.Location, Project);
2957 end if;
2959 List := Element.Next;
2960 end loop;
2962 Project.Lib_Interface_ALIs := Interface_ALIs;
2964 elsif Project.Extends /= No_Project
2965 and then Project.Extends.Interfaces_Defined
2966 then
2967 Project.Interfaces_Defined := True;
2969 Iter := For_Each_Source (Data.Tree, Project);
2970 loop
2971 Source := Prj.Element (Iter);
2972 exit when Source = No_Source;
2974 if not Source.Declared_In_Interfaces then
2975 Source.In_Interfaces := False;
2976 end if;
2978 Next (Iter);
2979 end loop;
2981 Project.Lib_Interface_ALIs := Project.Extends.Lib_Interface_ALIs;
2982 end if;
2983 end Check_Interfaces;
2985 ------------------------------
2986 -- Check_Library_Attributes --
2987 ------------------------------
2989 -- This procedure is awfully long (over 700 lines) should be broken up???
2991 procedure Check_Library_Attributes
2992 (Project : Project_Id;
2993 Data : in out Tree_Processing_Data)
2994 is
2995 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
2997 Attributes : constant Prj.Variable_Id := Project.Decl.Attributes;
2999 Lib_Dir : constant Prj.Variable_Value :=
3000 Prj.Util.Value_Of
3001 (Snames.Name_Library_Dir, Attributes, Shared);
3003 Lib_Name : constant Prj.Variable_Value :=
3004 Prj.Util.Value_Of
3005 (Snames.Name_Library_Name, Attributes, Shared);
3007 Lib_Standalone : constant Prj.Variable_Value :=
3008 Prj.Util.Value_Of
3009 (Snames.Name_Library_Standalone,
3010 Attributes, Shared);
3012 Lib_Version : constant Prj.Variable_Value :=
3013 Prj.Util.Value_Of
3014 (Snames.Name_Library_Version, Attributes, Shared);
3016 Lib_ALI_Dir : constant Prj.Variable_Value :=
3017 Prj.Util.Value_Of
3018 (Snames.Name_Library_Ali_Dir, Attributes, Shared);
3020 Lib_GCC : constant Prj.Variable_Value :=
3021 Prj.Util.Value_Of
3022 (Snames.Name_Library_GCC, Attributes, Shared);
3024 The_Lib_Kind : constant Prj.Variable_Value :=
3025 Prj.Util.Value_Of
3026 (Snames.Name_Library_Kind, Attributes, Shared);
3028 Imported_Project_List : Project_List;
3029 Continuation : String_Access := No_Continuation_String'Access;
3030 Support_For_Libraries : Library_Support;
3032 Library_Directory_Present : Boolean;
3034 procedure Check_Library (Proj : Project_Id; Extends : Boolean);
3035 -- Check if an imported or extended project if also a library project
3037 procedure Check_Aggregate_Library_Dirs;
3038 -- Check that the library directory and the library ALI directory of an
3039 -- aggregate library project are not the same as the object directory or
3040 -- the library directory of any of its aggregated projects.
3042 ----------------------------------
3043 -- Check_Aggregate_Library_Dirs --
3044 ----------------------------------
3046 procedure Check_Aggregate_Library_Dirs is
3047 procedure Process_Aggregate (Proj : Project_Id);
3048 -- Recursive procedure to check the aggregated projects, as they may
3049 -- also be aggregated library projects.
3051 -----------------------
3052 -- Process_Aggregate --
3053 -----------------------
3055 procedure Process_Aggregate (Proj : Project_Id) is
3056 Agg : Aggregated_Project_List;
3058 begin
3059 Agg := Proj.Aggregated_Projects;
3060 while Agg /= null loop
3061 Error_Msg_Name_1 := Agg.Project.Name;
3063 if Agg.Project.Qualifier /= Aggregate_Library
3064 and then Project.Library_ALI_Dir.Name =
3065 Agg.Project.Object_Directory.Name
3066 then
3067 Error_Msg
3068 (Data.Flags,
3071 The_Lib_Kind.Location, Project);
3073 elsif Project.Library_ALI_Dir.Name =
3074 Agg.Project.Library_Dir.Name
3075 then
3076 Error_Msg
3077 (Data.Flags,
3080 The_Lib_Kind.Location, Project);
3082 elsif Agg.Project.Qualifier /= Aggregate_Library
3083 and then Project.Library_Dir.Name =
3084 Agg.Project.Object_Directory.Name
3085 then
3086 Error_Msg
3087 (Data.Flags,
3090 The_Lib_Kind.Location, Project);
3092 elsif Project.Library_Dir.Name =
3093 Agg.Project.Library_Dir.Name
3094 then
3095 Error_Msg
3096 (Data.Flags,
3099 The_Lib_Kind.Location, Project);
3100 end if;
3102 if Agg.Project.Qualifier = Aggregate_Library then
3103 Process_Aggregate (Agg.Project);
3104 end if;
3106 Agg := Agg.Next;
3107 end loop;
3108 end Process_Aggregate;
3110 -- Start of processing for Check_Aggregate_Library_Dirs
3112 begin
3113 if Project.Qualifier = Aggregate_Library then
3114 Process_Aggregate (Project);
3115 end if;
3116 end Check_Aggregate_Library_Dirs;
3118 -------------------
3119 -- Check_Library --
3120 -------------------
3122 procedure Check_Library (Proj : Project_Id; Extends : Boolean) is
3123 Src_Id : Source_Id;
3124 Iter : Source_Iterator;
3126 begin
3127 if Proj /= No_Project then
3128 if not Proj.Library then
3130 -- The only not library projects that are OK are those that
3131 -- have no sources. However, header files from non-Ada
3132 -- languages are OK, as there is nothing to compile.
3134 Iter := For_Each_Source (Data.Tree, Proj);
3135 loop
3136 Src_Id := Prj.Element (Iter);
3137 exit when Src_Id = No_Source
3138 or else Src_Id.Language.Config.Kind /= File_Based
3139 or else Src_Id.Kind /= Spec;
3140 Next (Iter);
3141 end loop;
3143 if Src_Id /= No_Source then
3144 Error_Msg_Name_1 := Project.Name;
3145 Error_Msg_Name_2 := Proj.Name;
3147 if Extends then
3148 if Project.Library_Kind /= Static then
3149 Error_Msg
3150 (Data.Flags,
3151 Continuation.all &
3154 Project.Location, Project);
3155 Continuation := Continuation_String'Access;
3156 end if;
3158 elsif not Unchecked_Shared_Lib_Imports
3159 and then Project.Library_Kind /= Static
3160 then
3161 Error_Msg
3162 (Data.Flags,
3163 Continuation.all &
3166 Project.Location, Project);
3167 Continuation := Continuation_String'Access;
3168 end if;
3169 end if;
3171 elsif Project.Library_Kind /= Static
3172 and then not Lib_Standalone.Default
3174 and then Proj.Library_Kind /= Static
3175 then
3176 -- An encapsulated library must depend only on static libraries
3178 Error_Msg_Name_1 := Project.Name;
3179 Error_Msg_Name_2 := Proj.Name;
3181 Error_Msg
3182 (Data.Flags,
3183 Continuation.all &
3186 Project.Location, Project);
3187 Continuation := Continuation_String'Access;
3189 elsif Project.Library_Kind /= Static
3190 and then Proj.Library_Kind = Static
3191 and then
3192 (Lib_Standalone.Default
3193 or else
3195 then
3196 Error_Msg_Name_1 := Project.Name;
3197 Error_Msg_Name_2 := Proj.Name;
3199 if Extends then
3200 Error_Msg
3201 (Data.Flags,
3202 Continuation.all &
3205 Project.Location, Project);
3206 Continuation := Continuation_String'Access;
3208 elsif not Unchecked_Shared_Lib_Imports then
3209 Error_Msg
3210 (Data.Flags,
3211 Continuation.all &
3214 Project.Location, Project);
3215 Continuation := Continuation_String'Access;
3216 end if;
3218 end if;
3219 end if;
3220 end Check_Library;
3222 Dir_Exists : Boolean;
3224 -- Start of processing for Check_Library_Attributes
3226 begin
3227 Library_Directory_Present := Lib_Dir.Value /= Empty_String;
3229 -- Special case of extending project
3231 if Project.Extends /= No_Project then
3233 -- If the project extended is a library project, we inherit the
3234 -- library name, if it is not redefined; we check that the library
3235 -- directory is specified.
3237 if Project.Extends.Library then
3238 if Project.Qualifier = Standard then
3239 Error_Msg
3240 (Data.Flags,
3242 Project.Location, Project);
3244 else
3245 if Lib_Name.Default then
3246 Project.Library_Name := Project.Extends.Library_Name;
3247 end if;
3249 if Lib_Dir.Default then
3250 if not Project.Virtual then
3251 Error_Msg
3252 (Data.Flags,
3255 Project.Location, Project);
3257 else
3258 -- For a virtual project extending a library project,
3259 -- inherit library directory and library kind.
3261 Project.Library_Dir := Project.Extends.Library_Dir;
3262 Library_Directory_Present := True;
3263 Project.Library_Kind := Project.Extends.Library_Kind;
3264 end if;
3265 end if;
3266 end if;
3267 end if;
3268 end if;
3270 pragma Assert (Lib_Name.Kind = Single);
3272 if Lib_Name.Value = Empty_String then
3273 if Current_Verbosity = High
3274 and then Project.Library_Name = No_Name
3275 then
3276 Debug_Indent;
3278 end if;
3280 else
3281 -- There is no restriction on the syntax of library names
3283 Project.Library_Name := Lib_Name.Value;
3284 end if;
3286 if Project.Library_Name /= No_Name then
3287 if Current_Verbosity = High then
3288 Write_Attr
3290 end if;
3292 pragma Assert (Lib_Dir.Kind = Single);
3294 if not Library_Directory_Present then
3297 else
3298 -- Find path name (unless inherited), check that it is a directory
3300 if Project.Library_Dir = No_Path_Information then
3301 Locate_Directory
3302 (Project,
3303 File_Name_Type (Lib_Dir.Value),
3304 Path => Project.Library_Dir,
3305 Dir_Exists => Dir_Exists,
3306 Data => Data,
3308 Must_Exist => False,
3309 Location => Lib_Dir.Location,
3310 Externally_Built => Project.Externally_Built);
3312 else
3313 Dir_Exists :=
3314 Is_Directory
3315 (Get_Name_String (Project.Library_Dir.Display_Name));
3316 end if;
3318 if not Dir_Exists then
3319 if Directories_Must_Exist_In_Projects then
3321 -- Get the absolute name of the library directory that does
3322 -- not exist, to report an error.
3324 Err_Vars.Error_Msg_File_1 :=
3325 File_Name_Type (Project.Library_Dir.Display_Name);
3326 Error_Msg
3327 (Data.Flags,
3329 Lib_Dir.Location, Project);
3330 end if;
3332 -- Checks for object/source directories
3334 elsif not Project.Externally_Built
3336 -- An aggregate library does not have sources or objects, so
3337 -- these tests are not required in this case.
3339 and then Project.Qualifier /= Aggregate_Library
3340 then
3341 -- Library directory cannot be the same as Object directory
3343 if Project.Library_Dir.Name = Project.Object_Directory.Name then
3344 Error_Msg
3345 (Data.Flags,
3348 Lib_Dir.Location, Project);
3349 Project.Library_Dir := No_Path_Information;
3351 else
3352 declare
3353 OK : Boolean := True;
3354 Dirs_Id : String_List_Id;
3355 Dir_Elem : String_Element;
3356 Pid : Project_List;
3358 begin
3359 -- The library directory cannot be the same as a source
3360 -- directory of the current project.
3362 Dirs_Id := Project.Source_Dirs;
3363 while Dirs_Id /= Nil_String loop
3364 Dir_Elem := Shared.String_Elements.Table (Dirs_Id);
3365 Dirs_Id := Dir_Elem.Next;
3367 if Project.Library_Dir.Name =
3368 Path_Name_Type (Dir_Elem.Value)
3369 then
3370 Err_Vars.Error_Msg_File_1 :=
3371 File_Name_Type (Dir_Elem.Value);
3372 Error_Msg
3373 (Data.Flags,
3376 Lib_Dir.Location, Project);
3377 OK := False;
3378 exit;
3379 end if;
3380 end loop;
3382 if OK then
3384 -- The library directory cannot be the same as a
3385 -- source directory of another project either.
3387 Pid := Data.Tree.Projects;
3388 Project_Loop : loop
3389 exit Project_Loop when Pid = null;
3391 if Pid.Project /= Project then
3392 Dirs_Id := Pid.Project.Source_Dirs;
3394 Dir_Loop : while Dirs_Id /= Nil_String loop
3395 Dir_Elem :=
3396 Shared.String_Elements.Table (Dirs_Id);
3397 Dirs_Id := Dir_Elem.Next;
3399 if Project.Library_Dir.Name =
3400 Path_Name_Type (Dir_Elem.Value)
3401 then
3402 Err_Vars.Error_Msg_File_1 :=
3403 File_Name_Type (Dir_Elem.Value);
3404 Err_Vars.Error_Msg_Name_1 :=
3405 Pid.Project.Name;
3407 Error_Msg
3408 (Data.Flags,
3411 Lib_Dir.Location, Project);
3412 OK := False;
3413 exit Project_Loop;
3414 end if;
3415 end loop Dir_Loop;
3416 end if;
3418 Pid := Pid.Next;
3419 end loop Project_Loop;
3420 end if;
3422 if not OK then
3423 Project.Library_Dir := No_Path_Information;
3425 elsif Current_Verbosity = High then
3427 -- Display the Library directory in high verbosity
3429 Write_Attr
3431 Get_Name_String (Project.Library_Dir.Display_Name));
3432 end if;
3433 end;
3434 end if;
3435 end if;
3436 end if;
3438 end if;
3440 Project.Library :=
3441 Project.Library_Dir /= No_Path_Information
3442 and then Project.Library_Name /= No_Name;
3444 if Project.Extends = No_Project then
3445 case Project.Qualifier is
3446 when Standard =>
3447 if Project.Library then
3448 Error_Msg
3449 (Data.Flags,
3451 Lib_Name.Location, Project);
3452 end if;
3454 when Aggregate_Library
3455 | Library
3456 =>
3457 if not Project.Library then
3458 if Project.Library_Name = No_Name then
3459 Error_Msg
3460 (Data.Flags,
3462 Project.Location, Project);
3464 if not Library_Directory_Present then
3465 Error_Msg
3466 (Data.Flags,
3468 Project.Location, Project);
3469 end if;
3471 elsif Project.Library_Dir = No_Path_Information then
3472 Error_Msg
3473 (Data.Flags,
3475 Project.Location, Project);
3476 end if;
3477 end if;
3479 when others =>
3480 null;
3481 end case;
3482 end if;
3484 if Project.Library then
3485 Support_For_Libraries := Project.Config.Lib_Support;
3487 if not Project.Externally_Built
3488 and then Support_For_Libraries = Prj.None
3489 then
3490 Error_Msg
3491 (Data.Flags,
3493 Lib_Name.Location, Project);
3494 Project.Library := False;
3496 else
3497 if Lib_ALI_Dir.Value = Empty_String then
3499 Project.Library_ALI_Dir := Project.Library_Dir;
3501 else
3502 -- Find path name, check that it is a directory
3504 Locate_Directory
3505 (Project,
3506 File_Name_Type (Lib_ALI_Dir.Value),
3507 Path => Project.Library_ALI_Dir,
3509 Dir_Exists => Dir_Exists,
3510 Data => Data,
3511 Must_Exist => False,
3512 Location => Lib_ALI_Dir.Location,
3513 Externally_Built => Project.Externally_Built);
3515 if not Dir_Exists then
3517 -- Get the absolute name of the library ALI directory that
3518 -- does not exist, to report an error.
3520 Err_Vars.Error_Msg_File_1 :=
3521 File_Name_Type (Project.Library_ALI_Dir.Display_Name);
3522 Error_Msg
3523 (Data.Flags,
3525 Lib_ALI_Dir.Location, Project);
3526 end if;
3528 if not Project.Externally_Built
3529 and then Project.Library_ALI_Dir /= Project.Library_Dir
3530 then
3531 -- The library ALI directory cannot be the same as the
3532 -- Object directory.
3534 if Project.Library_ALI_Dir = Project.Object_Directory then
3535 Error_Msg
3536 (Data.Flags,
3539 Lib_ALI_Dir.Location, Project);
3540 Project.Library_ALI_Dir := No_Path_Information;
3542 else
3543 declare
3544 OK : Boolean := True;
3545 Dirs_Id : String_List_Id;
3546 Dir_Elem : String_Element;
3547 Pid : Project_List;
3549 begin
3550 -- The library ALI directory cannot be the same as
3551 -- a source directory of the current project.
3553 Dirs_Id := Project.Source_Dirs;
3554 while Dirs_Id /= Nil_String loop
3555 Dir_Elem := Shared.String_Elements.Table (Dirs_Id);
3556 Dirs_Id := Dir_Elem.Next;
3558 if Project.Library_ALI_Dir.Name =
3559 Path_Name_Type (Dir_Elem.Value)
3560 then
3561 Err_Vars.Error_Msg_File_1 :=
3562 File_Name_Type (Dir_Elem.Value);
3563 Error_Msg
3564 (Data.Flags,
3567 Lib_ALI_Dir.Location, Project);
3568 OK := False;
3569 exit;
3570 end if;
3571 end loop;
3573 if OK then
3575 -- The library ALI directory cannot be the same as
3576 -- a source directory of another project either.
3578 Pid := Data.Tree.Projects;
3579 ALI_Project_Loop : loop
3580 exit ALI_Project_Loop when Pid = null;
3582 if Pid.Project /= Project then
3583 Dirs_Id := Pid.Project.Source_Dirs;
3585 ALI_Dir_Loop :
3586 while Dirs_Id /= Nil_String loop
3587 Dir_Elem :=
3588 Shared.String_Elements.Table (Dirs_Id);
3589 Dirs_Id := Dir_Elem.Next;
3591 if Project.Library_ALI_Dir.Name =
3592 Path_Name_Type (Dir_Elem.Value)
3593 then
3594 Err_Vars.Error_Msg_File_1 :=
3595 File_Name_Type (Dir_Elem.Value);
3596 Err_Vars.Error_Msg_Name_1 :=
3597 Pid.Project.Name;
3599 Error_Msg
3600 (Data.Flags,
3604 Lib_ALI_Dir.Location, Project);
3605 OK := False;
3606 exit ALI_Project_Loop;
3607 end if;
3608 end loop ALI_Dir_Loop;
3609 end if;
3610 Pid := Pid.Next;
3611 end loop ALI_Project_Loop;
3612 end if;
3614 if not OK then
3615 Project.Library_ALI_Dir := No_Path_Information;
3617 elsif Current_Verbosity = High then
3619 -- Display Library ALI directory in high verbosity
3621 Write_Attr
3623 Get_Name_String
3624 (Project.Library_ALI_Dir.Display_Name));
3625 end if;
3626 end;
3627 end if;
3628 end if;
3629 end if;
3631 pragma Assert (Lib_Version.Kind = Single);
3633 if Lib_Version.Value = Empty_String then
3636 else
3637 Project.Lib_Internal_Name := Lib_Version.Value;
3638 end if;
3640 pragma Assert (The_Lib_Kind.Kind = Single);
3642 if The_Lib_Kind.Value = Empty_String then
3645 else
3646 Get_Name_String (The_Lib_Kind.Value);
3648 declare
3649 Kind_Name : constant String :=
3650 To_Lower (Name_Buffer (1 .. Name_Len));
3652 OK : Boolean := True;
3654 begin
3656 Project.Library_Kind := Static;
3659 Project.Library_Kind := Dynamic;
3662 Project.Library_Kind := Relocatable;
3664 else
3665 Error_Msg
3666 (Data.Flags,
3668 The_Lib_Kind.Location, Project);
3669 OK := False;
3670 end if;
3672 if Current_Verbosity = High and then OK then
3674 end if;
3676 if Project.Library_Kind /= Static then
3677 if not Project.Externally_Built
3678 and then Support_For_Libraries = Prj.Static_Only
3679 then
3680 Error_Msg
3681 (Data.Flags,
3684 The_Lib_Kind.Location, Project);
3685 Project.Library := False;
3687 else
3688 -- Check if (obsolescent) attribute Library_GCC or
3689 -- Linker'Driver is declared.
3691 if Lib_GCC.Value /= Empty_String then
3692 Error_Msg
3693 (Data.Flags,
3696 Lib_GCC.Location, Project);
3697 Project.Config.Shared_Lib_Driver :=
3698 File_Name_Type (Lib_GCC.Value);
3700 else
3701 declare
3702 Linker : constant Package_Id :=
3703 Value_Of
3704 (Name_Linker,
3705 Project.Decl.Packages,
3706 Shared);
3707 Driver : constant Variable_Value :=
3708 Value_Of
3709 (Name => No_Name,
3710 Attribute_Or_Array_Name =>
3711 Name_Driver,
3712 In_Package => Linker,
3713 Shared => Shared);
3715 begin
3716 if Driver /= Nil_Variable_Value
3717 and then Driver.Value /= Empty_String
3718 then
3719 Project.Config.Shared_Lib_Driver :=
3720 File_Name_Type (Driver.Value);
3721 end if;
3722 end;
3723 end if;
3724 end if;
3725 end if;
3726 end;
3727 end if;
3729 if Project.Library
3730 and then Project.Qualifier /= Aggregate_Library
3731 then
3732 Debug_Output ("this is a library project file");
3734 Check_Library (Project.Extends, Extends => True);
3736 Imported_Project_List := Project.Imported_Projects;
3737 while Imported_Project_List /= null loop
3738 Check_Library
3739 (Imported_Project_List.Project,
3740 Extends => False);
3741 Imported_Project_List := Imported_Project_List.Next;
3742 end loop;
3743 end if;
3744 end if;
3745 end if;
3747 -- Check if Linker'Switches or Linker'Default_Switches are declared.
3748 -- Warn if they are declared, as it is a common error to think that
3749 -- library are "linked" with Linker switches.
3751 if Project.Library then
3752 declare
3753 Linker_Package_Id : constant Package_Id :=
3754 Util.Value_Of
3755 (Name_Linker,
3756 Project.Decl.Packages, Shared);
3757 Linker_Package : Package_Element;
3758 Switches : Array_Element_Id := No_Array_Element;
3760 begin
3761 if Linker_Package_Id /= No_Package then
3762 Linker_Package := Shared.Packages.Table (Linker_Package_Id);
3764 Switches :=
3765 Value_Of
3766 (Name => Name_Switches,
3767 In_Arrays => Linker_Package.Decl.Arrays,
3768 Shared => Shared);
3770 if Switches = No_Array_Element then
3771 Switches :=
3772 Value_Of
3773 (Name => Name_Default_Switches,
3774 In_Arrays => Linker_Package.Decl.Arrays,
3775 Shared => Shared);
3776 end if;
3778 if Switches /= No_Array_Element then
3779 Error_Msg
3780 (Data.Flags,
3782 "projects",
3783 No_Location, Project);
3784 end if;
3785 end if;
3786 end;
3787 end if;
3789 if Project.Extends /= No_Project and then Project.Extends.Library then
3791 -- Remove the library name from Lib_Data_Table
3793 for J in 1 .. Lib_Data_Table.Last loop
3794 if Lib_Data_Table.Table (J).Proj = Project.Extends then
3795 Lib_Data_Table.Table (J) :=
3796 Lib_Data_Table.Table (Lib_Data_Table.Last);
3797 Lib_Data_Table.Set_Last (Lib_Data_Table.Last - 1);
3798 exit;
3799 end if;
3800 end loop;
3801 end if;
3803 if Project.Library and then not Lib_Name.Default then
3805 -- Check if the same library name is used in an other library project
3807 for J in 1 .. Lib_Data_Table.Last loop
3808 if Lib_Data_Table.Table (J).Name = Project.Library_Name
3809 and then Lib_Data_Table.Table (J).Tree = Data.Tree
3810 then
3811 Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name;
3812 Error_Msg
3813 (Data.Flags,
3814 "Library name cannot be the same as in project %%",
3815 Lib_Name.Location, Project);
3816 Project.Library := False;
3817 exit;
3818 end if;
3819 end loop;
3820 end if;
3822 if not Lib_Standalone.Default
3823 and then Project.Library_Kind = Static
3824 then
3825 -- An standalone library must be a shared library
3827 Error_Msg_Name_1 := Project.Name;
3829 Error_Msg
3830 (Data.Flags,
3831 Continuation.all &
3832 "standalone library project %% must be a shared library",
3833 Project.Location, Project);
3834 Continuation := Continuation_String'Access;
3835 end if;
3837 -- Check that aggregated libraries do not share the aggregate
3838 -- Library_ALI_Dir.
3840 if Project.Qualifier = Aggregate_Library then
3841 Check_Aggregate_Library_Dirs;
3842 end if;
3844 if Project.Library and not Data.In_Aggregate_Lib then
3846 -- Record the library name
3848 Lib_Data_Table.Append
3849 ((Name => Project.Library_Name,
3850 Proj => Project,
3851 Tree => Data.Tree));
3852 end if;
3853 end Check_Library_Attributes;
3855 --------------------------
3856 -- Check_Package_Naming --
3857 --------------------------
3859 procedure Check_Package_Naming
3860 (Project : Project_Id;
3861 Data : in out Tree_Processing_Data)
3862 is
3863 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
3864 Naming_Id : constant Package_Id :=
3865 Util.Value_Of
3866 (Name_Naming, Project.Decl.Packages, Shared);
3867 Naming : Package_Element;
3869 Ada_Body_Suffix_Loc : Source_Ptr := No_Location;
3871 procedure Check_Naming;
3872 -- Check the validity of the Naming package (suffixes valid, ...)
3874 procedure Check_Common
3875 (Dot_Replacement : in out File_Name_Type;
3876 Casing : in out Casing_Type;
3877 Casing_Defined : out Boolean;
3878 Separate_Suffix : in out File_Name_Type;
3879 Sep_Suffix_Loc : out Source_Ptr);
3880 -- Check attributes common
3882 procedure Process_Exceptions_File_Based
3883 (Lang_Id : Language_Ptr;
3884 Kind : Source_Kind);
3885 procedure Process_Exceptions_Unit_Based
3886 (Lang_Id : Language_Ptr;
3887 Kind : Source_Kind);
3888 -- Process the naming exceptions for the two types of languages
3890 procedure Initialize_Naming_Data;
3891 -- Initialize internal naming data for the various languages
3893 ------------------
3894 -- Check_Common --
3895 ------------------
3897 procedure Check_Common
3898 (Dot_Replacement : in out File_Name_Type;
3899 Casing : in out Casing_Type;
3900 Casing_Defined : out Boolean;
3901 Separate_Suffix : in out File_Name_Type;
3902 Sep_Suffix_Loc : out Source_Ptr)
3903 is
3904 Dot_Repl : constant Variable_Value :=
3905 Util.Value_Of
3906 (Name_Dot_Replacement,
3907 Naming.Decl.Attributes,
3908 Shared);
3909 Casing_String : constant Variable_Value :=
3910 Util.Value_Of
3911 (Name_Casing,
3912 Naming.Decl.Attributes,
3913 Shared);
3914 Sep_Suffix : constant Variable_Value :=
3915 Util.Value_Of
3916 (Name_Separate_Suffix,
3917 Naming.Decl.Attributes,
3918 Shared);
3919 Dot_Repl_Loc : Source_Ptr;
3921 begin
3922 Sep_Suffix_Loc := No_Location;
3924 if not Dot_Repl.Default then
3925 pragma Assert
3926 (Dot_Repl.Kind = Single, "Dot_Replacement is not a string");
3928 if Length_Of_Name (Dot_Repl.Value) = 0 then
3929 Error_Msg
3930 (Data.Flags, "Dot_Replacement cannot be empty",
3931 Dot_Repl.Location, Project);
3932 end if;
3934 Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value);
3935 Dot_Repl_Loc := Dot_Repl.Location;
3937 declare
3938 Repl : constant String := Get_Name_String (Dot_Replacement);
3940 begin
3941 -- Dot_Replacement cannot
3942 -- - be empty
3943 -- - start or end with an alphanumeric
3948 if Repl'Length = 0
3949 or else Is_Alphanumeric (Repl (Repl'First))
3950 or else Is_Alphanumeric (Repl (Repl'Last))
3952 and then
3953 (Repl'Length = 1
3954 or else
3955 Is_Alphanumeric (Repl (Repl'First + 1))))
3956 or else (Repl'Length > 1
3957 and then
3958 Index (Source => Repl, Pattern => ".") /= 0)
3959 then
3960 Error_Msg
3961 (Data.Flags,
3964 Dot_Repl_Loc, Project);
3965 end if;
3966 end;
3967 end if;
3969 if Dot_Replacement /= No_File then
3970 Write_Attr
3972 end if;
3974 Casing_Defined := False;
3976 if not Casing_String.Default then
3977 pragma Assert
3980 declare
3981 Casing_Image : constant String :=
3982 Get_Name_String (Casing_String.Value);
3984 begin
3985 if Casing_Image'Length = 0 then
3986 Error_Msg
3987 (Data.Flags,
3989 Casing_String.Location, Project);
3990 end if;
3992 Casing := Value (Casing_Image);
3993 Casing_Defined := True;
3995 exception
3996 when Constraint_Error =>
3997 Name_Len := Casing_Image'Length;
3998 Name_Buffer (1 .. Name_Len) := Casing_Image;
3999 Err_Vars.Error_Msg_Name_1 := Name_Find;
4000 Error_Msg
4001 (Data.Flags,
4003 Casing_String.Location, Project);
4004 end;
4005 end if;
4009 if not Sep_Suffix.Default then
4010 if Length_Of_Name (Sep_Suffix.Value) = 0 then
4011 Error_Msg
4012 (Data.Flags,
4014 Sep_Suffix.Location, Project);
4016 else
4017 Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value);
4018 Sep_Suffix_Loc := Sep_Suffix.Location;
4020 Check_Illegal_Suffix
4021 (Project, Separate_Suffix,
4023 Data);
4024 end if;
4025 end if;
4027 if Separate_Suffix /= No_File then
4028 Write_Attr
4030 end if;
4031 end Check_Common;
4033 -----------------------------------
4034 -- Process_Exceptions_File_Based --
4035 -----------------------------------
4037 procedure Process_Exceptions_File_Based
4038 (Lang_Id : Language_Ptr;
4039 Kind : Source_Kind)
4040 is
4041 Lang : constant Name_Id := Lang_Id.Name;
4042 Exceptions : Array_Element_Id;
4043 Exception_List : Variable_Value;
4044 Element_Id : String_List_Id;
4045 Element : String_Element;
4046 File_Name : File_Name_Type;
4047 Source : Source_Id;
4049 begin
4050 case Kind is
4051 when Impl
4052 | Sep
4053 =>
4054 Exceptions :=
4055 Value_Of
4056 (Name_Implementation_Exceptions,
4057 In_Arrays => Naming.Decl.Arrays,
4058 Shared => Shared);
4060 when Spec =>
4061 Exceptions :=
4062 Value_Of
4063 (Name_Specification_Exceptions,
4064 In_Arrays => Naming.Decl.Arrays,
4065 Shared => Shared);
4066 end case;
4068 Exception_List :=
4069 Value_Of
4070 (Index => Lang,
4071 In_Array => Exceptions,
4072 Shared => Shared);
4074 if Exception_List /= Nil_Variable_Value then
4075 Element_Id := Exception_List.Values;
4076 while Element_Id /= Nil_String loop
4077 Element := Shared.String_Elements.Table (Element_Id);
4078 File_Name := Canonical_Case_File_Name (Element.Value);
4080 Source :=
4081 Source_Files_Htable.Get
4082 (Data.Tree.Source_Files_HT, File_Name);
4083 while Source /= No_Source
4084 and then Source.Project /= Project
4085 loop
4086 Source := Source.Next_With_File_Name;
4087 end loop;
4089 if Source = No_Source then
4090 Add_Source
4091 (Id => Source,
4092 Data => Data,
4093 Project => Project,
4094 Source_Dir_Rank => 0,
4095 Lang_Id => Lang_Id,
4096 Kind => Kind,
4097 File_Name => File_Name,
4098 Display_File => File_Name_Type (Element.Value),
4099 Naming_Exception => Yes,
4100 Location => Element.Location);
4102 else
4103 -- Check if the file name is already recorded for another
4104 -- language or another kind.
4106 if Source.Language /= Lang_Id then
4107 Error_Msg
4108 (Data.Flags,
4110 Element.Location, Project);
4112 elsif Source.Kind /= Kind then
4113 Error_Msg
4114 (Data.Flags,
4116 Element.Location, Project);
4117 end if;
4119 -- If the file is already recorded for the same
4120 -- language and the same kind, it means that the file
4121 -- name appears several times in the *_Exceptions
4122 -- attribute; so there is nothing to do.
4123 end if;
4125 Element_Id := Element.Next;
4126 end loop;
4127 end if;
4128 end Process_Exceptions_File_Based;
4130 -----------------------------------
4131 -- Process_Exceptions_Unit_Based --
4132 -----------------------------------
4134 procedure Process_Exceptions_Unit_Based
4135 (Lang_Id : Language_Ptr;
4136 Kind : Source_Kind)
4137 is
4138 Exceptions : Array_Element_Id;
4139 Element : Array_Element;
4140 Unit : Name_Id;
4141 Index : Int;
4142 File_Name : File_Name_Type;
4143 Source : Source_Id;
4145 Naming_Exception : Naming_Exception_Type;
4147 begin
4148 case Kind is
4149 when Impl
4150 | Sep
4151 =>
4152 Exceptions :=
4153 Value_Of
4154 (Name_Body,
4155 In_Arrays => Naming.Decl.Arrays,
4156 Shared => Shared);
4158 if Exceptions = No_Array_Element then
4159 Exceptions :=
4160 Value_Of
4161 (Name_Implementation,
4162 In_Arrays => Naming.Decl.Arrays,
4163 Shared => Shared);
4164 end if;
4166 when Spec =>
4167 Exceptions :=
4168 Value_Of
4169 (Name_Spec,
4170 In_Arrays => Naming.Decl.Arrays,
4171 Shared => Shared);
4173 if Exceptions = No_Array_Element then
4174 Exceptions :=
4175 Value_Of
4176 (Name_Specification,
4177 In_Arrays => Naming.Decl.Arrays,
4178 Shared => Shared);
4179 end if;
4180 end case;
4182 while Exceptions /= No_Array_Element loop
4183 Element := Shared.Array_Elements.Table (Exceptions);
4185 if Element.Restricted then
4186 Naming_Exception := Inherited;
4187 else
4188 Naming_Exception := Yes;
4189 end if;
4191 File_Name := Canonical_Case_File_Name (Element.Value.Value);
4193 Get_Name_String (Element.Index);
4194 To_Lower (Name_Buffer (1 .. Name_Len));
4195 Index := Element.Value.Index;
4197 -- Check if it is a valid unit name
4199 Get_Name_String (Element.Index);
4200 Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit);
4202 if Unit = No_Name then
4203 Err_Vars.Error_Msg_Name_1 := Element.Index;
4204 Error_Msg
4205 (Data.Flags,
4207 Element.Value.Location, Project);
4208 end if;
4210 if Unit /= No_Name then
4211 Add_Source
4212 (Id => Source,
4213 Data => Data,
4214 Project => Project,
4215 Source_Dir_Rank => 0,
4216 Lang_Id => Lang_Id,
4217 Kind => Kind,
4218 File_Name => File_Name,
4219 Display_File => File_Name_Type (Element.Value.Value),
4220 Unit => Unit,
4221 Index => Index,
4222 Location => Element.Value.Location,
4223 Naming_Exception => Naming_Exception);
4224 end if;
4226 Exceptions := Element.Next;
4227 end loop;
4228 end Process_Exceptions_Unit_Based;
4230 ------------------
4231 -- Check_Naming --
4232 ------------------
4234 procedure Check_Naming is
4235 Dot_Replacement : File_Name_Type :=
4236 File_Name_Type
4237 (First_Name_Id + Character'Pos ('-'));
4238 Separate_Suffix : File_Name_Type := No_File;
4239 Casing : Casing_Type := All_Lower_Case;
4240 Casing_Defined : Boolean;
4241 Lang_Id : Language_Ptr;
4242 Sep_Suffix_Loc : Source_Ptr;
4243 Suffix : Variable_Value;
4244 Lang : Name_Id;
4246 begin
4247 Check_Common
4248 (Dot_Replacement => Dot_Replacement,
4249 Casing => Casing,
4250 Casing_Defined => Casing_Defined,
4251 Separate_Suffix => Separate_Suffix,
4252 Sep_Suffix_Loc => Sep_Suffix_Loc);
4254 -- For all unit based languages, if any, set the specified value
4255 -- of Dot_Replacement, Casing and/or Separate_Suffix. Do not
4256 -- systematically overwrite, since the defaults come from the
4257 -- configuration file.
4259 if Dot_Replacement /= No_File
4260 or else Casing_Defined
4261 or else Separate_Suffix /= No_File
4262 then
4263 Lang_Id := Project.Languages;
4264 while Lang_Id /= No_Language_Index loop
4265 if Lang_Id.Config.Kind = Unit_Based then
4266 if Dot_Replacement /= No_File then
4267 Lang_Id.Config.Naming_Data.Dot_Replacement :=
4268 Dot_Replacement;
4269 end if;
4271 if Casing_Defined then
4272 Lang_Id.Config.Naming_Data.Casing := Casing;
4273 end if;
4274 end if;
4276 Lang_Id := Lang_Id.Next;
4277 end loop;
4278 end if;
4280 -- Next, get the spec and body suffixes
4282 Lang_Id := Project.Languages;
4283 while Lang_Id /= No_Language_Index loop
4284 Lang := Lang_Id.Name;
4286 -- Spec_Suffix
4288 Suffix := Value_Of
4289 (Name => Lang,
4290 Attribute_Or_Array_Name => Name_Spec_Suffix,
4291 In_Package => Naming_Id,
4292 Shared => Shared);
4294 if Suffix = Nil_Variable_Value then
4295 Suffix := Value_Of
4296 (Name => Lang,
4297 Attribute_Or_Array_Name => Name_Specification_Suffix,
4298 In_Package => Naming_Id,
4299 Shared => Shared);
4300 end if;
4302 if Suffix /= Nil_Variable_Value
4303 and then Suffix.Value /= No_Name
4304 then
4305 Lang_Id.Config.Naming_Data.Spec_Suffix :=
4306 File_Name_Type (Suffix.Value);
4308 Check_Illegal_Suffix
4309 (Project,
4310 Lang_Id.Config.Naming_Data.Spec_Suffix,
4311 Lang_Id.Config.Naming_Data.Dot_Replacement,
4314 Write_Attr
4316 Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix));
4317 end if;
4319 -- Body_Suffix
4321 Suffix :=
4322 Value_Of
4323 (Name => Lang,
4324 Attribute_Or_Array_Name => Name_Body_Suffix,
4325 In_Package => Naming_Id,
4326 Shared => Shared);
4328 if Suffix = Nil_Variable_Value then
4329 Suffix :=
4330 Value_Of
4331 (Name => Lang,
4332 Attribute_Or_Array_Name => Name_Implementation_Suffix,
4333 In_Package => Naming_Id,
4334 Shared => Shared);
4335 end if;
4337 if Suffix /= Nil_Variable_Value
4338 and then Suffix.Value /= No_Name
4339 then
4340 Lang_Id.Config.Naming_Data.Body_Suffix :=
4341 File_Name_Type (Suffix.Value);
4343 -- The default value of separate suffix should be the same as
4344 -- the body suffix, so we need to compute that first.
4346 if Separate_Suffix = No_File then
4347 Lang_Id.Config.Naming_Data.Separate_Suffix :=
4348 Lang_Id.Config.Naming_Data.Body_Suffix;
4349 Write_Attr
4351 Get_Name_String
4352 (Lang_Id.Config.Naming_Data.Separate_Suffix));
4353 else
4354 Lang_Id.Config.Naming_Data.Separate_Suffix :=
4355 Separate_Suffix;
4356 end if;
4358 Check_Illegal_Suffix
4359 (Project,
4360 Lang_Id.Config.Naming_Data.Body_Suffix,
4361 Lang_Id.Config.Naming_Data.Dot_Replacement,
4364 Write_Attr
4366 Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix));
4368 elsif Separate_Suffix /= No_File then
4369 Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix;
4370 end if;
4372 -- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix,
4373 -- since that would cause a clear ambiguity. Note that we do allow
4374 -- a Spec_Suffix to have the same termination as one of these,
4375 -- which causes a potential ambiguity, but we resolve that by
4376 -- matching the longest possible suffix.
4378 if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File
4379 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
4380 Lang_Id.Config.Naming_Data.Body_Suffix
4381 then
4382 Error_Msg
4383 (Data.Flags,
4385 & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)
4387 Ada_Body_Suffix_Loc, Project);
4388 end if;
4390 if Lang_Id.Config.Naming_Data.Body_Suffix /=
4391 Lang_Id.Config.Naming_Data.Separate_Suffix
4392 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
4393 Lang_Id.Config.Naming_Data.Separate_Suffix
4394 then
4395 Error_Msg
4396 (Data.Flags,
4398 & Get_Name_String
4399 (Lang_Id.Config.Naming_Data.Separate_Suffix)
4401 Sep_Suffix_Loc, Project);
4402 end if;
4404 Lang_Id := Lang_Id.Next;
4405 end loop;
4407 -- Get the naming exceptions for all languages, but not for virtual
4408 -- projects.
4410 if not Project.Virtual then
4411 for Kind in Spec_Or_Body loop
4412 Lang_Id := Project.Languages;
4413 while Lang_Id /= No_Language_Index loop
4414 case Lang_Id.Config.Kind is
4415 when File_Based =>
4416 Process_Exceptions_File_Based (Lang_Id, Kind);
4418 when Unit_Based =>
4419 Process_Exceptions_Unit_Based (Lang_Id, Kind);
4420 end case;
4422 Lang_Id := Lang_Id.Next;
4423 end loop;
4424 end loop;
4425 end if;
4426 end Check_Naming;
4428 ----------------------------
4429 -- Initialize_Naming_Data --
4430 ----------------------------
4432 procedure Initialize_Naming_Data is
4433 Specs : Array_Element_Id :=
4434 Util.Value_Of
4435 (Name_Spec_Suffix,
4436 Naming.Decl.Arrays,
4437 Shared);
4439 Impls : Array_Element_Id :=
4440 Util.Value_Of
4441 (Name_Body_Suffix,
4442 Naming.Decl.Arrays,
4443 Shared);
4445 Lang : Language_Ptr;
4446 Lang_Name : Name_Id;
4447 Value : Variable_Value;
4448 Extended : Project_Id;
4450 begin
4451 -- At this stage, the project already contains the default extensions
4452 -- for the various languages. We now merge those suffixes read in the
4453 -- user project, and they override the default.
4455 while Specs /= No_Array_Element loop
4456 Lang_Name := Shared.Array_Elements.Table (Specs).Index;
4457 Lang :=
4458 Get_Language_From_Name
4459 (Project, Name => Get_Name_String (Lang_Name));
4461 -- An extending project inherits its parent projects' languages
4462 -- so if needed we should create entries for those languages
4464 if Lang = null then
4465 Extended := Project.Extends;
4466 while Extended /= null loop
4467 Lang := Get_Language_From_Name
4468 (Extended, Name => Get_Name_String (Lang_Name));
4469 exit when Lang /= null;
4471 Extended := Extended.Extends;
4472 end loop;
4474 if Lang /= null then
4475 Lang := new Language_Data'(Lang.all);
4476 Lang.First_Source := null;
4477 Lang.Next := Project.Languages;
4478 Project.Languages := Lang;
4479 end if;
4480 end if;
4482 -- If language was not found in project or the projects it extends
4484 if Lang = null then
4485 Debug_Output
4487 Lang_Name);
4489 else
4490 Value := Shared.Array_Elements.Table (Specs).Value;
4492 if Value.Kind = Single then
4493 Lang.Config.Naming_Data.Spec_Suffix :=
4494 Canonical_Case_File_Name (Value.Value);
4495 end if;
4496 end if;
4498 Specs := Shared.Array_Elements.Table (Specs).Next;
4499 end loop;
4501 while Impls /= No_Array_Element loop
4502 Lang_Name := Shared.Array_Elements.Table (Impls).Index;
4503 Lang :=
4504 Get_Language_From_Name
4505 (Project, Name => Get_Name_String (Lang_Name));
4507 if Lang = null then
4508 Debug_Output
4510 Lang_Name);
4511 else
4512 Value := Shared.Array_Elements.Table (Impls).Value;
4514 if Lang.Name = Name_Ada then
4515 Ada_Body_Suffix_Loc := Value.Location;
4516 end if;
4518 if Value.Kind = Single then
4519 Lang.Config.Naming_Data.Body_Suffix :=
4520 Canonical_Case_File_Name (Value.Value);
4521 end if;
4522 end if;
4524 Impls := Shared.Array_Elements.Table (Impls).Next;
4525 end loop;
4526 end Initialize_Naming_Data;
4528 -- Start of processing for Check_Naming_Schemes
4530 begin
4531 -- No Naming package or parsing a configuration file? nothing to do
4533 if Naming_Id /= No_Package
4534 and then Project.Qualifier /= Configuration
4535 then
4536 Naming := Shared.Packages.Table (Naming_Id);
4538 Initialize_Naming_Data;
4539 Check_Naming;
4541 end if;
4542 end Check_Package_Naming;
4544 ---------------------------------
4545 -- Check_Programming_Languages --
4546 ---------------------------------
4548 procedure Check_Programming_Languages
4549 (Project : Project_Id;
4550 Data : in out Tree_Processing_Data)
4551 is
4552 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
4554 Languages : Variable_Value := Nil_Variable_Value;
4555 Def_Lang : Variable_Value := Nil_Variable_Value;
4556 Def_Lang_Id : Name_Id;
4558 procedure Add_Language (Name, Display_Name : Name_Id);
4559 -- Add a new language to the list of languages for the project.
4560 -- Nothing is done if the language has already been defined
4562 ------------------
4563 -- Add_Language --
4564 ------------------
4566 procedure Add_Language (Name, Display_Name : Name_Id) is
4567 Lang : Language_Ptr;
4569 begin
4570 Lang := Project.Languages;
4571 while Lang /= No_Language_Index loop
4572 if Name = Lang.Name then
4573 return;
4574 end if;
4576 Lang := Lang.Next;
4577 end loop;
4579 Lang := new Language_Data'(No_Language_Data);
4580 Lang.Next := Project.Languages;
4581 Project.Languages := Lang;
4582 Lang.Name := Name;
4583 Lang.Display_Name := Display_Name;
4584 end Add_Language;
4586 -- Start of processing for Check_Programming_Languages
4588 begin
4589 Project.Languages := null;
4590 Languages :=
4591 Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, Shared);
4592 Def_Lang :=
4593 Prj.Util.Value_Of
4594 (Name_Default_Language, Project.Decl.Attributes, Shared);
4596 if Project.Source_Dirs /= Nil_String then
4598 -- Check if languages are specified in this project
4600 if Languages.Default then
4602 -- Fail if there is no default language defined
4604 if Def_Lang.Default then
4605 Error_Msg
4606 (Data.Flags,
4608 Project.Location, Project);
4609 Def_Lang_Id := No_Name;
4611 else
4612 Get_Name_String (Def_Lang.Value);
4613 To_Lower (Name_Buffer (1 .. Name_Len));
4614 Def_Lang_Id := Name_Find;
4615 end if;
4617 if Def_Lang_Id /= No_Name then
4618 Get_Name_String (Def_Lang_Id);
4619 Name_Buffer (1) := GNAT.Case_Util.To_Upper (Name_Buffer (1));
4620 Add_Language
4621 (Name => Def_Lang_Id,
4622 Display_Name => Name_Find);
4623 end if;
4625 else
4626 declare
4627 Current : String_List_Id := Languages.Values;
4628 Element : String_Element;
4630 begin
4631 -- If there are no languages declared, there are no sources
4633 if Current = Nil_String then
4634 Project.Source_Dirs := Nil_String;
4636 if Project.Qualifier = Standard then
4637 Error_Msg
4638 (Data.Flags,
4640 Languages.Location, Project);
4641 end if;
4643 else
4644 -- Look through all the languages specified in attribute
4645 -- Languages.
4647 while Current /= Nil_String loop
4648 Element := Shared.String_Elements.Table (Current);
4649 Get_Name_String (Element.Value);
4650 To_Lower (Name_Buffer (1 .. Name_Len));
4652 Add_Language
4653 (Name => Name_Find,
4654 Display_Name => Element.Value);
4656 Current := Element.Next;
4657 end loop;
4658 end if;
4659 end;
4660 end if;
4661 end if;
4662 end Check_Programming_Languages;
4664 -------------------------------
4665 -- Check_Stand_Alone_Library --
4666 -------------------------------
4668 procedure Check_Stand_Alone_Library
4669 (Project : Project_Id;
4670 Data : in out Tree_Processing_Data)
4671 is
4672 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
4674 Lib_Name : constant Prj.Variable_Value :=
4675 Prj.Util.Value_Of
4676 (Snames.Name_Library_Name,
4677 Project.Decl.Attributes,
4678 Shared);
4680 Lib_Standalone : constant Prj.Variable_Value :=
4681 Prj.Util.Value_Of
4682 (Snames.Name_Library_Standalone,
4683 Project.Decl.Attributes,
4684 Shared);
4686 Lib_Auto_Init : constant Prj.Variable_Value :=
4687 Prj.Util.Value_Of
4688 (Snames.Name_Library_Auto_Init,
4689 Project.Decl.Attributes,
4690 Shared);
4692 Lib_Src_Dir : constant Prj.Variable_Value :=
4693 Prj.Util.Value_Of
4694 (Snames.Name_Library_Src_Dir,
4695 Project.Decl.Attributes,
4696 Shared);
4698 Lib_Symbol_File : constant Prj.Variable_Value :=
4699 Prj.Util.Value_Of
4700 (Snames.Name_Library_Symbol_File,
4701 Project.Decl.Attributes,
4702 Shared);
4704 Lib_Symbol_Policy : constant Prj.Variable_Value :=
4705 Prj.Util.Value_Of
4706 (Snames.Name_Library_Symbol_Policy,
4707 Project.Decl.Attributes,
4708 Shared);
4710 Lib_Ref_Symbol_File : constant Prj.Variable_Value :=
4711 Prj.Util.Value_Of
4712 (Snames.Name_Library_Reference_Symbol_File,
4713 Project.Decl.Attributes,
4714 Shared);
4716 Auto_Init_Supported : Boolean;
4717 OK : Boolean := True;
4719 begin
4720 Auto_Init_Supported := Project.Config.Auto_Init_Supported;
4722 -- It is a stand-alone library project file if there is at least one
4723 -- unit in the declared or inherited interface.
4725 if Project.Lib_Interface_ALIs = Nil_String then
4726 if not Lib_Standalone.Default
4728 then
4729 Error_Msg
4730 (Data.Flags,
4732 Lib_Standalone.Location, Project);
4733 end if;
4735 else
4736 if Project.Standalone_Library = No then
4737 Project.Standalone_Library := Standard;
4738 end if;
4740 -- The name of a stand-alone library needs to have the syntax of an
4741 -- Ada identifier.
4743 declare
4744 Name : constant String := Get_Name_String (Project.Library_Name);
4745 OK : Boolean := Is_Letter (Name (Name'First));
4747 Underline : Boolean := False;
4749 begin
4750 for J in Name'First + 1 .. Name'Last loop
4751 exit when not OK;
4753 if Is_Alphanumeric (Name (J)) then
4754 Underline := False;
4756 elsif Name (J) = '_' then
4757 if Underline then
4758 OK := False;
4759 else
4760 Underline := True;
4761 end if;
4763 else
4764 OK := False;
4765 end if;
4766 end loop;
4768 OK := OK and not Underline;
4770 if not OK then
4771 Error_Msg
4772 (Data.Flags,
4774 Lib_Name.Location, Project);
4775 return;
4776 end if;
4777 end;
4779 if Lib_Standalone.Default then
4780 Project.Standalone_Library := Standard;
4782 else
4783 Get_Name_String (Lib_Standalone.Value);
4784 To_Lower (Name_Buffer (1 .. Name_Len));
4787 Project.Standalone_Library := Standard;
4790 Project.Standalone_Library := Encapsulated;
4793 Project.Standalone_Library := No;
4794 Error_Msg
4795 (Data.Flags,
4798 Lib_Standalone.Location, Project);
4800 else
4801 Error_Msg
4802 (Data.Flags,
4804 Lib_Standalone.Location, Project);
4805 end if;
4806 end if;
4808 -- Check value of attribute Library_Auto_Init and set Lib_Auto_Init
4809 -- accordingly.
4811 if Lib_Auto_Init.Default then
4813 -- If no attribute Library_Auto_Init is declared, then set auto
4814 -- init only if it is supported.
4816 Project.Lib_Auto_Init := Auto_Init_Supported;
4818 else
4819 Get_Name_String (Lib_Auto_Init.Value);
4820 To_Lower (Name_Buffer (1 .. Name_Len));
4823 Project.Lib_Auto_Init := False;
4826 if Auto_Init_Supported then
4827 Project.Lib_Auto_Init := True;
4829 else
4831 -- supported.
4833 Error_Msg
4834 (Data.Flags,
4837 Lib_Auto_Init.Location, Project);
4838 end if;
4840 else
4841 Error_Msg
4842 (Data.Flags,
4844 Lib_Auto_Init.Location, Project);
4845 end if;
4846 end if;
4848 -- If attribute Library_Src_Dir is defined and not the empty string,
4849 -- check if the directory exist and is not the object directory or
4850 -- one of the source directories. This is the directory where copies
4851 -- of the interface sources will be copied. Note that this directory
4852 -- may be the library directory.
4854 if Lib_Src_Dir.Value /= Empty_String then
4855 declare
4856 Dir_Id : constant File_Name_Type :=
4857 File_Name_Type (Lib_Src_Dir.Value);
4858 Dir_Exists : Boolean;
4860 begin
4861 Locate_Directory
4862 (Project,
4863 Dir_Id,
4864 Path => Project.Library_Src_Dir,
4865 Dir_Exists => Dir_Exists,
4866 Data => Data,
4867 Must_Exist => False,
4869 Location => Lib_Src_Dir.Location,
4870 Externally_Built => Project.Externally_Built);
4872 -- If directory does not exist, report an error
4874 if not Dir_Exists then
4876 -- Get the absolute name of the library directory that does
4877 -- not exist, to report an error.
4879 Err_Vars.Error_Msg_File_1 :=
4880 File_Name_Type (Project.Library_Src_Dir.Display_Name);
4881 Error_Msg
4882 (Data.Flags,
4884 Lib_Src_Dir.Location, Project);
4886 -- Report error if it is the same as the object directory
4888 elsif Project.Library_Src_Dir = Project.Object_Directory then
4889 Error_Msg
4890 (Data.Flags,
4893 Lib_Src_Dir.Location, Project);
4894 Project.Library_Src_Dir := No_Path_Information;
4896 else
4897 declare
4898 Src_Dirs : String_List_Id;
4899 Src_Dir : String_Element;
4900 Pid : Project_List;
4902 begin
4903 -- Interface copy directory cannot be one of the source
4904 -- directory of the current project.
4906 Src_Dirs := Project.Source_Dirs;
4907 while Src_Dirs /= Nil_String loop
4908 Src_Dir := Shared.String_Elements.Table (Src_Dirs);
4910 -- Report error if it is one of the source directories
4912 if Project.Library_Src_Dir.Name =
4913 Path_Name_Type (Src_Dir.Value)
4914 then
4915 Error_Msg
4916 (Data.Flags,
4919 Lib_Src_Dir.Location, Project);
4920 Project.Library_Src_Dir := No_Path_Information;
4921 exit;
4922 end if;
4924 Src_Dirs := Src_Dir.Next;
4925 end loop;
4927 if Project.Library_Src_Dir /= No_Path_Information then
4929 -- It cannot be a source directory of any other
4930 -- project either.
4932 Pid := Data.Tree.Projects;
4933 Project_Loop : loop
4934 exit Project_Loop when Pid = null;
4936 Src_Dirs := Pid.Project.Source_Dirs;
4937 Dir_Loop : while Src_Dirs /= Nil_String loop
4938 Src_Dir :=
4939 Shared.String_Elements.Table (Src_Dirs);
4941 -- Report error if it is one of the source
4942 -- directories.
4944 if Project.Library_Src_Dir.Name =
4945 Path_Name_Type (Src_Dir.Value)
4946 then
4947 Error_Msg_File_1 :=
4948 File_Name_Type (Src_Dir.Value);
4949 Error_Msg_Name_1 := Pid.Project.Name;
4950 Error_Msg
4951 (Data.Flags,
4955 Lib_Src_Dir.Location, Project);
4956 Project.Library_Src_Dir :=
4957 No_Path_Information;
4958 exit Project_Loop;
4959 end if;
4961 Src_Dirs := Src_Dir.Next;
4962 end loop Dir_Loop;
4964 Pid := Pid.Next;
4965 end loop Project_Loop;
4966 end if;
4967 end;
4969 -- In high verbosity, if there is a valid Library_Src_Dir,
4970 -- display its path name.
4972 if Project.Library_Src_Dir /= No_Path_Information
4973 and then Current_Verbosity = High
4974 then
4975 Write_Attr
4977 Get_Name_String (Project.Library_Src_Dir.Name));
4978 end if;
4979 end if;
4980 end;
4981 end if;
4983 -- Check the symbol related attributes
4985 -- First, the symbol policy
4987 if not Lib_Symbol_Policy.Default then
4988 declare
4989 Value : constant String :=
4990 To_Lower
4991 (Get_Name_String (Lib_Symbol_Policy.Value));
4993 begin
4994 -- Symbol policy must have one of a limited number of values
4997 Project.Symbol_Data.Symbol_Policy := Autonomous;
5000 Project.Symbol_Data.Symbol_Policy := Compliant;
5003 Project.Symbol_Data.Symbol_Policy := Controlled;
5006 Project.Symbol_Data.Symbol_Policy := Restricted;
5009 Project.Symbol_Data.Symbol_Policy := Direct;
5011 else
5012 Error_Msg
5013 (Data.Flags,
5015 Lib_Symbol_Policy.Location, Project);
5016 end if;
5017 end;
5018 end if;
5020 -- If attribute Library_Symbol_File is not specified, symbol policy
5021 -- cannot be Restricted.
5023 if Lib_Symbol_File.Default then
5024 if Project.Symbol_Data.Symbol_Policy = Restricted then
5025 Error_Msg
5026 (Data.Flags,
5029 Lib_Symbol_Policy.Location, Project);
5030 end if;
5032 else
5033 -- Library_Symbol_File is defined
5035 Project.Symbol_Data.Symbol_File :=
5036 Path_Name_Type (Lib_Symbol_File.Value);
5038 Get_Name_String (Lib_Symbol_File.Value);
5040 if Name_Len = 0 then
5041 Error_Msg
5042 (Data.Flags,
5044 Lib_Symbol_File.Location, Project);
5046 else
5047 OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
5049 if OK then
5050 for J in 1 .. Name_Len loop
5051 if Is_Directory_Separator (Name_Buffer (J)) then
5052 OK := False;
5053 exit;
5054 end if;
5055 end loop;
5056 end if;
5058 if not OK then
5059 Error_Msg_File_1 := File_Name_Type (Lib_Symbol_File.Value);
5060 Error_Msg
5061 (Data.Flags,
5064 Lib_Symbol_File.Location, Project);
5065 end if;
5066 end if;
5067 end if;
5069 -- If attribute Library_Reference_Symbol_File is not defined,
5070 -- symbol policy cannot be Compliant or Controlled.
5072 if Lib_Ref_Symbol_File.Default then
5073 if Project.Symbol_Data.Symbol_Policy = Compliant
5074 or else Project.Symbol_Data.Symbol_Policy = Controlled
5075 then
5076 Error_Msg
5077 (Data.Flags,
5079 Lib_Symbol_Policy.Location, Project);
5080 end if;
5082 else
5083 -- Library_Reference_Symbol_File is defined, check file exists
5085 Project.Symbol_Data.Reference :=
5086 Path_Name_Type (Lib_Ref_Symbol_File.Value);
5088 Get_Name_String (Lib_Ref_Symbol_File.Value);
5090 if Name_Len = 0 then
5091 Error_Msg
5092 (Data.Flags,
5094 Lib_Symbol_File.Location, Project);
5096 else
5097 if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then
5098 Name_Len := 0;
5099 Add_Str_To_Name_Buffer
5100 (Get_Name_String (Project.Directory.Name));
5101 Add_Str_To_Name_Buffer
5102 (Get_Name_String (Lib_Ref_Symbol_File.Value));
5103 Project.Symbol_Data.Reference := Name_Find;
5104 end if;
5106 if not Is_Regular_File
5107 (Get_Name_String (Project.Symbol_Data.Reference))
5108 then
5109 Error_Msg_File_1 :=
5110 File_Name_Type (Lib_Ref_Symbol_File.Value);
5112 -- For controlled and direct symbol policies, it is an error
5113 -- if the reference symbol file does not exist. For other
5114 -- symbol policies, this is just a warning
5116 Error_Msg_Warn :=
5117 Project.Symbol_Data.Symbol_Policy /= Controlled
5118 and then Project.Symbol_Data.Symbol_Policy /= Direct;
5120 Error_Msg
5121 (Data.Flags,
5123 Lib_Ref_Symbol_File.Location, Project);
5125 -- In addition in the non-controlled case, if symbol policy
5126 -- is Compliant, it is changed to Autonomous, because there
5127 -- is no reference to check against, and we don't want to
5128 -- fail in this case.
5130 if Project.Symbol_Data.Symbol_Policy /= Controlled then
5131 if Project.Symbol_Data.Symbol_Policy = Compliant then
5132 Project.Symbol_Data.Symbol_Policy := Autonomous;
5133 end if;
5134 end if;
5135 end if;
5137 -- If both the reference symbol file and the symbol file are
5138 -- defined, then check that they are not the same file.
5140 if Project.Symbol_Data.Symbol_File /= No_Path then
5141 Get_Name_String (Project.Symbol_Data.Symbol_File);
5143 if Name_Len > 0 then
5144 declare
5145 -- We do not need to pass a Directory to
5146 -- Normalize_Pathname, since the path_information
5147 -- already contains absolute information.
5149 Symb_Path : constant String :=
5150 Normalize_Pathname
5151 (Get_Name_String
5152 (Project.Object_Directory.Name) &
5153 Name_Buffer (1 .. Name_Len),
5155 Resolve_Links =>
5156 Opt.Follow_Links_For_Files);
5157 Ref_Path : constant String :=
5158 Normalize_Pathname
5159 (Get_Name_String
5160 (Project.Symbol_Data.Reference),
5162 Resolve_Links =>
5163 Opt.Follow_Links_For_Files);
5164 begin
5165 if Symb_Path = Ref_Path then
5166 Error_Msg
5167 (Data.Flags,
5170 Lib_Ref_Symbol_File.Location, Project);
5171 end if;
5172 end;
5173 end if;
5174 end if;
5175 end if;
5176 end if;
5177 end if;
5178 end Check_Stand_Alone_Library;
5180 ---------------------
5181 -- Check_Unit_Name --
5182 ---------------------
5184 procedure Check_Unit_Name (Name : String; Unit : out Name_Id) is
5185 The_Name : String := Name;
5186 Real_Name : Name_Id;
5187 Need_Letter : Boolean := True;
5188 Last_Underscore : Boolean := False;
5189 OK : Boolean := The_Name'Length > 0;
5190 First : Positive;
5192 function Is_Reserved (Name : Name_Id) return Boolean;
5193 function Is_Reserved (S : String) return Boolean;
5194 -- Check that the given name is not an Ada 95 reserved word. The reason
5195 -- for the Ada 95 here is that we do not want to exclude the case of an
5196 -- Ada 95 unit called Interface (for example). In Ada 2005, such a unit
5197 -- name would be rejected anyway by the compiler. That means there is no
5198 -- requirement that the project file parser reject this.
5200 -----------------
5201 -- Is_Reserved --
5202 -----------------
5204 function Is_Reserved (S : String) return Boolean is
5205 begin
5206 Name_Len := 0;
5207 Add_Str_To_Name_Buffer (S);
5208 return Is_Reserved (Name_Find);
5209 end Is_Reserved;
5211 -----------------
5212 -- Is_Reserved --
5213 -----------------
5215 function Is_Reserved (Name : Name_Id) return Boolean is
5216 begin
5217 if Get_Name_Table_Byte (Name) /= 0
5218 and then
5219 not Nam_In (Name, Name_Project, Name_Extends, Name_External)
5220 and then Name not in Ada_2005_Reserved_Words
5221 then
5222 Unit := No_Name;
5224 return True;
5226 else
5227 return False;
5228 end if;
5229 end Is_Reserved;
5231 -- Start of processing for Check_Unit_Name
5233 begin
5234 To_Lower (The_Name);
5236 Name_Len := The_Name'Length;
5237 Name_Buffer (1 .. Name_Len) := The_Name;
5239 Real_Name := Name_Find;
5241 if Is_Reserved (Real_Name) then
5242 return;
5243 end if;
5245 First := The_Name'First;
5247 for Index in The_Name'Range loop
5248 if Need_Letter then
5250 -- We need a letter (at the beginning, and following a dot),
5251 -- but we don't have one.
5253 if Is_Letter (The_Name (Index)) then
5254 Need_Letter := False;
5256 else
5257 OK := False;
5259 if Current_Verbosity = High then
5260 Debug_Indent;
5261 Write_Int (Types.Int (Index));
5263 Write_Char (The_Name (Index));
5265 end if;
5267 exit;
5268 end if;
5270 elsif Last_Underscore
5271 and then (The_Name (Index) = '_' or else The_Name (Index) = '.')
5272 then
5273 -- Two underscores are illegal, and a dot cannot follow
5274 -- an underscore.
5276 OK := False;
5278 if Current_Verbosity = High then
5279 Debug_Indent;
5280 Write_Int (Types.Int (Index));
5282 Write_Char (The_Name (Index));
5284 end if;
5286 exit;
5288 elsif The_Name (Index) = '.' then
5290 -- First, check if the name before the dot is not a reserved word
5292 if Is_Reserved (The_Name (First .. Index - 1)) then
5293 return;
5294 end if;
5296 First := Index + 1;
5298 -- We need a letter after a dot
5300 Need_Letter := True;
5302 elsif The_Name (Index) = '_' then
5303 Last_Underscore := True;
5305 else
5306 -- We need an letter or a digit
5308 Last_Underscore := False;
5310 if not Is_Alphanumeric (The_Name (Index)) then
5311 OK := False;
5313 if Current_Verbosity = High then
5314 Debug_Indent;
5315 Write_Int (Types.Int (Index));
5317 Write_Char (The_Name (Index));
5319 end if;
5321 exit;
5322 end if;
5323 end if;
5324 end loop;
5326 -- Cannot end with an underscore or a dot
5328 OK := OK and then not Need_Letter and then not Last_Underscore;
5330 if OK then
5331 if First /= Name'First
5332 and then Is_Reserved (The_Name (First .. The_Name'Last))
5333 then
5334 return;
5335 end if;
5337 Unit := Real_Name;
5339 else
5340 -- Signal a problem with No_Name
5342 Unit := No_Name;
5343 end if;
5344 end Check_Unit_Name;
5346 ----------------------------
5347 -- Compute_Directory_Last --
5348 ----------------------------
5350 function Compute_Directory_Last (Dir : String) return Natural is
5351 begin
5352 if Dir'Length > 1
5353 and then Is_Directory_Separator (Dir (Dir'Last - 1))
5354 then
5355 return Dir'Last - 1;
5356 else
5357 return Dir'Last;
5358 end if;
5359 end Compute_Directory_Last;
5361 ---------------------
5362 -- Get_Directories --
5363 ---------------------
5365 procedure Get_Directories
5366 (Project : Project_Id;
5367 Data : in out Tree_Processing_Data)
5368 is
5369 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
5371 Object_Dir : constant Variable_Value :=
5372 Util.Value_Of
5373 (Name_Object_Dir, Project.Decl.Attributes, Shared);
5375 Exec_Dir : constant Variable_Value :=
5376 Util.Value_Of
5377 (Name_Exec_Dir, Project.Decl.Attributes, Shared);
5379 Source_Dirs : constant Variable_Value :=
5380 Util.Value_Of
5381 (Name_Source_Dirs, Project.Decl.Attributes, Shared);
5383 Ignore_Source_Sub_Dirs : constant Variable_Value :=
5384 Util.Value_Of
5385 (Name_Ignore_Source_Sub_Dirs,
5386 Project.Decl.Attributes,
5387 Shared);
5389 Excluded_Source_Dirs : constant Variable_Value :=
5390 Util.Value_Of
5391 (Name_Excluded_Source_Dirs,
5392 Project.Decl.Attributes,
5393 Shared);
5395 Source_Files : constant Variable_Value :=
5396 Util.Value_Of
5397 (Name_Source_Files,
5398 Project.Decl.Attributes, Shared);
5400 Last_Source_Dir : String_List_Id := Nil_String;
5401 Last_Src_Dir_Rank : Number_List_Index := No_Number_List;
5403 Languages : constant Variable_Value :=
5404 Prj.Util.Value_Of
5405 (Name_Languages, Project.Decl.Attributes, Shared);
5407 Remove_Source_Dirs : Boolean := False;
5409 procedure Add_To_Or_Remove_From_Source_Dirs
5410 (Path : Path_Information;
5411 Rank : Natural);
5412 -- When Removed = False, the directory Path_Id to the list of
5413 -- source_dirs if not already in the list. When Removed = True,
5414 -- removed directory Path_Id if in the list.
5416 procedure Find_Source_Dirs is new Expand_Subdirectory_Pattern
5417 (Add_To_Or_Remove_From_Source_Dirs);
5419 ---------------------------------------
5420 -- Add_To_Or_Remove_From_Source_Dirs --
5421 ---------------------------------------
5423 procedure Add_To_Or_Remove_From_Source_Dirs
5424 (Path : Path_Information;
5425 Rank : Natural)
5426 is
5427 List : String_List_Id;
5428 Prev : String_List_Id;
5429 Rank_List : Number_List_Index;
5430 Prev_Rank : Number_List_Index;
5431 Element : String_Element;
5433 begin
5434 Prev := Nil_String;
5435 Prev_Rank := No_Number_List;
5436 List := Project.Source_Dirs;
5437 Rank_List := Project.Source_Dir_Ranks;
5438 while List /= Nil_String loop
5439 Element := Shared.String_Elements.Table (List);
5440 exit when Element.Value = Name_Id (Path.Name);
5441 Prev := List;
5442 List := Element.Next;
5443 Prev_Rank := Rank_List;
5444 Rank_List := Shared.Number_Lists.Table (Prev_Rank).Next;
5445 end loop;
5447 -- The directory is in the list if List is not Nil_String
5449 if not Remove_Source_Dirs and then List = Nil_String then
5452 String_Element_Table.Increment_Last (Shared.String_Elements);
5453 Element :=
5454 (Value => Name_Id (Path.Name),
5455 Index => 0,
5456 Display_Value => Name_Id (Path.Display_Name),
5457 Location => No_Location,
5458 Flag => False,
5459 Next => Nil_String);
5461 Number_List_Table.Increment_Last (Shared.Number_Lists);
5463 if Last_Source_Dir = Nil_String then
5465 -- This is the first source directory
5467 Project.Source_Dirs :=
5468 String_Element_Table.Last (Shared.String_Elements);
5469 Project.Source_Dir_Ranks :=
5470 Number_List_Table.Last (Shared.Number_Lists);
5472 else
5473 -- We already have source directories, link the previous
5474 -- last to the new one.
5476 Shared.String_Elements.Table (Last_Source_Dir).Next :=
5477 String_Element_Table.Last (Shared.String_Elements);
5478 Shared.Number_Lists.Table (Last_Src_Dir_Rank).Next :=
5479 Number_List_Table.Last (Shared.Number_Lists);
5480 end if;
5482 -- And register this source directory as the new last
5484 Last_Source_Dir :=
5485 String_Element_Table.Last (Shared.String_Elements);
5486 Shared.String_Elements.Table (Last_Source_Dir) := Element;
5487 Last_Src_Dir_Rank := Number_List_Table.Last (Shared.Number_Lists);
5488 Shared.Number_Lists.Table (Last_Src_Dir_Rank) :=
5489 (Number => Rank, Next => No_Number_List);
5491 elsif Remove_Source_Dirs and then List /= Nil_String then
5493 -- Remove source dir if present
5495 if Prev = Nil_String then
5496 Project.Source_Dirs := Shared.String_Elements.Table (List).Next;
5497 Project.Source_Dir_Ranks :=
5498 Shared.Number_Lists.Table (Rank_List).Next;
5500 else
5501 Shared.String_Elements.Table (Prev).Next :=
5502 Shared.String_Elements.Table (List).Next;
5503 Shared.Number_Lists.Table (Prev_Rank).Next :=
5504 Shared.Number_Lists.Table (Rank_List).Next;
5505 end if;
5506 end if;
5507 end Add_To_Or_Remove_From_Source_Dirs;
5509 -- Local declarations
5511 Dir_Exists : Boolean;
5513 No_Sources : constant Boolean :=
5514 Project.Qualifier = Abstract_Project
5515 or else (((not Source_Files.Default
5516 and then Source_Files.Values = Nil_String)
5517 or else
5518 (not Source_Dirs.Default
5519 and then Source_Dirs.Values = Nil_String)
5520 or else
5521 (not Languages.Default
5522 and then Languages.Values = Nil_String))
5523 and then Project.Extends = No_Project);
5525 -- Start of processing for Get_Directories
5527 begin
5530 -- Set the object directory to its default which may be nil, if there
5531 -- is no sources in the project.
5533 if No_Sources then
5534 Project.Object_Directory := No_Path_Information;
5535 else
5536 Project.Object_Directory := Project.Directory;
5537 end if;
5539 -- Check the object directory
5541 if Object_Dir.Value /= Empty_String then
5542 Get_Name_String (Object_Dir.Value);
5544 if Name_Len = 0 then
5545 Error_Msg
5546 (Data.Flags,
5548 Object_Dir.Location, Project);
5550 elsif Setup_Projects
5551 and then No_Sources
5552 and then Project.Extends = No_Project
5553 then
5554 -- Do not create an object directory for a non extending project
5555 -- with no sources.
5557 Locate_Directory
5558 (Project,
5559 File_Name_Type (Object_Dir.Value),
5560 Path => Project.Object_Directory,
5561 Dir_Exists => Dir_Exists,
5562 Data => Data,
5563 Location => Object_Dir.Location,
5564 Must_Exist => False,
5565 Externally_Built => Project.Externally_Built);
5567 else
5568 -- We check that the specified object directory does exist.
5569 -- However, even when it doesn't exist, we set it to a default
5570 -- value. This is for the benefit of tools that recover from
5571 -- errors; for example, these tools could create the non existent
5572 -- directory. We always return an absolute directory name though.
5574 Locate_Directory
5575 (Project,
5576 File_Name_Type (Object_Dir.Value),
5577 Path => Project.Object_Directory,
5579 Dir_Exists => Dir_Exists,
5580 Data => Data,
5581 Location => Object_Dir.Location,
5582 Must_Exist => False,
5583 Externally_Built => Project.Externally_Built);
5585 if not Dir_Exists and then not Project.Externally_Built then
5586 if Opt.Directories_Must_Exist_In_Projects then
5588 -- The object directory does not exist, report an error if
5589 -- the project is not externally built.
5591 Err_Vars.Error_Msg_File_1 :=
5592 File_Name_Type (Object_Dir.Value);
5593 Error_Or_Warning
5594 (Data.Flags, Data.Flags.Require_Obj_Dirs,
5596 Project.Location, Project);
5597 end if;
5598 end if;
5599 end if;
5601 elsif not No_Sources
5602 and then (Subdirs /= null or else Build_Tree_Dir /= null)
5603 then
5604 Name_Len := 1;
5605 Name_Buffer (1) := '.';
5606 Locate_Directory
5607 (Project,
5608 Name_Find,
5609 Path => Project.Object_Directory,
5611 Dir_Exists => Dir_Exists,
5612 Data => Data,
5613 Location => Object_Dir.Location,
5614 Externally_Built => Project.Externally_Built);
5615 end if;
5617 if Current_Verbosity = High then
5618 if Project.Object_Directory = No_Path_Information then
5620 else
5621 Write_Attr
5623 Get_Name_String (Project.Object_Directory.Display_Name));
5624 end if;
5625 end if;
5627 -- Check the exec directory
5629 -- We set the object directory to its default
5631 Project.Exec_Directory := Project.Object_Directory;
5633 if Exec_Dir.Value /= Empty_String then
5634 Get_Name_String (Exec_Dir.Value);
5636 if Name_Len = 0 then
5637 Error_Msg
5638 (Data.Flags,
5640 Exec_Dir.Location, Project);
5642 elsif Setup_Projects
5643 and then No_Sources
5644 and then Project.Extends = No_Project
5645 then
5646 -- Do not create an exec directory for a non extending project
5647 -- with no sources.
5649 Locate_Directory
5650 (Project,
5651 File_Name_Type (Exec_Dir.Value),
5652 Path => Project.Exec_Directory,
5653 Dir_Exists => Dir_Exists,
5654 Data => Data,
5655 Location => Exec_Dir.Location,
5656 Externally_Built => Project.Externally_Built);
5658 else
5659 -- We check that the specified exec directory does exist
5661 Locate_Directory
5662 (Project,
5663 File_Name_Type (Exec_Dir.Value),
5664 Path => Project.Exec_Directory,
5665 Dir_Exists => Dir_Exists,
5666 Data => Data,
5668 Location => Exec_Dir.Location,
5669 Externally_Built => Project.Externally_Built);
5671 if not Dir_Exists then
5672 if Opt.Directories_Must_Exist_In_Projects then
5673 Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value);
5674 Error_Or_Warning
5675 (Data.Flags, Data.Flags.Missing_Source_Files,
5678 else
5679 Project.Exec_Directory := No_Path_Information;
5680 end if;
5681 end if;
5682 end if;
5683 end if;
5685 if Current_Verbosity = High then
5686 if Project.Exec_Directory = No_Path_Information then
5688 else
5689 Debug_Output
5691 Name_Id (Project.Exec_Directory.Display_Name));
5692 end if;
5693 end if;
5695 -- Look for the source directories
5701 if not Source_Files.Default and then Source_Files.Values = Nil_String
5702 then
5703 Project.Source_Dirs := Nil_String;
5705 if Project.Qualifier = Standard then
5706 Error_Msg
5707 (Data.Flags,
5709 Source_Files.Location, Project);
5710 end if;
5712 elsif Source_Dirs.Default then
5714 -- No Source_Dirs specified: the single source directory is the one
5715 -- containing the project file.
5717 Remove_Source_Dirs := False;
5718 Add_To_Or_Remove_From_Source_Dirs
5719 (Path => (Name => Project.Directory.Name,
5720 Display_Name => Project.Directory.Display_Name),
5721 Rank => 1);
5723 else
5724 Remove_Source_Dirs := False;
5725 Find_Source_Dirs
5726 (Project => Project,
5727 Data => Data,
5728 Patterns => Source_Dirs.Values,
5729 Ignore => Ignore_Source_Sub_Dirs.Values,
5730 Search_For => Search_Directories,
5731 Resolve_Links => Opt.Follow_Links_For_Dirs);
5733 if Project.Source_Dirs = Nil_String
5734 and then Project.Qualifier = Standard
5735 then
5736 Error_Msg
5737 (Data.Flags,
5739 Source_Dirs.Location, Project);
5740 end if;
5741 end if;
5743 if not Excluded_Source_Dirs.Default
5744 and then Excluded_Source_Dirs.Values /= Nil_String
5745 then
5746 Remove_Source_Dirs := True;
5747 Find_Source_Dirs
5748 (Project => Project,
5749 Data => Data,
5750 Patterns => Excluded_Source_Dirs.Values,
5751 Ignore => Nil_String,
5752 Search_For => Search_Directories,
5753 Resolve_Links => Opt.Follow_Links_For_Dirs);
5754 end if;
5758 declare
5759 Current : String_List_Id := Project.Source_Dirs;
5760 Element : String_Element;
5762 begin
5763 while Current /= Nil_String loop
5764 Element := Shared.String_Elements.Table (Current);
5765 if Element.Value /= No_Name then
5766 Element.Value :=
5767 Name_Id (Canonical_Case_File_Name (Element.Value));
5768 Shared.String_Elements.Table (Current) := Element;
5769 end if;
5771 Current := Element.Next;
5772 end loop;
5773 end;
5774 end Get_Directories;
5776 ---------------
5777 -- Get_Mains --
5778 ---------------
5780 procedure Get_Mains
5781 (Project : Project_Id;
5782 Data : in out Tree_Processing_Data)
5783 is
5784 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
5786 Mains : constant Variable_Value :=
5787 Prj.Util.Value_Of
5788 (Name_Main, Project.Decl.Attributes, Shared);
5789 List : String_List_Id;
5790 Elem : String_Element;
5792 begin
5793 Project.Mains := Mains.Values;
5795 -- If no Mains were specified, and if we are an extending project,
5796 -- inherit the Mains from the project we are extending.
5798 if Mains.Default then
5799 if not Project.Library and then Project.Extends /= No_Project then
5800 Project.Mains := Project.Extends.Mains;
5801 end if;
5803 -- In a library project file, Main cannot be specified
5805 elsif Project.Library then
5806 Error_Msg
5807 (Data.Flags,
5809 Mains.Location, Project);
5811 else
5812 List := Mains.Values;
5813 while List /= Nil_String loop
5814 Elem := Shared.String_Elements.Table (List);
5816 if Length_Of_Name (Elem.Value) = 0 then
5817 Error_Msg
5818 (Data.Flags,
5820 Elem.Location, Project);
5821 exit;
5822 end if;
5824 List := Elem.Next;
5825 end loop;
5826 end if;
5827 end Get_Mains;
5829 ---------------------------
5830 -- Get_Sources_From_File --
5831 ---------------------------
5833 procedure Get_Sources_From_File
5834 (Path : String;
5835 Location : Source_Ptr;
5836 Project : in out Project_Processing_Data;
5837 Data : in out Tree_Processing_Data)
5838 is
5839 File : Prj.Util.Text_File;
5840 Line : String (1 .. 250);
5841 Last : Natural;
5842 Source_Name : File_Name_Type;
5843 Name_Loc : Name_Location;
5845 begin
5846 if Current_Verbosity = High then
5848 end if;
5850 -- Open the file
5852 Prj.Util.Open (File, Path);
5854 if not Prj.Util.Is_Valid (File) then
5855 Error_Msg
5856 (Data.Flags, "file does not exist", Location, Project.Project);
5858 else
5859 -- Read the lines one by one
5861 while not Prj.Util.End_Of_File (File) loop
5862 Prj.Util.Get_Line (File, Line, Last);
5864 -- A non empty, non comment line should contain a file name
5866 if Last /= 0 and then (Last = 1 or else Line (1 .. 2) /= "--") then
5867 Name_Len := Last;
5868 Name_Buffer (1 .. Name_Len) := Line (1 .. Last);
5869 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
5870 Source_Name := Name_Find;
5872 -- Check that there is no directory information
5874 for J in 1 .. Last loop
5875 if Is_Directory_Separator (Line (J)) then
5876 Error_Msg_File_1 := Source_Name;
5877 Error_Msg
5878 (Data.Flags,
5879 "file name cannot include directory information ({)",
5880 Location, Project.Project);
5881 exit;
5882 end if;
5883 end loop;
5885 Name_Loc := Source_Names_Htable.Get
5886 (Project.Source_Names, Source_Name);
5888 if Name_Loc = No_Name_Location then
5889 Name_Loc :=
5890 (Name => Source_Name,
5891 Location => Location,
5892 Source => No_Source,
5893 Listed => True,
5894 Found => False);
5896 else
5897 Name_Loc.Listed := True;
5898 end if;
5900 Source_Names_Htable.Set
5901 (Project.Source_Names, Source_Name, Name_Loc);
5902 end if;
5903 end loop;
5905 Prj.Util.Close (File);
5907 end if;
5908 end Get_Sources_From_File;
5910 ------------------
5911 -- No_Space_Img --
5912 ------------------
5914 function No_Space_Img (N : Natural) return String is
5915 Image : constant String := N'Img;
5916 begin
5917 return Image (2 .. Image'Last);
5918 end No_Space_Img;
5920 -----------------------
5921 -- Compute_Unit_Name --
5922 -----------------------
5924 procedure Compute_Unit_Name
5925 (File_Name : File_Name_Type;
5926 Naming : Lang_Naming_Data;
5927 Kind : out Source_Kind;
5928 Unit : out Name_Id;
5929 Project : Project_Processing_Data)
5930 is
5931 Filename : constant String := Get_Name_String (File_Name);
5932 Last : Integer := Filename'Last;
5933 Sep_Len : Integer;
5934 Body_Len : Integer;
5935 Spec_Len : Integer;
5937 Unit_Except : Unit_Exception;
5938 Masked : Boolean := False;
5940 begin
5941 Unit := No_Name;
5942 Kind := Spec;
5944 if Naming.Separate_Suffix = No_File
5945 or else Naming.Body_Suffix = No_File
5946 or else Naming.Spec_Suffix = No_File
5947 then
5948 return;
5949 end if;
5951 if Naming.Dot_Replacement = No_File then
5952 Debug_Output ("no dot_replacement specified");
5953 return;
5954 end if;
5956 Sep_Len := Integer (Length_Of_Name (Naming.Separate_Suffix));
5957 Spec_Len := Integer (Length_Of_Name (Naming.Spec_Suffix));
5958 Body_Len := Integer (Length_Of_Name (Naming.Body_Suffix));
5960 -- Choose the longest suffix that matches. If there are several matches,
5961 -- give priority to specs, then bodies, then separates.
5963 if Naming.Separate_Suffix /= Naming.Body_Suffix
5964 and then Suffix_Matches (Filename, Naming.Separate_Suffix)
5965 then
5966 Last := Filename'Last - Sep_Len;
5967 Kind := Sep;
5968 end if;
5970 if Filename'Last - Body_Len <= Last
5971 and then Suffix_Matches (Filename, Naming.Body_Suffix)
5972 then
5973 Last := Natural'Min (Last, Filename'Last - Body_Len);
5974 Kind := Impl;
5975 end if;
5977 if Filename'Last - Spec_Len <= Last
5978 and then Suffix_Matches (Filename, Naming.Spec_Suffix)
5979 then
5980 Last := Natural'Min (Last, Filename'Last - Spec_Len);
5981 Kind := Spec;
5982 end if;
5984 if Last = Filename'Last then
5985 Debug_Output ("no matching suffix");
5986 return;
5987 end if;
5989 -- Check that the casing matches
5991 if File_Names_Case_Sensitive then
5992 case Naming.Casing is
5993 when All_Lower_Case =>
5994 for J in Filename'First .. Last loop
5995 if Is_Letter (Filename (J))
5996 and then not Is_Lower (Filename (J))
5997 then
5998 Debug_Output ("invalid casing");
5999 return;
6000 end if;
6001 end loop;
6003 when All_Upper_Case =>
6004 for J in Filename'First .. Last loop
6005 if Is_Letter (Filename (J))
6006 and then not Is_Upper (Filename (J))
6007 then
6008 Debug_Output ("invalid casing");
6009 return;
6010 end if;
6011 end loop;
6013 when Mixed_Case
6014 | Unknown
6015 =>
6016 null;
6017 end case;
6018 end if;
6020 -- If Dot_Replacement is not a single dot, then there should not
6021 -- be any dot in the name.
6023 declare
6024 Dot_Repl : constant String :=
6025 Get_Name_String (Naming.Dot_Replacement);
6027 begin
6028 if Dot_Repl /= "." then
6029 for Index in Filename'First .. Last loop
6031 Debug_Output ("invalid name, contains dot");
6032 return;
6033 end if;
6034 end loop;
6036 Replace_Into_Name_Buffer
6039 else
6040 Name_Len := Last - Filename'First + 1;
6041 Name_Buffer (1 .. Name_Len) := Filename (Filename'First .. Last);
6042 Fixed.Translate
6043 (Source => Name_Buffer (1 .. Name_Len),
6044 Mapping => Lower_Case_Map);
6045 end if;
6046 end;
6048 -- In the standard GNAT naming scheme, check for special cases: children
6049 -- or separates of A, G, I or S, and run time sources.
6051 if Is_Standard_GNAT_Naming (Naming) and then Name_Len >= 3 then
6052 declare
6053 S1 : constant Character := Name_Buffer (1);
6054 S2 : constant Character := Name_Buffer (2);
6055 S3 : constant Character := Name_Buffer (3);
6057 begin
6060 -- Children or separates of packages A, G, I or S. These names
6061 -- are x__ ... or x~... (where x is a, g, i, or s). Both
6062 -- versions (x__... and x~...) are allowed in all platforms,
6063 -- because it is not possible to know the platform before
6064 -- processing of the project files.
6068 Name_Buffer (3 .. Name_Len - 1) :=
6069 Name_Buffer (4 .. Name_Len);
6070 Name_Len := Name_Len - 1;
6077 -- If it is potentially a run time source
6079 null;
6080 end if;
6081 end if;
6082 end;
6083 end if;
6085 -- Name_Buffer contains the name of the unit in lower-cases. Check
6086 -- that this is a valid unit name
6088 Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit);
6090 -- If there is a naming exception for the same unit, the file is not
6091 -- a source for the unit.
6093 if Unit /= No_Name then
6094 Unit_Except :=
6095 Unit_Exceptions_Htable.Get (Project.Unit_Exceptions, Unit);
6097 if Kind = Spec then
6098 Masked := Unit_Except.Spec /= No_File
6099 and then
6100 Unit_Except.Spec /= File_Name;
6101 else
6102 Masked := Unit_Except.Impl /= No_File
6103 and then
6104 Unit_Except.Impl /= File_Name;
6105 end if;
6107 if Masked then
6108 if Current_Verbosity = High then
6109 Debug_Indent;
6110 Write_Str (" """ & Filename & """ contains the ");
6112 if Kind = Spec then
6113 Write_Str ("spec of a unit found in """);
6114 Write_Str (Get_Name_String (Unit_Except.Spec));
6115 else
6116 Write_Str ("body of a unit found in """);
6117 Write_Str (Get_Name_String (Unit_Except.Impl));
6118 end if;
6120 Write_Line (""" (ignored)");
6121 end if;
6123 Unit := No_Name;
6124 end if;
6125 end if;
6127 if Unit /= No_Name and then Current_Verbosity = High then
6128 case Kind is
6129 when Spec => Debug_Output ("spec of", Unit);
6130 when Impl => Debug_Output ("body of", Unit);
6131 when Sep => Debug_Output ("sep of", Unit);
6132 end case;
6133 end if;
6134 end Compute_Unit_Name;
6136 --------------------------
6137 -- Check_Illegal_Suffix --
6138 --------------------------
6140 procedure Check_Illegal_Suffix
6141 (Project : Project_Id;
6142 Suffix : File_Name_Type;
6143 Dot_Replacement : File_Name_Type;
6144 Attribute_Name : String;
6145 Location : Source_Ptr;
6146 Data : in out Tree_Processing_Data)
6147 is
6148 Suffix_Str : constant String := Get_Name_String (Suffix);
6150 begin
6151 if Suffix_Str'Length = 0 then
6153 -- Always valid
6155 return;
6157 elsif Index (Suffix_Str, ".") = 0 then
6158 Err_Vars.Error_Msg_File_1 := Suffix;
6159 Error_Msg
6160 (Data.Flags,
6161 "{ is illegal for " & Attribute_Name & ": must have a dot",
6162 Location, Project);
6163 return;
6164 end if;
6166 -- Case of dot replacement is a single dot, and first character of
6167 -- suffix is also a dot.
6169 if Dot_Replacement /= No_File
6170 and then Get_Name_String (Dot_Replacement) = "."
6172 then
6173 for Index in Suffix_Str'First + 1 .. Suffix_Str'Last loop
6175 -- If there are multiple dots in the name
6179 -- It is illegal to have a letter following the initial dot
6181 if Is_Letter (Suffix_Str (Suffix_Str'First + 1)) then
6182 Err_Vars.Error_Msg_File_1 := Suffix;
6183 Error_Msg
6184 (Data.Flags,
6185 "{ is illegal for " & Attribute_Name
6186 & ": ambiguous prefix when Dot_Replacement is a dot",
6187 Location, Project);
6188 end if;
6189 return;
6190 end if;
6191 end loop;
6192 end if;
6193 end Check_Illegal_Suffix;
6195 ----------------------
6196 -- Locate_Directory --
6197 ----------------------
6199 procedure Locate_Directory
6200 (Project : Project_Id;
6201 Name : File_Name_Type;
6202 Path : out Path_Information;
6203 Dir_Exists : out Boolean;
6204 Data : in out Tree_Processing_Data;
6205 Create : String := "";
6206 Location : Source_Ptr := No_Location;
6207 Must_Exist : Boolean := True;
6208 Externally_Built : Boolean := False)
6209 is
6210 Parent : constant Path_Name_Type :=
6211 Project.Directory.Display_Name;
6212 The_Parent : constant String :=
6213 Get_Name_String (Parent);
6214 The_Parent_Last : constant Natural :=
6215 Compute_Directory_Last (The_Parent);
6216 Full_Name : File_Name_Type;
6217 The_Name : File_Name_Type;
6219 begin
6220 -- Check if we have a root-object dir specified, if so relocate all
6221 -- artefact directories to it.
6223 if Build_Tree_Dir /= null
6224 and then Create /= ""
6225 and then not Is_Absolute_Path (Get_Name_String (Name))
6226 then
6227 Name_Len := 0;
6228 Add_Str_To_Name_Buffer (Build_Tree_Dir.all);
6230 if The_Parent_Last - The_Parent'First + 1 < Root_Dir'Length then
6231 Err_Vars.Error_Msg_File_1 := Name;
6232 Error_Or_Warning
6233 (Data.Flags, Error,
6234 "{ cannot relocate deeper than " & Create & " directory",
6235 No_Location, Project);
6236 end if;
6238 Add_Str_To_Name_Buffer
6239 (Relative_Path
6240 (The_Parent (The_Parent'First .. The_Parent_Last),
6241 Root_Dir.all));
6242 Add_Str_To_Name_Buffer (Get_Name_String (Name));
6244 else
6245 if Build_Tree_Dir /= null and then Create /= "" then
6247 -- Issue a warning that we cannot relocate absolute obj dir
6249 Err_Vars.Error_Msg_File_1 := Name;
6250 Error_Or_Warning
6251 (Data.Flags, Warning,
6252 "{ cannot relocate absolute object directory",
6253 No_Location, Project);
6254 end if;
6256 Get_Name_String (Name);
6257 end if;
6259 -- Add Subdirs.all if it is a directory that may be created and
6260 -- Subdirs is not null;
6262 if Create /= "" and then Subdirs /= null then
6263 if Name_Buffer (Name_Len) /= Directory_Separator then
6264 Add_Char_To_Name_Buffer (Directory_Separator);
6265 end if;
6267 Add_Str_To_Name_Buffer (Subdirs.all);
6268 end if;
6272 for J in 1 .. Name_Len loop
6274 Name_Buffer (J) := Directory_Separator;
6275 end if;
6276 end loop;
6278 The_Name := Name_Find;
6280 if Current_Verbosity = High then
6281 Debug_Indent;
6282 Write_Str ("Locate_Directory (""");
6283 Write_Str (Get_Name_String (The_Name));
6284 Write_Str (""", in """);
6285 Write_Str (The_Parent);
6286 Write_Line (""")");
6287 end if;
6289 Path := No_Path_Information;
6290 Dir_Exists := False;
6292 if Is_Absolute_Path (Get_Name_String (The_Name)) then
6293 Full_Name := The_Name;
6295 else
6296 Name_Len := 0;
6297 Add_Str_To_Name_Buffer
6298 (The_Parent (The_Parent'First .. The_Parent_Last));
6299 Add_Str_To_Name_Buffer (Get_Name_String (The_Name));
6300 Full_Name := Name_Find;
6301 end if;
6303 declare
6304 Full_Path_Name : String_Access :=
6307 begin
6310 then
6313 -- If project is externally built, do not create a subdir,
6314 -- use the specified directory, without the subdir.
6320 else
6322 Add_Str_To_Name_Buffer
6329 else
6330 begin
6331 Create_Path (Full_Path_Name.all);
6333 if not Quiet_Output then
6334 Write_Str (Create);
6335 Write_Str (" directory """);
6336 Write_Str (Full_Path_Name.all);
6337 Write_Str (""" created for project ");
6338 Write_Line (Get_Name_String (Project.Name));
6339 end if;
6341 exception
6342 when Use_Error =>
6344 -- Output message with name of directory. Note that we
6345 -- use the ~ insertion method here in case the name
6346 -- has special characters in it.
6348 Error_Msg_Strlen := Full_Path_Name'Length;
6349 Error_Msg_String (1 .. Error_Msg_Strlen) :=
6350 Full_Path_Name.all;
6351 Error_Msg
6352 (Data.Flags,
6353 "could not create " & Create & " directory ~",
6354 Location,
6355 Project);
6356 end;
6357 end if;
6358 end if;
6359 end if;
6361 Dir_Exists := Is_Directory (Full_Path_Name.all);
6363 if not Must_Exist or Dir_Exists then
6364 declare
6365 Normed : constant String :=
6366 Normalize_Pathname
6367 (Full_Path_Name.all,
6368 Directory =>
6369 The_Parent (The_Parent'First .. The_Parent_Last),
6370 Resolve_Links => False,
6371 Case_Sensitive => True);
6373 Canonical_Path : constant String :=
6374 Normalize_Pathname
6375 (Normed,
6376 Directory =>
6377 The_Parent
6378 (The_Parent'First .. The_Parent_Last),
6379 Resolve_Links =>
6380 Opt.Follow_Links_For_Dirs,
6381 Case_Sensitive => False);
6383 begin
6384 Name_Len := Normed'Length;
6385 Name_Buffer (1 .. Name_Len) := Normed;
6387 -- Directories should always end with a directory separator
6389 if Name_Buffer (Name_Len) /= Directory_Separator then
6390 Add_Char_To_Name_Buffer (Directory_Separator);
6391 end if;
6393 Path.Display_Name := Name_Find;
6395 Name_Len := Canonical_Path'Length;
6396 Name_Buffer (1 .. Name_Len) := Canonical_Path;
6398 if Name_Buffer (Name_Len) /= Directory_Separator then
6399 Add_Char_To_Name_Buffer (Directory_Separator);
6400 end if;
6402 Path.Name := Name_Find;
6403 end;
6404 end if;
6406 Free (Full_Path_Name);
6407 end;
6408 end Locate_Directory;
6410 ---------------------------
6411 -- Find_Excluded_Sources --
6412 ---------------------------
6414 procedure Find_Excluded_Sources
6415 (Project : in out Project_Processing_Data;
6416 Data : in out Tree_Processing_Data)
6417 is
6418 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
6420 Excluded_Source_List_File : constant Variable_Value :=
6421 Util.Value_Of
6422 (Name_Excluded_Source_List_File,
6423 Project.Project.Decl.Attributes,
6424 Shared);
6425 Excluded_Sources : Variable_Value := Util.Value_Of
6426 (Name_Excluded_Source_Files,
6427 Project.Project.Decl.Attributes,
6428 Shared);
6430 Current : String_List_Id;
6431 Element : String_Element;
6432 Location : Source_Ptr;
6433 Name : File_Name_Type;
6434 File : Prj.Util.Text_File;
6435 Line : String (1 .. 300);
6436 Last : Natural;
6437 Locally_Removed : Boolean := False;
6439 begin
6440 -- If Excluded_Source_Files is not declared, check Locally_Removed_Files
6442 if Excluded_Sources.Default then
6443 Locally_Removed := True;
6444 Excluded_Sources :=
6445 Util.Value_Of
6446 (Name_Locally_Removed_Files,
6447 Project.Project.Decl.Attributes, Shared);
6448 end if;
6450 -- If there are excluded sources, put them in the table
6452 if not Excluded_Sources.Default then
6453 if not Excluded_Source_List_File.Default then
6454 if Locally_Removed then
6455 Error_Msg
6456 (Data.Flags,
6457 "?both attributes Locally_Removed_Files and " &
6458 "Excluded_Source_List_File are present",
6459 Excluded_Source_List_File.Location, Project.Project);
6460 else
6461 Error_Msg
6462 (Data.Flags,
6463 "?both attributes Excluded_Source_Files and " &
6464 "Excluded_Source_List_File are present",
6465 Excluded_Source_List_File.Location, Project.Project);
6466 end if;
6467 end if;
6469 Current := Excluded_Sources.Values;
6470 while Current /= Nil_String loop
6471 Element := Shared.String_Elements.Table (Current);
6472 Name := Canonical_Case_File_Name (Element.Value);
6474 -- If the element has no location, then use the location of
6475 -- Excluded_Sources to report possible errors.
6477 if Element.Location = No_Location then
6478 Location := Excluded_Sources.Location;
6479 else
6480 Location := Element.Location;
6481 end if;
6483 Excluded_Sources_Htable.Set
6484 (Project.Excluded, Name,
6485 (Name, No_File, 0, False, Location));
6486 Current := Element.Next;
6487 end loop;
6489 elsif not Excluded_Source_List_File.Default then
6490 Location := Excluded_Source_List_File.Location;
6492 declare
6493 Source_File_Name : constant File_Name_Type :=
6494 File_Name_Type
6495 (Excluded_Source_List_File.Value);
6496 Source_File_Line : Natural := 0;
6498 Source_File_Path_Name : constant String :=
6499 Path_Name_Of
6500 (Source_File_Name,
6501 Project.Project.Directory.Name);
6503 begin
6504 if Source_File_Path_Name'Length = 0 then
6505 Err_Vars.Error_Msg_File_1 :=
6506 File_Name_Type (Excluded_Source_List_File.Value);
6507 Error_Msg
6508 (Data.Flags,
6509 "file with excluded sources { does not exist",
6510 Excluded_Source_List_File.Location, Project.Project);
6512 else
6513 -- Open the file
6515 Prj.Util.Open (File, Source_File_Path_Name);
6517 if not Prj.Util.Is_Valid (File) then
6518 Error_Msg
6519 (Data.Flags, "file does not exist",
6520 Location, Project.Project);
6521 else
6522 -- Read the lines one by one
6524 while not Prj.Util.End_Of_File (File) loop
6525 Prj.Util.Get_Line (File, Line, Last);
6526 Source_File_Line := Source_File_Line + 1;
6528 -- Non empty, non comment line should contain a file name
6530 if Last /= 0
6531 and then (Last = 1 or else Line (1 .. 2) /= "--")
6532 then
6533 Name_Len := Last;
6534 Name_Buffer (1 .. Name_Len) := Line (1 .. Last);
6535 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
6536 Name := Name_Find;
6538 -- Check that there is no directory information
6540 for J in 1 .. Last loop
6541 if Is_Directory_Separator (Line (J)) then
6542 Error_Msg_File_1 := Name;
6543 Error_Msg
6544 (Data.Flags,
6545 "file name cannot include "
6546 & "directory information ({)",
6547 Location, Project.Project);
6548 exit;
6549 end if;
6550 end loop;
6552 Excluded_Sources_Htable.Set
6553 (Project.Excluded,
6554 Name,
6555 (Name, Source_File_Name, Source_File_Line,
6556 False, Location));
6557 end if;
6558 end loop;
6560 Prj.Util.Close (File);
6561 end if;
6562 end if;
6563 end;
6564 end if;
6565 end Find_Excluded_Sources;
6567 ------------------
6568 -- Find_Sources --
6569 ------------------
6571 procedure Find_Sources
6572 (Project : in out Project_Processing_Data;
6573 Data : in out Tree_Processing_Data)
6574 is
6575 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
6577 Sources : constant Variable_Value :=
6578 Util.Value_Of
6579 (Name_Source_Files,
6580 Project.Project.Decl.Attributes,
6581 Shared);
6583 Source_List_File : constant Variable_Value :=
6584 Util.Value_Of
6585 (Name_Source_List_File,
6586 Project.Project.Decl.Attributes,
6587 Shared);
6589 Name_Loc : Name_Location;
6590 Has_Explicit_Sources : Boolean;
6592 begin
6593 pragma Assert (Sources.Kind = List, "Source_Files is not a list");
6594 pragma Assert
6595 (Source_List_File.Kind = Single,
6596 "Source_List_File is not a single string");
6598 Project.Source_List_File_Location := Source_List_File.Location;
6600 -- If the user has specified a Source_Files attribute
6602 if not Sources.Default then
6603 if not Source_List_File.Default then
6604 Error_Msg
6605 (Data.Flags,
6606 "?both attributes source_files and " &
6607 "source_list_file are present",
6608 Source_List_File.Location, Project.Project);
6609 end if;
6611 -- Sources is a list of file names
6613 declare
6614 Current : String_List_Id := Sources.Values;
6615 Element : String_Element;
6616 Location : Source_Ptr;
6617 Name : File_Name_Type;
6619 begin
6620 if Current = Nil_String then
6621 Project.Project.Languages := No_Language_Index;
6623 -- This project contains no source. For projects that don't
6624 -- extend other projects, this also means that there is no
6625 -- need for an object directory, if not specified.
6627 if Project.Project.Extends = No_Project
6628 and then
6629 Project.Project.Object_Directory = Project.Project.Directory
6630 and then not (Project.Project.Qualifier = Aggregate_Library)
6631 then
6632 Project.Project.Object_Directory := No_Path_Information;
6633 end if;
6634 end if;
6636 while Current /= Nil_String loop
6637 Element := Shared.String_Elements.Table (Current);
6638 Name := Canonical_Case_File_Name (Element.Value);
6639 Get_Name_String (Element.Value);
6641 -- If the element has no location, then use the location of
6642 -- Sources to report possible errors.
6644 if Element.Location = No_Location then
6645 Location := Sources.Location;
6646 else
6647 Location := Element.Location;
6648 end if;
6650 -- Check that there is no directory information
6652 for J in 1 .. Name_Len loop
6653 if Is_Directory_Separator (Name_Buffer (J)) then
6654 Error_Msg_File_1 := Name;
6655 Error_Msg
6656 (Data.Flags,
6657 "file name cannot include directory " &
6658 "information ({)",
6659 Location, Project.Project);
6660 exit;
6661 end if;
6662 end loop;
6664 -- Check whether the file is already there: the same file name
6665 -- may be in the list. If the source is missing, the error will
6666 -- be on the first mention of the source file name.
6668 Name_Loc := Source_Names_Htable.Get
6669 (Project.Source_Names, Name);
6671 if Name_Loc = No_Name_Location then
6672 Name_Loc :=
6673 (Name => Name,
6674 Location => Location,
6675 Source => No_Source,
6676 Listed => True,
6677 Found => False);
6679 else
6680 Name_Loc.Listed := True;
6681 end if;
6683 Source_Names_Htable.Set
6684 (Project.Source_Names, Name, Name_Loc);
6686 Current := Element.Next;
6687 end loop;
6689 Has_Explicit_Sources := True;
6690 end;
6692 -- If we have no Source_Files attribute, check the Source_List_File
6693 -- attribute.
6695 elsif not Source_List_File.Default then
6697 -- Source_List_File is the name of the file that contains the source
6698 -- file names.
6700 declare
6701 Source_File_Path_Name : constant String :=
6702 Path_Name_Of
6703 (File_Name_Type
6704 (Source_List_File.Value),
6705 Project.Project.
6706 Directory.Display_Name);
6708 begin
6709 Has_Explicit_Sources := True;
6711 if Source_File_Path_Name'Length = 0 then
6712 Err_Vars.Error_Msg_File_1 :=
6713 File_Name_Type (Source_List_File.Value);
6714 Error_Msg
6715 (Data.Flags,
6716 "file with sources { does not exist",
6717 Source_List_File.Location, Project.Project);
6719 else
6720 Get_Sources_From_File
6721 (Source_File_Path_Name, Source_List_File.Location,
6722 Project, Data);
6723 end if;
6724 end;
6726 else
6727 -- Neither Source_Files nor Source_List_File has been specified. Find
6728 -- all the files that satisfy the naming scheme in all the source
6729 -- directories.
6731 Has_Explicit_Sources := False;
6732 end if;
6734 -- Remove any exception that is not in the specified list of sources
6736 if Has_Explicit_Sources then
6737 declare
6738 Source : Source_Id;
6739 Iter : Source_Iterator;
6740 NL : Name_Location;
6741 Again : Boolean;
6742 begin
6743 Iter_Loop :
6744 loop
6745 Again := False;
6746 Iter := For_Each_Source (Data.Tree, Project.Project);
6748 Source_Loop :
6749 loop
6750 Source := Prj.Element (Iter);
6751 exit Source_Loop when Source = No_Source;
6753 if Source.Naming_Exception /= No then
6754 NL := Source_Names_Htable.Get
6755 (Project.Source_Names, Source.File);
6757 if NL /= No_Name_Location and then not NL.Listed then
6759 -- Remove the exception
6761 Source_Names_Htable.Set
6762 (Project.Source_Names,
6763 Source.File,
6764 No_Name_Location);
6765 Remove_Source (Data.Tree, Source, No_Source);
6767 if Source.Naming_Exception = Yes then
6768 Error_Msg_Name_1 := Name_Id (Source.File);
6769 Error_Msg
6770 (Data.Flags,
6771 "? unknown source file %%",
6772 NL.Location,
6773 Project.Project);
6774 end if;
6776 Again := True;
6777 exit Source_Loop;
6778 end if;
6779 end if;
6781 Next (Iter);
6782 end loop Source_Loop;
6784 exit Iter_Loop when not Again;
6785 end loop Iter_Loop;
6786 end;
6787 end if;
6789 Search_Directories
6790 (Project,
6791 Data => Data,
6792 For_All_Sources => Sources.Default and then Source_List_File.Default);
6794 -- Check if all exceptions have been found
6796 declare
6797 Source : Source_Id;
6798 Iter : Source_Iterator;
6799 Found : Boolean := False;
6801 begin
6802 Iter := For_Each_Source (Data.Tree, Project.Project);
6803 loop
6804 Source := Prj.Element (Iter);
6805 exit when Source = No_Source;
6807 -- If the full source path is unknown for this source_id, there
6808 -- could be several reasons:
6809 -- * we simply did not find the file itself, this is an error
6810 -- * we have a multi-unit source file. Another Source_Id from
6811 -- the same file has received the full path, so we need to
6812 -- propagate it.
6814 if Source.Path = No_Path_Information then
6815 if Source.Naming_Exception = Yes then
6816 if Source.Unit /= No_Unit_Index then
6817 Found := False;
6819 if Source.Index /= 0 then -- Only multi-unit files
6820 declare
6821 S : Source_Id :=
6822 Source_Files_Htable.Get
6823 (Data.Tree.Source_Files_HT, Source.File);
6825 begin
6826 while S /= null loop
6827 if S.Path /= No_Path_Information then
6828 Source.Path := S.Path;
6829 Found := True;
6831 if Current_Verbosity = High then
6832 Debug_Output
6833 ("setting full path for "
6834 & Get_Name_String (Source.File)
6835 & " at" & Source.Index'Img
6836 & " to "
6837 & Get_Name_String (Source.Path.Name));
6838 end if;
6840 exit;
6841 end if;
6843 S := S.Next_With_File_Name;
6844 end loop;
6845 end;
6846 end if;
6848 if not Found then
6849 Error_Msg_Name_1 := Name_Id (Source.Display_File);
6850 Error_Msg_Name_2 := Source.Unit.Name;
6851 Error_Or_Warning
6852 (Data.Flags, Data.Flags.Missing_Source_Files,
6854 No_Location, Project.Project);
6855 end if;
6856 end if;
6858 if Source.Path = No_Path_Information then
6859 Remove_Source (Data.Tree, Source, No_Source);
6860 end if;
6862 elsif Source.Naming_Exception = Inherited then
6863 Remove_Source (Data.Tree, Source, No_Source);
6864 end if;
6865 end if;
6867 Next (Iter);
6868 end loop;
6869 end;
6871 -- It is an error if a source file name in a source list or in a source
6872 -- list file is not found.
6874 if Has_Explicit_Sources then
6875 declare
6876 NL : Name_Location;
6877 First_Error : Boolean;
6879 begin
6880 NL := Source_Names_Htable.Get_First (Project.Source_Names);
6881 First_Error := True;
6882 while NL /= No_Name_Location loop
6883 if not NL.Found then
6884 Err_Vars.Error_Msg_File_1 := NL.Name;
6885 if First_Error then
6886 Error_Or_Warning
6887 (Data.Flags, Data.Flags.Missing_Source_Files,
6888 "source file { not found",
6889 NL.Location, Project.Project);
6890 First_Error := False;
6891 else
6892 Error_Or_Warning
6893 (Data.Flags, Data.Flags.Missing_Source_Files,
6895 NL.Location, Project.Project);
6896 end if;
6897 end if;
6899 NL := Source_Names_Htable.Get_Next (Project.Source_Names);
6900 end loop;
6901 end;
6902 end if;
6903 end Find_Sources;
6905 ----------------
6906 -- Initialize --
6907 ----------------
6909 procedure Initialize
6910 (Data : out Tree_Processing_Data;
6911 Tree : Project_Tree_Ref;
6912 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
6913 Flags : Prj.Processing_Flags)
6914 is
6915 begin
6916 Data.Tree := Tree;
6917 Data.Node_Tree := Node_Tree;
6918 Data.Flags := Flags;
6919 end Initialize;
6921 ----------
6922 -- Free --
6923 ----------
6925 procedure Free (Data : in out Tree_Processing_Data) is
6926 pragma Unreferenced (Data);
6927 begin
6928 null;
6929 end Free;
6931 ----------------
6932 -- Initialize --
6933 ----------------
6935 procedure Initialize
6936 (Data : in out Project_Processing_Data;
6937 Project : Project_Id)
6938 is
6939 begin
6940 Data.Project := Project;
6941 end Initialize;
6943 ----------
6944 -- Free --
6945 ----------
6947 procedure Free (Data : in out Project_Processing_Data) is
6948 begin
6949 Source_Names_Htable.Reset (Data.Source_Names);
6950 Unit_Exceptions_Htable.Reset (Data.Unit_Exceptions);
6951 Excluded_Sources_Htable.Reset (Data.Excluded);
6952 end Free;
6954 -------------------------------
6955 -- Check_File_Naming_Schemes --
6956 -------------------------------
6958 procedure Check_File_Naming_Schemes
6959 (Project : Project_Processing_Data;
6960 File_Name : File_Name_Type;
6961 Alternate_Languages : out Language_List;
6962 Language : out Language_Ptr;
6963 Display_Language_Name : out Name_Id;
6964 Unit : out Name_Id;
6965 Lang_Kind : out Language_Kind;
6966 Kind : out Source_Kind)
6967 is
6968 Filename : constant String := Get_Name_String (File_Name);
6969 Config : Language_Config;
6970 Tmp_Lang : Language_Ptr;
6972 Header_File : Boolean := False;
6973 -- True if we found at least one language for which the file is a header
6974 -- In such a case, we search for all possible languages where this is
6975 -- also a header (C and C++ for instance), since the file might be used
6976 -- for several such languages.
6978 procedure Check_File_Based_Lang;
6979 -- Does the naming scheme test for file-based languages. For those,
6980 -- there is no Unit. Just check if the file name has the implementation
6981 -- or, if it is specified, the template suffix of the language.
6982 --
6983 -- Returns True if the file belongs to the current language and we
6984 -- should stop searching for matching languages. Not that a given header
6985 -- file could belong to several languages (C and C++ for instance). Thus
6986 -- if we found a header we'll check whether it matches other languages.
6988 ---------------------------
6989 -- Check_File_Based_Lang --
6990 ---------------------------
6992 procedure Check_File_Based_Lang is
6993 begin
6994 if not Header_File
6995 and then Suffix_Matches (Filename, Config.Naming_Data.Body_Suffix)
6996 then
6997 Unit := No_Name;
6998 Kind := Impl;
6999 Language := Tmp_Lang;
7001 Debug_Output
7002 ("implementation of language ", Display_Language_Name);
7004 elsif Suffix_Matches (Filename, Config.Naming_Data.Spec_Suffix) then
7005 Debug_Output
7006 ("header of language ", Display_Language_Name);
7008 if Header_File then
7009 Alternate_Languages := new Language_List_Element'
7013 else
7022 -- Start of processing for Check_File_Naming_Schemes
7024 begin
7035 Debug_Output
7047 Check_File_Based_Lang;
7052 -- We know it belongs to a least a file_based language, no
7053 -- need to check unit-based ones.
7056 Compute_Unit_Name
7078 -------------------
7079 -- Override_Kind --
7080 -------------------
7083 begin
7084 -- If the file was previously already associated with a unit, change it
7089 then
7090 -- If we had another file referencing the same unit (for instance it
7091 -- was in an extended project), that source file is in fact invisible
7092 -- from now on, and in particular doesn't belong to the same unit.
7093 -- If the source is an inherited naming exception, then it may not
7094 -- really exist: the source potentially replaced is left untouched.
7115 else
7121 ----------------
7122 -- Check_File --
7123 ----------------
7125 procedure Check_File
7135 is
7137 Source_Names_Htable.Get
7149 begin
7151 Debug_Increase_Indent
7159 else
7162 -- Check if it is OK to have the same file name in several
7163 -- source directories.
7167 then
7169 Error_Msg
7175 else
7178 Source_Names_Htable.Set
7184 else
7185 -- Set the full path for the source_id (which might have been
7186 -- created when parsing the naming exceptions, and therefore
7187 -- might not have the full path).
7188 -- We only set this for this source_id, but not for other
7189 -- source_id in the same file (case of multi-unit source files)
7190 -- For the latter, they will be set in Find_Sources when we
7191 -- check that all source_id have known full paths.
7192 -- Doing this later saves one htable lookup per file in the
7193 -- common case where the user is not using multi-unit files.
7197 Source_Paths_Htable.Set
7200 -- Check if this is a subunit
7204 then
7213 -- If this is an inherited naming exception, make sure that
7214 -- the naming exception it replaces is no longer a source.
7217 declare
7221 begin
7249 Units_Htable.Set
7260 Check_File_Naming_Schemes
7272 -- A file name in a list must be a source of a language
7275 then
7277 Error_Msg
7283 else
7284 Add_Source
7298 -- If it is a source specified in a list, update the entry in
7299 -- the Source_Names table.
7303 Source_Names_Htable.Set
7309 Debug_Decrease_Indent;
7312 ---------------------------------
7313 -- Expand_Subdirectory_Pattern --
7314 ---------------------------------
7316 procedure Expand_Subdirectory_Pattern
7323 is
7333 -- Hash table stores recursive source directories, to avoid looking
7334 -- several times, and to avoid cycles that may be introduced by symbolic
7335 -- links.
7338 -- Pattern to use when matching file names
7342 procedure Find_Pattern
7346 -- Find a specific pattern
7348 function Recursive_Find_Dirs
7351 -- Search all the subdirectories (recursively) of Path.
7352 -- Return True if at least one file or directory was processed
7354 function Subdirectory_Matches
7357 -- Called when a matching directory was found. If the user is in fact
7358 -- searching for files, we then search for those files matching the
7359 -- pattern within the directory.
7360 -- Return True if at least one file or directory was processed
7362 --------------------------
7363 -- Subdirectory_Matches --
7364 --------------------------
7366 function Subdirectory_Matches
7369 is
7376 begin
7384 loop
7391 then
7410 -------------------------
7411 -- Recursive_Find_Dirs --
7412 -------------------------
7414 function Recursive_Find_Dirs
7417 is
7424 begin
7437 loop
7442 declare
7444 Normalize_Pathname
7453 begin
7456 declare
7460 begin
7464 Get_Name_String
7466 Canonical_Case_File_Name
7483 Success :=
7495 exception
7500 ------------------
7501 -- Find_Pattern --
7502 ------------------
7504 procedure Find_Pattern
7508 is
7518 begin
7521 -- If we are looking for files, find the pattern for the files
7526 loop
7532 Error_Or_Warning
7539 Debug_Indent;
7546 File_Pattern := Compile
7551 -- If we had just "*.gpr", this is equivalent to "./*.gpr"
7558 Recursive :=
7561 and then
7576 Locate_Directory
7586 Error_Or_Warning
7594 -- Links have been resolved if necessary, and Path_Name
7595 -- always ends with a directory separator.
7599 else
7610 Error_Or_Warning
7620 -- Local variables
7626 -- Start of processing for Expand_Subdirectory_Pattern
7628 begin
7639 ------------------------
7640 -- Search_Directories --
7641 ------------------------
7643 procedure Search_Directories
7647 is
7660 begin
7663 -- Loop through subdirectories
7669 begin
7673 -- Use Element.Value in this test, not Display_Value, because we
7674 -- want the symbolic links to be resolved when appropriate.
7677 declare
7686 Get_Name_String
7689 -- Display_Source_Directory is to allow us to open a UTF-8
7690 -- encoded directory on Windows.
7692 begin
7694 Debug_Increase_Indent
7700 -- We look to every entry in the source directory
7704 loop
7708 -- In fast project loading mode (without -eL), the user
7709 -- guarantees that no directory has a name which is a
7710 -- valid source name, so we can avoid doing a system call
7711 -- here. This provides a very significant speed up on
7712 -- slow file systems (remote files for instance).
7715 or else Is_Regular_File
7717 then
7724 else
7725 Canonical_Case_File_Name
7730 declare
7732 Normalize_Pathname
7734 Directory =>
7735 Source_Directory
7737 Dir_Last),
7738 Resolve_Links =>
7744 Excluded_Sources_Htable.Get
7748 begin
7754 else
7755 Canonical_Case_File_Name
7763 Excluded_Sources_Htable.Set
7766 Debug_Output
7770 -- Will mark the file as removed, but we
7771 -- still need to add it to the list: if we
7772 -- don't, the file will not appear in the
7773 -- mapping file and will cause the compiler
7774 -- to fail.
7780 -- Preserve the user's original casing and use of
7781 -- links. The display_value (a directory) already
7782 -- ends with a directory separator by construction,
7783 -- so no need to add one.
7788 Check_File
7800 else
7807 Debug_Decrease_Indent;
7812 exception
7824 ----------------------------
7825 -- Load_Naming_Exceptions --
7826 ----------------------------
7828 procedure Load_Naming_Exceptions
7831 is
7835 begin
7837 loop
7841 -- An excluded file cannot also be an exception file name
7844 No_File_Found
7845 then
7847 Error_Msg
7853 Debug_Output
7857 Source_Names_Htable.Set
7861 (Name => Source.File,
7862 Location => Source.Location,
7863 Source => Source,
7864 Listed => False,
7865 Found => False));
7867 -- If this is an Ada exception, record in table Unit_Exceptions
7869 if Source.Unit /= No_Unit_Index then
7870 declare
7871 Unit_Except : Unit_Exception :=
7872 Unit_Exceptions_Htable.Get
7873 (Project.Unit_Exceptions, Source.Unit.Name);
7875 begin
7876 Unit_Except.Name := Source.Unit.Name;
7878 if Source.Kind = Spec then
7879 Unit_Except.Spec := Source.File;
7880 else
7881 Unit_Except.Impl := Source.File;
7882 end if;
7884 Unit_Exceptions_Htable.Set
7885 (Project.Unit_Exceptions, Source.Unit.Name, Unit_Except);
7886 end;
7887 end if;
7889 Next (Iter);
7890 end loop;
7891 end Load_Naming_Exceptions;
7893 ----------------------
7894 -- Look_For_Sources --
7895 ----------------------
7897 procedure Look_For_Sources
7898 (Project : in out Project_Processing_Data;
7899 Data : in out Tree_Processing_Data)
7900 is
7901 Object_Files : Object_File_Names_Htable.Instance;
7902 Iter : Source_Iterator;
7903 Src : Source_Id;
7905 procedure Check_Object (Src : Source_Id);
7906 -- Check if object file name of Src is already used in the project tree,
7907 -- and report an error if so.
7909 procedure Check_Object_Files;
7910 -- Check that no two sources of this project have the same object file
7912 procedure Mark_Excluded_Sources;
7913 -- Mark as such the sources that are declared as excluded
7915 procedure Check_Missing_Sources;
7916 -- Check whether one of the languages has no sources, and report an
7917 -- error when appropriate
7919 procedure Get_Sources_From_Source_Info;
7920 -- Get the source information from the tables that were created when a
7921 -- source info file was read.
7923 ---------------------------
7924 -- Check_Missing_Sources --
7925 ---------------------------
7927 procedure Check_Missing_Sources is
7928 Extending : constant Boolean :=
7929 Project.Project.Extends /= No_Project;
7930 Language : Language_Ptr;
7931 Source : Source_Id;
7932 Alt_Lang : Language_List;
7933 Continuation : Boolean := False;
7934 Iter : Source_Iterator;
7935 begin
7936 if not Project.Project.Externally_Built and then not Extending then
7937 Language := Project.Project.Languages;
7938 while Language /= No_Language_Index loop
7940 -- If there are no sources for this language, check if there
7941 -- are sources for which this is an alternate language.
7943 if Language.First_Source = No_Source
7944 and then (Data.Flags.Require_Sources_Other_Lang
7945 or else Language.Name = Name_Ada)
7946 then
7947 Iter := For_Each_Source (In_Tree => Data.Tree,
7948 Project => Project.Project);
7949 Source_Loop : loop
7950 Source := Element (Iter);
7951 exit Source_Loop when Source = No_Source
7952 or else Source.Language = Language;
7954 Alt_Lang := Source.Alternate_Languages;
7955 while Alt_Lang /= null loop
7956 exit Source_Loop when Alt_Lang.Language = Language;
7957 Alt_Lang := Alt_Lang.Next;
7958 end loop;
7960 Next (Iter);
7961 end loop Source_Loop;
7963 if Source = No_Source then
7964 Report_No_Sources
7965 (Project.Project,
7966 Get_Name_String (Language.Display_Name),
7967 Data,
7968 Project.Source_List_File_Location,
7969 Continuation);
7970 Continuation := True;
7971 end if;
7972 end if;
7974 Language := Language.Next;
7975 end loop;
7976 end if;
7977 end Check_Missing_Sources;
7979 ------------------
7980 -- Check_Object --
7981 ------------------
7983 procedure Check_Object (Src : Source_Id) is
7984 Source : Source_Id;
7986 begin
7987 Source := Object_File_Names_Htable.Get (Object_Files, Src.Object);
7989 -- We cannot just check on "Source /= Src", since we might have
7990 -- two different entries for the same file (and since that's
7991 -- the same file it is expected that it has the same object)
7993 if Source /= No_Source
7994 and then Source.Replaced_By = No_Source
7995 and then Source.Path /= Src.Path
7996 and then Source.Index = 0
7997 and then Src.Index = 0
7998 and then Is_Extending (Src.Project, Source.Project)
7999 then
8000 Error_Msg_File_1 := Src.File;
8001 Error_Msg_File_2 := Source.File;
8002 Error_Msg
8003 (Data.Flags,
8005 No_Location, Project.Project);
8007 else
8008 Object_File_Names_Htable.Set (Object_Files, Src.Object, Src);
8009 end if;
8010 end Check_Object;
8012 ---------------------------
8013 -- Mark_Excluded_Sources --
8014 ---------------------------
8016 procedure Mark_Excluded_Sources is
8017 Source : Source_Id := No_Source;
8018 Excluded : File_Found;
8019 Proj : Project_Id;
8021 begin
8022 -- Minor optimization: if there are no excluded files, no need to
8023 -- traverse the list of sources. We cannot however also check whether
8024 -- the existing exceptions have ".Found" set to True (indicating we
8025 -- found them before) because we need to do some final processing on
8026 -- them in any case.
8028 if Excluded_Sources_Htable.Get_First (Project.Excluded) /=
8029 No_File_Found
8030 then
8031 Proj := Project.Project;
8032 while Proj /= No_Project loop
8033 Iter := For_Each_Source (Data.Tree, Proj);
8034 while Prj.Element (Iter) /= No_Source loop
8035 Source := Prj.Element (Iter);
8036 Excluded := Excluded_Sources_Htable.Get
8037 (Project.Excluded, Source.File);
8039 if Excluded /= No_File_Found then
8040 Source.In_Interfaces := False;
8041 Source.Locally_Removed := True;
8043 if Proj = Project.Project then
8044 Source.Suppressed := True;
8045 end if;
8047 if Current_Verbosity = High then
8048 Debug_Indent;
8049 Write_Str ("removing file ");
8050 Write_Line
8051 (Get_Name_String (Excluded.File)
8052 & " " & Get_Name_String (Source.Project.Name));
8053 end if;
8055 Excluded_Sources_Htable.Remove
8056 (Project.Excluded, Source.File);
8057 end if;
8059 Next (Iter);
8060 end loop;
8062 Proj := Proj.Extends;
8063 end loop;
8064 end if;
8066 -- If we have any excluded element left, that means we did not find
8067 -- the source file
8069 Excluded := Excluded_Sources_Htable.Get_First (Project.Excluded);
8070 while Excluded /= No_File_Found loop
8071 if not Excluded.Found then
8073 -- Check if the file belongs to another imported project to
8074 -- provide a better error message.
8076 Src := Find_Source
8077 (In_Tree => Data.Tree,
8078 Project => Project.Project,
8079 In_Imported_Only => True,
8080 Base_Name => Excluded.File);
8082 Err_Vars.Error_Msg_File_1 := Excluded.File;
8084 if Src = No_Source then
8085 if Excluded.Excl_File = No_File then
8086 Error_Msg
8087 (Data.Flags,
8088 "unknown file {", Excluded.Location, Project.Project);
8090 else
8091 Error_Msg
8092 (Data.Flags,
8093 "in " &
8094 Get_Name_String (Excluded.Excl_File) & ":" &
8095 No_Space_Img (Excluded.Excl_Line) &
8096 ": unknown file {", Excluded.Location, Project.Project);
8097 end if;
8099 else
8100 if Excluded.Excl_File = No_File then
8101 Error_Msg
8102 (Data.Flags,
8103 "cannot remove a source from an imported project: {",
8104 Excluded.Location, Project.Project);
8106 else
8107 Error_Msg
8108 (Data.Flags,
8109 "in " &
8110 Get_Name_String (Excluded.Excl_File) & ":" &
8111 No_Space_Img (Excluded.Excl_Line) &
8112 ": cannot remove a source from an imported project: {",
8113 Excluded.Location, Project.Project);
8114 end if;
8115 end if;
8116 end if;
8118 Excluded := Excluded_Sources_Htable.Get_Next (Project.Excluded);
8119 end loop;
8120 end Mark_Excluded_Sources;
8122 ------------------------
8123 -- Check_Object_Files --
8124 ------------------------
8126 procedure Check_Object_Files is
8127 Iter : Source_Iterator;
8128 Src_Id : Source_Id;
8129 Src_Ind : Source_File_Index;
8131 begin
8132 Iter := For_Each_Source (Data.Tree);
8133 loop
8134 Src_Id := Prj.Element (Iter);
8135 exit when Src_Id = No_Source;
8137 if Is_Compilable (Src_Id)
8138 and then Src_Id.Language.Config.Object_Generated
8139 and then Is_Extending (Project.Project, Src_Id.Project)
8140 then
8141 if Src_Id.Unit = No_Unit_Index then
8142 if Src_Id.Kind = Impl then
8143 Check_Object (Src_Id);
8144 end if;
8146 else
8147 case Src_Id.Kind is
8148 when Spec =>
8149 if Other_Part (Src_Id) = No_Source then
8150 Check_Object (Src_Id);
8151 end if;
8153 when Sep =>
8154 null;
8156 when Impl =>
8157 if Other_Part (Src_Id) /= No_Source then
8158 Check_Object (Src_Id);
8160 else
8161 -- Check if it is a subunit
8163 Src_Ind :=
8164 Sinput.P.Load_Project_File
8165 (Get_Name_String (Src_Id.Path.Display_Name));
8167 if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
8168 Override_Kind (Src_Id, Sep);
8169 else
8170 Check_Object (Src_Id);
8171 end if;
8172 end if;
8173 end case;
8174 end if;
8175 end if;
8177 Next (Iter);
8178 end loop;
8179 end Check_Object_Files;
8181 ----------------------------------
8182 -- Get_Sources_From_Source_Info --
8183 ----------------------------------
8185 procedure Get_Sources_From_Source_Info is
8186 Iter : Source_Info_Iterator;
8187 Src : Source_Info;
8188 Id : Source_Id;
8189 Lang_Id : Language_Ptr;
8191 begin
8192 Initialize (Iter, Project.Project.Name);
8194 loop
8195 Src := Source_Info_Of (Iter);
8197 exit when Src = No_Source_Info;
8199 Id := new Source_Data;
8201 Id.Project := Project.Project;
8203 Lang_Id := Project.Project.Languages;
8204 while Lang_Id /= No_Language_Index
8205 and then Lang_Id.Name /= Src.Language
8206 loop
8207 Lang_Id := Lang_Id.Next;
8208 end loop;
8210 if Lang_Id = No_Language_Index then
8211 Prj.Com.Fail
8212 ("unknown language " &
8213 Get_Name_String (Src.Language) &
8214 " for project " &
8215 Get_Name_String (Src.Project) &
8216 " in source info file");
8217 end if;
8219 Id.Language := Lang_Id;
8220 Id.Kind := Src.Kind;
8221 Id.Index := Src.Index;
8223 Id.Path :=
8224 (Path_Name_Type (Src.Display_Path_Name),
8225 Path_Name_Type (Src.Path_Name));
8227 Name_Len := 0;
8228 Add_Str_To_Name_Buffer
8229 (Directories.Simple_Name (Get_Name_String (Src.Path_Name)));
8230 Id.File := Name_Find;
8232 Id.Next_With_File_Name :=
8233 Source_Files_Htable.Get (Data.Tree.Source_Files_HT, Id.File);
8234 Source_Files_Htable.Set (Data.Tree.Source_Files_HT, Id.File, Id);
8236 Name_Len := 0;
8237 Add_Str_To_Name_Buffer
8238 (Directories.Simple_Name
8239 (Get_Name_String (Src.Display_Path_Name)));
8240 Id.Display_File := Name_Find;
8242 Id.Dep_Name :=
8243 Dependency_Name (Id.File, Id.Language.Config.Dependency_Kind);
8244 Id.Naming_Exception := Src.Naming_Exception;
8245 Id.Object :=
8246 Object_Name (Id.File, Id.Language.Config.Object_File_Suffix);
8247 Id.Switches := Switches_Name (Id.File);
8249 -- Add the source id to the Unit_Sources_HT hash table, if the
8250 -- unit name is not null.
8252 if Src.Kind /= Sep and then Src.Unit_Name /= No_Name then
8253 declare
8254 UData : Unit_Index :=
8255 Units_Htable.Get (Data.Tree.Units_HT, Src.Unit_Name);
8256 begin
8257 if UData = No_Unit_Index then
8258 UData := new Unit_Data;
8259 UData.Name := Src.Unit_Name;
8260 Units_Htable.Set
8261 (Data.Tree.Units_HT, Src.Unit_Name, UData);
8262 end if;
8264 Id.Unit := UData;
8265 end;
8267 -- Note that this updates Unit information as well
8269 Override_Kind (Id, Id.Kind);
8270 end if;
8272 if Src.Index /= 0 then
8273 Project.Project.Has_Multi_Unit_Sources := True;
8274 end if;
8276 -- Add the source to the language list
8278 Id.Next_In_Lang := Id.Language.First_Source;
8279 Id.Language.First_Source := Id;
8281 Next (Iter);
8282 end loop;
8283 end Get_Sources_From_Source_Info;
8285 -- Start of processing for Look_For_Sources
8287 begin
8288 if Data.Tree.Source_Info_File_Exists then
8289 Get_Sources_From_Source_Info;
8291 else
8292 if Project.Project.Source_Dirs /= Nil_String then
8293 Find_Excluded_Sources (Project, Data);
8295 if Project.Project.Languages /= No_Language_Index then
8296 Load_Naming_Exceptions (Project, Data);
8297 Find_Sources (Project, Data);
8298 Mark_Excluded_Sources;
8299 Check_Object_Files;
8300 Check_Missing_Sources;
8301 end if;
8302 end if;
8304 Object_File_Names_Htable.Reset (Object_Files);
8305 end if;
8306 end Look_For_Sources;
8308 ------------------
8309 -- Path_Name_Of --
8310 ------------------
8312 function Path_Name_Of
8313 (File_Name : File_Name_Type;
8314 Directory : Path_Name_Type) return String
8315 is
8316 Result : String_Access;
8317 The_Directory : constant String := Get_Name_String (Directory);
8319 begin
8320 Debug_Output ("Path_Name_Of file name=", Name_Id (File_Name));
8321 Debug_Output ("Path_Name_Of directory=", Name_Id (Directory));
8322 Get_Name_String (File_Name);
8323 Result :=
8324 Locate_Regular_File
8325 (File_Name => Name_Buffer (1 .. Name_Len),
8326 Path => The_Directory);
8328 if Result = null then
8329 return "";
8330 else
8331 declare
8332 R : constant String := Result.all;
8333 begin
8334 Free (Result);
8335 return R;
8336 end;
8337 end if;
8338 end Path_Name_Of;
8340 -------------------
8341 -- Remove_Source --
8342 -------------------
8344 procedure Remove_Source
8345 (Tree : Project_Tree_Ref;
8346 Id : Source_Id;
8347 Replaced_By : Source_Id)
8348 is
8349 Source : Source_Id;
8351 begin
8352 if Current_Verbosity = High then
8353 Debug_Indent;
8354 Write_Str ("removing source ");
8355 Write_Str (Get_Name_String (Id.File));
8357 if Id.Index /= 0 then
8358 Write_Str (" at" & Id.Index'Img);
8359 end if;
8361 Write_Eol;
8362 end if;
8364 if Replaced_By /= No_Source then
8365 Id.Replaced_By := Replaced_By;
8366 Replaced_By.Declared_In_Interfaces := Id.Declared_In_Interfaces;
8368 if Id.File /= Replaced_By.File then
8369 declare
8370 Replacement : constant File_Name_Type :=
8371 Replaced_Source_HTable.Get
8372 (Tree.Replaced_Sources, Id.File);
8374 begin
8375 Replaced_Source_HTable.Set
8376 (Tree.Replaced_Sources, Id.File, Replaced_By.File);
8378 if Replacement = No_File then
8379 Tree.Replaced_Source_Number :=
8380 Tree.Replaced_Source_Number + 1;
8381 end if;
8382 end;
8383 end if;
8384 end if;
8386 Id.In_Interfaces := False;
8387 Id.Locally_Removed := True;
8389 -- ??? Should we remove the source from the unit ? The file is not used,
8390 -- so probably should not be referenced from the unit. On the other hand
8391 -- it might give useful additional info
8392 -- if Id.Unit /= null then
8393 -- Id.Unit.File_Names (Id.Kind) := null;
8394 -- end if;
8396 Source := Id.Language.First_Source;
8398 if Source = Id then
8399 Id.Language.First_Source := Id.Next_In_Lang;
8401 else
8402 while Source.Next_In_Lang /= Id loop
8403 Source := Source.Next_In_Lang;
8404 end loop;
8406 Source.Next_In_Lang := Id.Next_In_Lang;
8407 end if;
8408 end Remove_Source;
8410 -----------------------
8411 -- Report_No_Sources --
8412 -----------------------
8414 procedure Report_No_Sources
8415 (Project : Project_Id;
8416 Lang_Name : String;
8417 Data : Tree_Processing_Data;
8418 Location : Source_Ptr;
8419 Continuation : Boolean := False)
8420 is
8421 begin
8422 case Data.Flags.When_No_Sources is
8423 when Silent =>
8424 null;
8426 when Error
8427 | Warning
8428 =>
8429 declare
8430 Msg : constant String :=
8431 "<there are no " & Lang_Name
8432 & " sources in this project";
8434 begin
8435 Error_Msg_Warn := Data.Flags.When_No_Sources = Warning;
8437 if Continuation then
8439 else
8440 Error_Msg (Data.Flags, Msg, Location, Project);
8441 end if;
8442 end;
8443 end case;
8444 end Report_No_Sources;
8446 ----------------------
8447 -- Show_Source_Dirs --
8448 ----------------------
8450 procedure Show_Source_Dirs
8451 (Project : Project_Id;
8452 Shared : Shared_Project_Tree_Data_Access)
8453 is
8454 Current : String_List_Id;
8455 Element : String_Element;
8457 begin
8458 if Project.Source_Dirs = Nil_String then
8459 Debug_Output ("no Source_Dirs");
8460 else
8461 Debug_Increase_Indent ("Source_Dirs:");
8463 Current := Project.Source_Dirs;
8464 while Current /= Nil_String loop
8465 Element := Shared.String_Elements.Table (Current);
8466 Debug_Output (Get_Name_String (Element.Display_Value));
8467 Current := Element.Next;
8468 end loop;
8470 Debug_Decrease_Indent ("end Source_Dirs.");
8471 end if;
8472 end Show_Source_Dirs;
8474 ---------------------------
8475 -- Process_Naming_Scheme --
8476 ---------------------------
8478 procedure Process_Naming_Scheme
8479 (Tree : Project_Tree_Ref;
8480 Root_Project : Project_Id;
8481 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
8482 Flags : Processing_Flags)
8483 is
8485 procedure Check
8486 (Project : Project_Id;
8487 In_Aggregate_Lib : Boolean;
8488 Data : in out Tree_Processing_Data);
8489 -- Process the naming scheme for a single project
8491 procedure Recursive_Check
8492 (Project : Project_Id;
8493 Prj_Tree : Project_Tree_Ref;
8494 Context : Project_Context;
8495 Data : in out Tree_Processing_Data);
8496 -- Check_Naming_Scheme for the project
8498 -----------
8499 -- Check --
8500 -----------
8502 procedure Check
8503 (Project : Project_Id;
8504 In_Aggregate_Lib : Boolean;
8505 Data : in out Tree_Processing_Data)
8506 is
8507 procedure Check_Aggregated;
8508 -- Check aggregated projects which should not be externally built
8510 ----------------------
8511 -- Check_Aggregated --
8512 ----------------------
8514 procedure Check_Aggregated is
8515 L : Aggregated_Project_List;
8517 begin
8518 -- Check that aggregated projects are not externally built
8520 L := Project.Aggregated_Projects;
8521 while L /= null loop
8522 declare
8523 Var : constant Prj.Variable_Value :=
8524 Prj.Util.Value_Of
8525 (Snames.Name_Externally_Built,
8526 L.Project.Decl.Attributes,
8527 Data.Tree.Shared);
8528 begin
8529 if not Var.Default then
8530 Error_Msg_Name_1 := L.Project.Display_Name;
8531 Error_Msg
8532 (Data.Flags,
8533 "cannot aggregate externally built project %%",
8534 Var.Location, Project);
8535 end if;
8536 end;
8538 L := L.Next;
8539 end loop;
8540 end Check_Aggregated;
8542 -- Local Variables
8544 Shared : constant Shared_Project_Tree_Data_Access :=
8545 Data.Tree.Shared;
8546 Prj_Data : Project_Processing_Data;
8548 -- Start of processing for Check
8550 begin
8551 Debug_Increase_Indent ("check", Project.Name);
8553 Initialize (Prj_Data, Project);
8555 Check_If_Externally_Built (Project, Data);
8557 case Project.Qualifier is
8558 when Aggregate =>
8559 Check_Aggregated;
8561 when Aggregate_Library =>
8562 Check_Aggregated;
8564 if Project.Object_Directory = No_Path_Information then
8565 Project.Object_Directory := Project.Directory;
8566 end if;
8568 when others =>
8569 Get_Directories (Project, Data);
8570 Check_Programming_Languages (Project, Data);
8572 if Current_Verbosity = High then
8573 Show_Source_Dirs (Project, Shared);
8574 end if;
8576 if Project.Qualifier = Abstract_Project then
8577 Check_Abstract_Project (Project, Data);
8578 end if;
8579 end case;
8581 -- Check configuration. Must be done for gnatmake (even though no
8582 -- user configuration file was provided) since the default config we
8583 -- generate indicates whether libraries are supported for instance.
8585 Check_Configuration (Project, Data);
8587 if Project.Qualifier /= Aggregate then
8588 Check_Library_Attributes (Project, Data);
8589 Check_Package_Naming (Project, Data);
8591 -- An aggregate library has no source, no need to look for them
8593 if Project.Qualifier /= Aggregate_Library then
8594 Look_For_Sources (Prj_Data, Data);
8595 end if;
8597 Check_Interfaces (Project, Data);
8599 -- If this library is part of an aggregated library don't check it
8600 -- as it has no sources by itself and so interface won't be found.
8602 if Project.Library and not In_Aggregate_Lib then
8603 Check_Stand_Alone_Library (Project, Data);
8604 end if;
8606 Get_Mains (Project, Data);
8607 end if;
8609 Free (Prj_Data);
8611 Debug_Decrease_Indent ("done check");
8612 end Check;
8614 ---------------------
8615 -- Recursive_Check --
8616 ---------------------
8618 procedure Recursive_Check
8619 (Project : Project_Id;
8620 Prj_Tree : Project_Tree_Ref;
8621 Context : Project_Context;
8622 Data : in out Tree_Processing_Data)
8623 is
8624 begin
8625 if Current_Verbosity = High then
8626 Debug_Increase_Indent
8627 ("Processing_Naming_Scheme for project", Project.Name);
8628 end if;
8630 Data.Tree := Prj_Tree;
8631 Data.In_Aggregate_Lib := Context.In_Aggregate_Lib;
8633 Check (Project, Context.In_Aggregate_Lib, Data);
8635 if Current_Verbosity = High then
8636 Debug_Decrease_Indent ("done Processing_Naming_Scheme");
8637 end if;
8638 end Recursive_Check;
8640 procedure Check_All_Projects is new For_Every_Project_Imported_Context
8641 (Tree_Processing_Data, Recursive_Check);
8642 -- Comment required???
8644 -- Local Variables
8646 Data : Tree_Processing_Data;
8648 -- Start of processing for Process_Naming_Scheme
8650 begin
8651 Lib_Data_Table.Init;
8652 Initialize (Data, Tree => Tree, Node_Tree => Node_Tree, Flags => Flags);
8653 Check_All_Projects (Root_Project, Tree, Data, Imported_First => True);
8654 Free (Data);
8656 -- Adjust language configs for projects that are extended
8658 declare
8659 List : Project_List;
8660 Proj : Project_Id;
8661 Exte : Project_Id;
8662 Lang : Language_Ptr;
8663 Elng : Language_Ptr;
8665 begin
8666 List := Tree.Projects;
8667 while List /= null loop
8668 Proj := List.Project;
8670 Exte := Proj;
8671 while Exte.Extended_By /= No_Project loop
8672 Exte := Exte.Extended_By;
8673 end loop;
8675 if Exte /= Proj then
8676 Lang := Proj.Languages;
8678 if Lang /= No_Language_Index then
8679 loop
8680 Elng := Get_Language_From_Name
8681 (Exte, Get_Name_String (Lang.Name));
8682 exit when Elng /= No_Language_Index;
8683 Exte := Exte.Extends;
8684 end loop;
8686 if Elng /= Lang then
8687 Lang.Config := Elng.Config;
8688 end if;
8689 end if;
8690 end if;
8692 List := List.Next;
8693 end loop;
8694 end;
8695 end Process_Naming_Scheme;
8697 end Prj.Nmsc;