| blob | 3bfe2d837edd8ea1edc5d0f15e1f29cc67fed509 |
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-2014, 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_Required_Switches
1505 | Name_Leading_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 then
1807 case Current_Array.Name is
1808 when Name_Spec_Suffix | Name_Specification_Suffix =>
1810 -- Attribute Spec_Suffix (<language>)
1812 Get_Name_String (Element.Value.Value);
1813 Canonical_Case_File_Name
1814 (Name_Buffer (1 .. Name_Len));
1815 Lang_Index.Config.Naming_Data.Spec_Suffix :=
1816 Name_Find;
1818 when Name_Implementation_Suffix | Name_Body_Suffix =>
1820 Get_Name_String (Element.Value.Value);
1821 Canonical_Case_File_Name
1822 (Name_Buffer (1 .. Name_Len));
1824 -- Attribute Body_Suffix (<language>)
1826 Lang_Index.Config.Naming_Data.Body_Suffix :=
1827 Name_Find;
1828 Lang_Index.Config.Naming_Data.Separate_Suffix :=
1829 Lang_Index.Config.Naming_Data.Body_Suffix;
1831 when others =>
1832 null;
1833 end case;
1834 end if;
1836 Element_Id := Element.Next;
1837 end loop;
1839 Current_Array_Id := Current_Array.Next;
1840 end loop;
1841 end Process_Naming;
1843 --------------------
1844 -- Process_Linker --
1845 --------------------
1847 procedure Process_Linker (Attributes : Variable_Id) is
1848 Attribute_Id : Variable_Id;
1849 Attribute : Variable;
1851 begin
1852 -- Process non associated array attribute from package Linker
1854 Attribute_Id := Attributes;
1855 while Attribute_Id /= No_Variable loop
1856 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
1858 if not Attribute.Value.Default then
1859 if Attribute.Name = Name_Driver then
1861 -- Attribute Linker'Driver: the default linker to use
1863 Project.Config.Linker :=
1864 Path_Name_Type (Attribute.Value.Value);
1866 -- Linker'Driver is also used to link shared libraries
1867 -- if the obsolescent attribute Library_GCC has not been
1868 -- specified.
1870 if Project.Config.Shared_Lib_Driver = No_File then
1871 Project.Config.Shared_Lib_Driver :=
1872 File_Name_Type (Attribute.Value.Value);
1873 end if;
1875 elsif Attribute.Name = Name_Required_Switches then
1877 -- Attribute Required_Switches: the minimum trailing
1878 -- options to use when invoking the linker
1880 Put (Into_List =>
1881 Project.Config.Trailing_Linker_Required_Switches,
1882 From_List => Attribute.Value.Values,
1883 In_Tree => Data.Tree);
1885 elsif Attribute.Name = Name_Map_File_Option then
1886 Project.Config.Map_File_Option := Attribute.Value.Value;
1888 elsif Attribute.Name = Name_Max_Command_Line_Length then
1889 begin
1890 Project.Config.Max_Command_Line_Length :=
1891 Natural'Value (Get_Name_String
1892 (Attribute.Value.Value));
1894 exception
1895 when Constraint_Error =>
1896 Error_Msg
1897 (Data.Flags,
1898 "value must be positive or equal to 0",
1899 Attribute.Value.Location, Project);
1900 end;
1902 elsif Attribute.Name = Name_Response_File_Format then
1903 declare
1904 Name : Name_Id;
1906 begin
1907 Get_Name_String (Attribute.Value.Value);
1908 To_Lower (Name_Buffer (1 .. Name_Len));
1909 Name := Name_Find;
1911 if Name = Name_None then
1912 Project.Config.Resp_File_Format := None;
1914 elsif Name = Name_Gnu then
1915 Project.Config.Resp_File_Format := GNU;
1917 elsif Name = Name_Object_List then
1918 Project.Config.Resp_File_Format := Object_List;
1920 elsif Name = Name_Option_List then
1921 Project.Config.Resp_File_Format := Option_List;
1923 elsif Name_Buffer (1 .. Name_Len) = "gcc" then
1924 Project.Config.Resp_File_Format := GCC;
1926 elsif Name_Buffer (1 .. Name_Len) = "gcc_gnu" then
1927 Project.Config.Resp_File_Format := GCC_GNU;
1929 elsif
1930 Name_Buffer (1 .. Name_Len) = "gcc_option_list"
1931 then
1932 Project.Config.Resp_File_Format := GCC_Option_List;
1934 elsif
1935 Name_Buffer (1 .. Name_Len) = "gcc_object_list"
1936 then
1937 Project.Config.Resp_File_Format := GCC_Object_List;
1939 else
1940 Error_Msg
1941 (Data.Flags,
1942 "illegal response file format",
1943 Attribute.Value.Location, Project);
1944 end if;
1945 end;
1947 elsif Attribute.Name = Name_Response_File_Switches then
1948 Put (Into_List => Project.Config.Resp_File_Options,
1949 From_List => Attribute.Value.Values,
1950 In_Tree => Data.Tree);
1951 end if;
1952 end if;
1954 Attribute_Id := Attribute.Next;
1955 end loop;
1956 end Process_Linker;
1958 -- Start of processing for Process_Packages
1960 begin
1961 Packages := Project.Decl.Packages;
1962 while Packages /= No_Package loop
1963 Element := Shared.Packages.Table (Packages);
1965 case Element.Name is
1966 when Name_Binder =>
1968 -- Process attributes of package Binder
1970 Process_Binder (Element.Decl.Arrays);
1972 when Name_Builder =>
1974 -- Process attributes of package Builder
1976 Process_Builder (Element.Decl.Attributes);
1978 when Name_Clean =>
1980 -- Process attributes of package Clean
1982 Process_Clean (Element.Decl.Attributes);
1983 Process_Clean (Element.Decl.Arrays);
1985 when Name_Compiler =>
1987 -- Process attributes of package Compiler
1989 Process_Compiler (Element.Decl.Arrays);
1991 when Name_Linker =>
1993 -- Process attributes of package Linker
1995 Process_Linker (Element.Decl.Attributes);
1997 when Name_Naming =>
1999 -- Process attributes of package Naming
2001 Process_Naming (Element.Decl.Attributes);
2002 Process_Naming (Element.Decl.Arrays);
2004 when others =>
2005 null;
2006 end case;
2008 Packages := Element.Next;
2009 end loop;
2010 end Process_Packages;
2012 ---------------------------------------------
2013 -- Process_Project_Level_Simple_Attributes --
2014 ---------------------------------------------
2016 procedure Process_Project_Level_Simple_Attributes is
2017 Attribute_Id : Variable_Id;
2018 Attribute : Variable;
2019 List : String_List_Id;
2021 begin
2022 -- Process non associated array attribute at project level
2024 Attribute_Id := Project.Decl.Attributes;
2025 while Attribute_Id /= No_Variable loop
2026 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
2028 if not Attribute.Value.Default then
2029 if Attribute.Name = Name_Target then
2031 -- Attribute Target: the target specified
2033 Project.Config.Target := Attribute.Value.Value;
2035 elsif Attribute.Name = Name_Library_Builder then
2037 -- Attribute Library_Builder: the application to invoke
2038 -- to build libraries.
2040 Project.Config.Library_Builder :=
2041 Path_Name_Type (Attribute.Value.Value);
2043 elsif Attribute.Name = Name_Archive_Builder then
2045 -- Attribute Archive_Builder: the archive builder
2046 -- (usually "ar") and its minimum options (usually "cr").
2048 List := Attribute.Value.Values;
2050 if List = Nil_String then
2051 Error_Msg
2052 (Data.Flags,
2053 "archive builder cannot be null",
2054 Attribute.Value.Location, Project);
2055 end if;
2057 Put (Into_List => Project.Config.Archive_Builder,
2058 From_List => List,
2059 In_Tree => Data.Tree);
2061 elsif Attribute.Name = Name_Archive_Builder_Append_Option then
2063 -- Attribute Archive_Builder: the archive builder
2064 -- (usually "ar") and its minimum options (usually "cr").
2066 List := Attribute.Value.Values;
2068 if List /= Nil_String then
2069 Put
2070 (Into_List =>
2071 Project.Config.Archive_Builder_Append_Option,
2072 From_List => List,
2073 In_Tree => Data.Tree);
2074 end if;
2076 elsif Attribute.Name = Name_Archive_Indexer then
2078 -- Attribute Archive_Indexer: the optional archive
2079 -- indexer (usually "ranlib") with its minimum options
2080 -- (usually none).
2082 List := Attribute.Value.Values;
2084 if List = Nil_String then
2085 Error_Msg
2086 (Data.Flags,
2087 "archive indexer cannot be null",
2088 Attribute.Value.Location, Project);
2089 end if;
2091 Put (Into_List => Project.Config.Archive_Indexer,
2092 From_List => List,
2093 In_Tree => Data.Tree);
2095 elsif Attribute.Name = Name_Library_Partial_Linker then
2097 -- Attribute Library_Partial_Linker: the optional linker
2098 -- driver with its minimum options, to partially link
2099 -- archives.
2101 List := Attribute.Value.Values;
2103 if List = Nil_String then
2104 Error_Msg
2105 (Data.Flags,
2106 "partial linker cannot be null",
2107 Attribute.Value.Location, Project);
2108 end if;
2110 Put (Into_List => Project.Config.Lib_Partial_Linker,
2111 From_List => List,
2112 In_Tree => Data.Tree);
2114 elsif Attribute.Name = Name_Library_GCC then
2115 Project.Config.Shared_Lib_Driver :=
2116 File_Name_Type (Attribute.Value.Value);
2117 Error_Msg
2118 (Data.Flags,
2121 Attribute.Value.Location, Project);
2123 elsif Attribute.Name = Name_Archive_Suffix then
2124 Project.Config.Archive_Suffix :=
2125 File_Name_Type (Attribute.Value.Value);
2127 elsif Attribute.Name = Name_Linker_Executable_Option then
2129 -- Attribute Linker_Executable_Option: optional options
2132 List := Attribute.Value.Values;
2134 if List = Nil_String then
2135 Error_Msg
2136 (Data.Flags,
2138 Attribute.Value.Location, Project);
2139 end if;
2141 Put (Into_List => Project.Config.Linker_Executable_Option,
2142 From_List => List,
2143 In_Tree => Data.Tree);
2145 elsif Attribute.Name = Name_Linker_Lib_Dir_Option then
2147 -- Attribute Linker_Lib_Dir_Option: optional options
2148 -- to specify a library search directory. Defaults to
2151 Get_Name_String (Attribute.Value.Value);
2153 if Name_Len = 0 then
2154 Error_Msg
2155 (Data.Flags,
2157 Attribute.Value.Location, Project);
2158 end if;
2160 Project.Config.Linker_Lib_Dir_Option :=
2161 Attribute.Value.Value;
2163 elsif Attribute.Name = Name_Linker_Lib_Name_Option then
2165 -- Attribute Linker_Lib_Name_Option: optional options
2166 -- to specify the name of a library to be linked in.
2169 Get_Name_String (Attribute.Value.Value);
2171 if Name_Len = 0 then
2172 Error_Msg
2173 (Data.Flags,
2175 Attribute.Value.Location, Project);
2176 end if;
2178 Project.Config.Linker_Lib_Name_Option :=
2179 Attribute.Value.Value;
2181 elsif Attribute.Name = Name_Run_Path_Option then
2183 -- Attribute Run_Path_Option: optional options to
2184 -- specify a path for libraries.
2186 List := Attribute.Value.Values;
2188 if List /= Nil_String then
2189 Put (Into_List => Project.Config.Run_Path_Option,
2190 From_List => List,
2191 In_Tree => Data.Tree);
2192 end if;
2194 elsif Attribute.Name = Name_Run_Path_Origin then
2195 Get_Name_String (Attribute.Value.Value);
2197 if Name_Len = 0 then
2198 Error_Msg
2199 (Data.Flags,
2201 Attribute.Value.Location, Project);
2202 end if;
2204 Project.Config.Run_Path_Origin := Attribute.Value.Value;
2206 elsif Attribute.Name = Name_Library_Install_Name_Option then
2207 Project.Config.Library_Install_Name_Option :=
2208 Attribute.Value.Value;
2210 elsif Attribute.Name = Name_Separate_Run_Path_Options then
2211 declare
2212 pragma Unsuppress (All_Checks);
2213 begin
2214 Project.Config.Separate_Run_Path_Options :=
2215 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2216 exception
2217 when Constraint_Error =>
2218 Error_Msg
2219 (Data.Flags,
2221 Get_Name_String (Attribute.Value.Value) &
2223 Attribute.Value.Location, Project);
2224 end;
2226 elsif Attribute.Name = Name_Library_Support then
2227 declare
2228 pragma Unsuppress (All_Checks);
2229 begin
2230 Project.Config.Lib_Support :=
2231 Library_Support'Value (Get_Name_String
2232 (Attribute.Value.Value));
2233 exception
2234 when Constraint_Error =>
2235 Error_Msg
2236 (Data.Flags,
2238 Get_Name_String (Attribute.Value.Value) &
2240 Attribute.Value.Location, Project);
2241 end;
2243 elsif
2244 Attribute.Name = Name_Library_Encapsulated_Supported
2245 then
2246 declare
2247 pragma Unsuppress (All_Checks);
2248 begin
2249 Project.Config.Lib_Encapsulated_Supported :=
2250 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2251 exception
2252 when Constraint_Error =>
2253 Error_Msg
2254 (Data.Flags,
2256 & Get_Name_String (Attribute.Value.Value)
2258 Attribute.Value.Location, Project);
2259 end;
2261 elsif Attribute.Name = Name_Shared_Library_Prefix then
2262 Project.Config.Shared_Lib_Prefix :=
2263 File_Name_Type (Attribute.Value.Value);
2265 elsif Attribute.Name = Name_Shared_Library_Suffix then
2266 Project.Config.Shared_Lib_Suffix :=
2267 File_Name_Type (Attribute.Value.Value);
2269 elsif Attribute.Name = Name_Symbolic_Link_Supported then
2270 declare
2271 pragma Unsuppress (All_Checks);
2272 begin
2273 Project.Config.Symbolic_Link_Supported :=
2274 Boolean'Value (Get_Name_String
2275 (Attribute.Value.Value));
2276 exception
2277 when Constraint_Error =>
2278 Error_Msg
2279 (Data.Flags,
2281 & Get_Name_String (Attribute.Value.Value)
2283 Attribute.Value.Location, Project);
2284 end;
2286 elsif
2287 Attribute.Name = Name_Library_Major_Minor_Id_Supported
2288 then
2289 declare
2290 pragma Unsuppress (All_Checks);
2291 begin
2292 Project.Config.Lib_Maj_Min_Id_Supported :=
2293 Boolean'Value (Get_Name_String
2294 (Attribute.Value.Value));
2295 exception
2296 when Constraint_Error =>
2297 Error_Msg
2298 (Data.Flags,
2300 Get_Name_String (Attribute.Value.Value) &
2302 Attribute.Value.Location, Project);
2303 end;
2305 elsif Attribute.Name = Name_Library_Auto_Init_Supported then
2306 declare
2307 pragma Unsuppress (All_Checks);
2308 begin
2309 Project.Config.Auto_Init_Supported :=
2310 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2311 exception
2312 when Constraint_Error =>
2313 Error_Msg
2314 (Data.Flags,
2316 & Get_Name_String (Attribute.Value.Value)
2318 Attribute.Value.Location, Project);
2319 end;
2321 elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then
2322 List := Attribute.Value.Values;
2324 if List /= Nil_String then
2325 Put (Into_List => Project.Config.Shared_Lib_Min_Options,
2326 From_List => List,
2327 In_Tree => Data.Tree);
2328 end if;
2330 elsif Attribute.Name = Name_Library_Version_Switches then
2331 List := Attribute.Value.Values;
2333 if List /= Nil_String then
2334 Put (Into_List => Project.Config.Lib_Version_Options,
2335 From_List => List,
2336 In_Tree => Data.Tree);
2337 end if;
2338 end if;
2339 end if;
2341 Attribute_Id := Attribute.Next;
2342 end loop;
2343 end Process_Project_Level_Simple_Attributes;
2345 --------------------------------------------
2346 -- Process_Project_Level_Array_Attributes --
2347 --------------------------------------------
2349 procedure Process_Project_Level_Array_Attributes is
2350 Current_Array_Id : Array_Id;
2351 Current_Array : Array_Data;
2352 Element_Id : Array_Element_Id;
2353 Element : Array_Element;
2354 List : String_List_Id;
2356 begin
2357 -- Process the associative array attributes at project level
2359 Current_Array_Id := Project.Decl.Arrays;
2360 while Current_Array_Id /= No_Array loop
2361 Current_Array := Shared.Arrays.Table (Current_Array_Id);
2363 Element_Id := Current_Array.Value;
2364 while Element_Id /= No_Array_Element loop
2365 Element := Shared.Array_Elements.Table (Element_Id);
2367 -- Get the name of the language
2369 Lang_Index :=
2370 Get_Language_From_Name
2371 (Project, Get_Name_String (Element.Index));
2373 if Lang_Index /= No_Language_Index then
2374 case Current_Array.Name is
2375 when Name_Inherit_Source_Path =>
2376 List := Element.Value.Values;
2378 if List /= Nil_String then
2379 Put
2380 (Into_List =>
2381 Lang_Index.Config.Include_Compatible_Languages,
2382 From_List => List,
2383 In_Tree => Data.Tree,
2384 Lower_Case => True);
2385 end if;
2387 when Name_Toolchain_Description =>
2389 -- Attribute Toolchain_Description (<language>)
2391 Lang_Index.Config.Toolchain_Description :=
2392 Element.Value.Value;
2394 when Name_Toolchain_Version =>
2396 -- Attribute Toolchain_Version (<language>)
2398 Lang_Index.Config.Toolchain_Version :=
2399 Element.Value.Value;
2401 -- For Ada, set proper checksum computation mode,
2402 -- which has changed from version to version.
2404 if Lang_Index.Name = Name_Ada then
2405 declare
2406 Vers : constant String :=
2407 Get_Name_String (Element.Value.Value);
2408 pragma Assert (Vers'First = 1);
2410 begin
2411 -- Version 6.3 or earlier
2413 if Vers'Length >= 8
2415 and then Vers (7) = '.'
2416 and then
2417 (Vers (6) < '6'
2418 or else
2419 (Vers (6) = '6' and then Vers (8) < '4'))
2420 then
2421 Checksum_GNAT_6_3 := True;
2423 -- Version 5.03 or earlier
2425 if Vers (6) < '5'
2426 or else (Vers (6) = '5'
2427 and then Vers (Vers'Last) < '4')
2428 then
2429 Checksum_GNAT_5_03 := True;
2431 -- Version 5.02 or earlier (no checksums)
2433 if Vers (6) /= '5'
2434 or else Vers (Vers'Last) < '3'
2435 then
2436 Checksum_Accumulate_Token_Checksum :=
2437 False;
2438 end if;
2439 end if;
2440 end if;
2441 end;
2442 end if;
2444 when Name_Runtime_Library_Dir =>
2446 -- Attribute Runtime_Library_Dir (<language>)
2448 Lang_Index.Config.Runtime_Library_Dir :=
2449 Element.Value.Value;
2451 when Name_Runtime_Source_Dir =>
2453 -- Attribute Runtime_Source_Dir (<language>)
2455 Lang_Index.Config.Runtime_Source_Dir :=
2456 Element.Value.Value;
2458 when Name_Object_Generated =>
2459 declare
2460 pragma Unsuppress (All_Checks);
2461 Value : Boolean;
2463 begin
2464 Value :=
2465 Boolean'Value
2466 (Get_Name_String (Element.Value.Value));
2468 Lang_Index.Config.Object_Generated := Value;
2470 -- If no object is generated, no object may be
2471 -- linked.
2473 if not Value then
2474 Lang_Index.Config.Objects_Linked := False;
2475 end if;
2477 exception
2478 when Constraint_Error =>
2479 Error_Msg
2480 (Data.Flags,
2482 & Get_Name_String (Element.Value.Value)
2484 Element.Value.Location, Project);
2485 end;
2487 when Name_Objects_Linked =>
2488 declare
2489 pragma Unsuppress (All_Checks);
2490 Value : Boolean;
2492 begin
2493 Value :=
2494 Boolean'Value
2495 (Get_Name_String (Element.Value.Value));
2497 -- No change if Object_Generated is False, as this
2498 -- forces Objects_Linked to be False too.
2500 if Lang_Index.Config.Object_Generated then
2501 Lang_Index.Config.Objects_Linked := Value;
2502 end if;
2504 exception
2505 when Constraint_Error =>
2506 Error_Msg
2507 (Data.Flags,
2509 & Get_Name_String (Element.Value.Value)
2511 Element.Value.Location, Project);
2512 end;
2513 when others =>
2514 null;
2515 end case;
2516 end if;
2518 Element_Id := Element.Next;
2519 end loop;
2521 Current_Array_Id := Current_Array.Next;
2522 end loop;
2523 end Process_Project_Level_Array_Attributes;
2525 -- Start of processing for Check_Configuration
2527 begin
2528 Process_Project_Level_Simple_Attributes;
2529 Process_Project_Level_Array_Attributes;
2530 Process_Packages;
2532 -- For unit based languages, set Casing, Dot_Replacement and
2533 -- Separate_Suffix in Naming_Data.
2535 Lang_Index := Project.Languages;
2536 while Lang_Index /= No_Language_Index loop
2537 if Lang_Index.Config.Kind = Unit_Based then
2538 Lang_Index.Config.Naming_Data.Casing := Casing;
2539 Lang_Index.Config.Naming_Data.Dot_Replacement := Dot_Replacement;
2541 if Separate_Suffix /= No_File then
2542 Lang_Index.Config.Naming_Data.Separate_Suffix :=
2543 Separate_Suffix;
2544 end if;
2546 exit;
2547 end if;
2549 Lang_Index := Lang_Index.Next;
2550 end loop;
2552 -- Give empty names to various prefixes/suffixes, if they have not
2553 -- been specified in the configuration.
2555 if Project.Config.Archive_Suffix = No_File then
2556 Project.Config.Archive_Suffix := Empty_File;
2557 end if;
2559 if Project.Config.Shared_Lib_Prefix = No_File then
2560 Project.Config.Shared_Lib_Prefix := Empty_File;
2561 end if;
2563 if Project.Config.Shared_Lib_Suffix = No_File then
2564 Project.Config.Shared_Lib_Suffix := Empty_File;
2565 end if;
2567 Lang_Index := Project.Languages;
2568 while Lang_Index /= No_Language_Index loop
2570 -- For all languages, Compiler_Driver needs to be specified. This is
2571 -- only needed if we do intend to compile (not in GPS for instance).
2573 if Data.Flags.Compiler_Driver_Mandatory
2574 and then Lang_Index.Config.Compiler_Driver = No_File
2575 and then not Project.Externally_Built
2576 then
2577 Error_Msg_Name_1 := Lang_Index.Display_Name;
2578 Error_Msg
2579 (Data.Flags,
2582 No_Location, Project);
2584 if Lang_Index = Project.Languages then
2585 Project.Languages := Lang_Index.Next;
2586 else
2587 Prev_Index.Next := Lang_Index.Next;
2588 end if;
2590 elsif Lang_Index.Config.Kind = Unit_Based then
2591 Prev_Index := Lang_Index;
2593 -- For unit based languages, Dot_Replacement, Spec_Suffix and
2594 -- Body_Suffix need to be specified.
2596 if Lang_Index.Config.Naming_Data.Dot_Replacement = No_File then
2597 Error_Msg
2598 (Data.Flags,
2600 Get_Name_String (Lang_Index.Name),
2601 No_Location, Project);
2602 end if;
2604 if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then
2605 Error_Msg
2606 (Data.Flags,
2608 Get_Name_String (Lang_Index.Name),
2609 No_Location, Project);
2610 end if;
2612 if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then
2613 Error_Msg
2614 (Data.Flags,
2616 Get_Name_String (Lang_Index.Name),
2617 No_Location, Project);
2618 end if;
2620 else
2621 Prev_Index := Lang_Index;
2623 -- For file based languages, either Spec_Suffix or Body_Suffix
2624 -- need to be specified.
2626 if Data.Flags.Require_Sources_Other_Lang
2627 and then Lang_Index.Config.Naming_Data.Spec_Suffix = No_File
2628 and then Lang_Index.Config.Naming_Data.Body_Suffix = No_File
2629 then
2630 Error_Msg_Name_1 := Lang_Index.Display_Name;
2631 Error_Msg
2632 (Data.Flags,
2634 No_Location, Project);
2635 end if;
2636 end if;
2638 Lang_Index := Lang_Index.Next;
2639 end loop;
2640 end Check_Configuration;
2642 -------------------------------
2643 -- Check_If_Externally_Built --
2644 -------------------------------
2646 procedure Check_If_Externally_Built
2647 (Project : Project_Id;
2648 Data : in out Tree_Processing_Data)
2649 is
2650 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
2651 Externally_Built : constant Variable_Value :=
2652 Util.Value_Of
2653 (Name_Externally_Built,
2654 Project.Decl.Attributes, Shared);
2656 begin
2657 if not Externally_Built.Default then
2658 Get_Name_String (Externally_Built.Value);
2659 To_Lower (Name_Buffer (1 .. Name_Len));
2662 Project.Externally_Built := True;
2665 Error_Msg (Data.Flags,
2667 Externally_Built.Location, Project);
2668 end if;
2669 end if;
2671 -- A virtual project extending an externally built project is itself
2672 -- externally built.
2674 if Project.Virtual and then Project.Extends /= No_Project then
2675 Project.Externally_Built := Project.Extends.Externally_Built;
2676 end if;
2678 if Project.Externally_Built then
2680 else
2682 end if;
2683 end Check_If_Externally_Built;
2685 ----------------------
2686 -- Check_Interfaces --
2687 ----------------------
2689 procedure Check_Interfaces
2690 (Project : Project_Id;
2691 Data : in out Tree_Processing_Data)
2692 is
2693 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
2695 Interfaces : constant Prj.Variable_Value :=
2696 Prj.Util.Value_Of
2697 (Snames.Name_Interfaces,
2698 Project.Decl.Attributes,
2699 Shared);
2701 Library_Interface : constant Prj.Variable_Value :=
2702 Prj.Util.Value_Of
2703 (Snames.Name_Library_Interface,
2704 Project.Decl.Attributes,
2705 Shared);
2707 List : String_List_Id;
2708 Element : String_Element;
2709 Name : File_Name_Type;
2710 Iter : Source_Iterator;
2711 Source : Source_Id;
2712 Project_2 : Project_Id;
2713 Other : Source_Id;
2714 Unit_Found : Boolean;
2716 Interface_ALIs : String_List_Id := Nil_String;
2717 Other_Interfaces : String_List_Id := Nil_String;
2719 begin
2720 if not Interfaces.Default then
2722 -- Set In_Interfaces to False for all sources. It will be set to True
2723 -- later for the sources in the Interfaces list.
2725 Project_2 := Project;
2726 while Project_2 /= No_Project loop
2727 Iter := For_Each_Source (Data.Tree, Project_2);
2728 loop
2729 Source := Prj.Element (Iter);
2730 exit when Source = No_Source;
2731 Source.In_Interfaces := False;
2732 Next (Iter);
2733 end loop;
2735 Project_2 := Project_2.Extends;
2736 end loop;
2738 List := Interfaces.Values;
2739 while List /= Nil_String loop
2740 Element := Shared.String_Elements.Table (List);
2741 Name := Canonical_Case_File_Name (Element.Value);
2743 Project_2 := Project;
2744 Big_Loop : while Project_2 /= No_Project loop
2745 if Project.Qualifier = Aggregate_Library then
2747 -- For an aggregate library we want to consider sources of
2748 -- all aggregated projects.
2750 Iter := For_Each_Source (Data.Tree);
2752 else
2753 Iter := For_Each_Source (Data.Tree, Project_2);
2754 end if;
2756 loop
2757 Source := Prj.Element (Iter);
2758 exit when Source = No_Source;
2760 if Source.File = Name then
2761 if not Source.Locally_Removed then
2762 Source.In_Interfaces := True;
2763 Source.Declared_In_Interfaces := True;
2765 Other := Other_Part (Source);
2767 if Other /= No_Source then
2768 Other.In_Interfaces := True;
2769 Other.Declared_In_Interfaces := True;
2770 end if;
2772 -- Unit based case
2774 if Source.Language.Config.Kind = Unit_Based then
2775 if Source.Kind = Spec
2776 and then Other_Part (Source) /= No_Source
2777 then
2778 Source := Other_Part (Source);
2779 end if;
2781 String_Element_Table.Increment_Last
2782 (Shared.String_Elements);
2784 Shared.String_Elements.Table
2785 (String_Element_Table.Last
2786 (Shared.String_Elements)) :=
2787 (Value => Name_Id (Source.Dep_Name),
2788 Index => 0,
2789 Display_Value => Name_Id (Source.Dep_Name),
2790 Location => No_Location,
2791 Flag => False,
2792 Next => Interface_ALIs);
2794 Interface_ALIs :=
2795 String_Element_Table.Last
2796 (Shared.String_Elements);
2798 -- File based case
2800 else
2801 String_Element_Table.Increment_Last
2802 (Shared.String_Elements);
2804 Shared.String_Elements.Table
2805 (String_Element_Table.Last
2806 (Shared.String_Elements)) :=
2807 (Value => Name_Id (Source.File),
2808 Index => 0,
2809 Display_Value => Name_Id (Source.Display_File),
2810 Location => No_Location,
2811 Flag => False,
2812 Next => Other_Interfaces);
2814 Other_Interfaces :=
2815 String_Element_Table.Last
2816 (Shared.String_Elements);
2817 end if;
2819 Debug_Output
2821 end if;
2823 exit Big_Loop;
2824 end if;
2826 Next (Iter);
2827 end loop;
2829 Project_2 := Project_2.Extends;
2830 end loop Big_Loop;
2832 if Source = No_Source then
2833 Error_Msg_File_1 := File_Name_Type (Element.Value);
2834 Error_Msg_Name_1 := Project.Name;
2836 Error_Msg
2837 (Data.Flags,
2840 Element.Location, Project);
2841 end if;
2843 List := Element.Next;
2844 end loop;
2846 Project.Interfaces_Defined := True;
2847 Project.Lib_Interface_ALIs := Interface_ALIs;
2848 Project.Other_Interfaces := Other_Interfaces;
2850 elsif Project.Library and then not Library_Interface.Default then
2852 -- Set In_Interfaces to False for all sources. It will be set to True
2853 -- later for the sources in the Library_Interface list.
2855 Project_2 := Project;
2856 while Project_2 /= No_Project loop
2857 Iter := For_Each_Source (Data.Tree, Project_2);
2858 loop
2859 Source := Prj.Element (Iter);
2860 exit when Source = No_Source;
2861 Source.In_Interfaces := False;
2862 Next (Iter);
2863 end loop;
2865 Project_2 := Project_2.Extends;
2866 end loop;
2868 List := Library_Interface.Values;
2869 while List /= Nil_String loop
2870 Element := Shared.String_Elements.Table (List);
2871 Get_Name_String (Element.Value);
2872 To_Lower (Name_Buffer (1 .. Name_Len));
2873 Name := Name_Find;
2874 Unit_Found := False;
2876 Project_2 := Project;
2877 Big_Loop_2 : while Project_2 /= No_Project loop
2878 if Project.Qualifier = Aggregate_Library then
2880 -- For an aggregate library we want to consider sources of
2881 -- all aggregated projects.
2883 Iter := For_Each_Source (Data.Tree);
2885 else
2886 Iter := For_Each_Source (Data.Tree, Project_2);
2887 end if;
2889 loop
2890 Source := Prj.Element (Iter);
2891 exit when Source = No_Source;
2893 if Source.Unit /= No_Unit_Index
2894 and then Source.Unit.Name = Name_Id (Name)
2895 then
2896 if not Source.Locally_Removed then
2897 Source.In_Interfaces := True;
2898 Source.Declared_In_Interfaces := True;
2899 Project.Interfaces_Defined := True;
2901 Other := Other_Part (Source);
2903 if Other /= No_Source then
2904 Other.In_Interfaces := True;
2905 Other.Declared_In_Interfaces := True;
2906 end if;
2908 Debug_Output
2911 if Source.Kind = Spec
2912 and then Other_Part (Source) /= No_Source
2913 then
2914 Source := Other_Part (Source);
2915 end if;
2917 String_Element_Table.Increment_Last
2918 (Shared.String_Elements);
2920 Shared.String_Elements.Table
2921 (String_Element_Table.Last
2922 (Shared.String_Elements)) :=
2923 (Value => Name_Id (Source.Dep_Name),
2924 Index => 0,
2925 Display_Value => Name_Id (Source.Dep_Name),
2926 Location => No_Location,
2927 Flag => False,
2928 Next => Interface_ALIs);
2930 Interface_ALIs :=
2931 String_Element_Table.Last (Shared.String_Elements);
2932 end if;
2934 Unit_Found := True;
2935 exit Big_Loop_2;
2936 end if;
2938 Next (Iter);
2939 end loop;
2941 Project_2 := Project_2.Extends;
2942 end loop Big_Loop_2;
2944 if not Unit_Found then
2945 Error_Msg_Name_1 := Name_Id (Name);
2947 Error_Msg
2948 (Data.Flags,
2950 Element.Location, Project);
2951 end if;
2953 List := Element.Next;
2954 end loop;
2956 Project.Lib_Interface_ALIs := Interface_ALIs;
2958 elsif Project.Extends /= No_Project
2959 and then Project.Extends.Interfaces_Defined
2960 then
2961 Project.Interfaces_Defined := True;
2963 Iter := For_Each_Source (Data.Tree, Project);
2964 loop
2965 Source := Prj.Element (Iter);
2966 exit when Source = No_Source;
2968 if not Source.Declared_In_Interfaces then
2969 Source.In_Interfaces := False;
2970 end if;
2972 Next (Iter);
2973 end loop;
2975 Project.Lib_Interface_ALIs := Project.Extends.Lib_Interface_ALIs;
2976 end if;
2977 end Check_Interfaces;
2979 ------------------------------
2980 -- Check_Library_Attributes --
2981 ------------------------------
2983 -- This procedure is awfully long (over 700 lines) should be broken up???
2985 procedure Check_Library_Attributes
2986 (Project : Project_Id;
2987 Data : in out Tree_Processing_Data)
2988 is
2989 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
2991 Attributes : constant Prj.Variable_Id := Project.Decl.Attributes;
2993 Lib_Dir : constant Prj.Variable_Value :=
2994 Prj.Util.Value_Of
2995 (Snames.Name_Library_Dir, Attributes, Shared);
2997 Lib_Name : constant Prj.Variable_Value :=
2998 Prj.Util.Value_Of
2999 (Snames.Name_Library_Name, Attributes, Shared);
3001 Lib_Standalone : constant Prj.Variable_Value :=
3002 Prj.Util.Value_Of
3003 (Snames.Name_Library_Standalone,
3004 Attributes, Shared);
3006 Lib_Version : constant Prj.Variable_Value :=
3007 Prj.Util.Value_Of
3008 (Snames.Name_Library_Version, Attributes, Shared);
3010 Lib_ALI_Dir : constant Prj.Variable_Value :=
3011 Prj.Util.Value_Of
3012 (Snames.Name_Library_Ali_Dir, Attributes, Shared);
3014 Lib_GCC : constant Prj.Variable_Value :=
3015 Prj.Util.Value_Of
3016 (Snames.Name_Library_GCC, Attributes, Shared);
3018 The_Lib_Kind : constant Prj.Variable_Value :=
3019 Prj.Util.Value_Of
3020 (Snames.Name_Library_Kind, Attributes, Shared);
3022 Imported_Project_List : Project_List;
3023 Continuation : String_Access := No_Continuation_String'Access;
3024 Support_For_Libraries : Library_Support;
3026 Library_Directory_Present : Boolean;
3028 procedure Check_Library (Proj : Project_Id; Extends : Boolean);
3029 -- Check if an imported or extended project if also a library project
3031 procedure Check_Aggregate_Library_Dirs;
3032 -- Check that the library directory and the library ALI directory of an
3033 -- aggregate library project are not the same as the object directory or
3034 -- the library directory of any of its aggregated projects.
3036 ----------------------------------
3037 -- Check_Aggregate_Library_Dirs --
3038 ----------------------------------
3040 procedure Check_Aggregate_Library_Dirs is
3041 procedure Process_Aggregate (Proj : Project_Id);
3042 -- Recursive procedure to check the aggregated projects, as they may
3043 -- also be aggregated library projects.
3045 -----------------------
3046 -- Process_Aggregate --
3047 -----------------------
3049 procedure Process_Aggregate (Proj : Project_Id) is
3050 Agg : Aggregated_Project_List;
3052 begin
3053 Agg := Proj.Aggregated_Projects;
3054 while Agg /= null loop
3055 Error_Msg_Name_1 := Agg.Project.Name;
3057 if Agg.Project.Qualifier /= Aggregate_Library
3058 and then Project.Library_ALI_Dir.Name =
3059 Agg.Project.Object_Directory.Name
3060 then
3061 Error_Msg
3062 (Data.Flags,
3065 The_Lib_Kind.Location, Project);
3067 elsif Project.Library_ALI_Dir.Name =
3068 Agg.Project.Library_Dir.Name
3069 then
3070 Error_Msg
3071 (Data.Flags,
3074 The_Lib_Kind.Location, Project);
3076 elsif Agg.Project.Qualifier /= Aggregate_Library
3077 and then Project.Library_Dir.Name =
3078 Agg.Project.Object_Directory.Name
3079 then
3080 Error_Msg
3081 (Data.Flags,
3084 The_Lib_Kind.Location, Project);
3086 elsif Project.Library_Dir.Name =
3087 Agg.Project.Library_Dir.Name
3088 then
3089 Error_Msg
3090 (Data.Flags,
3093 The_Lib_Kind.Location, Project);
3094 end if;
3096 if Agg.Project.Qualifier = Aggregate_Library then
3097 Process_Aggregate (Agg.Project);
3098 end if;
3100 Agg := Agg.Next;
3101 end loop;
3102 end Process_Aggregate;
3104 -- Start of processing for Check_Aggregate_Library_Dirs
3106 begin
3107 if Project.Qualifier = Aggregate_Library then
3108 Process_Aggregate (Project);
3109 end if;
3110 end Check_Aggregate_Library_Dirs;
3112 -------------------
3113 -- Check_Library --
3114 -------------------
3116 procedure Check_Library (Proj : Project_Id; Extends : Boolean) is
3117 Src_Id : Source_Id;
3118 Iter : Source_Iterator;
3120 begin
3121 if Proj /= No_Project then
3122 if not Proj.Library then
3124 -- The only not library projects that are OK are those that
3125 -- have no sources. However, header files from non-Ada
3126 -- languages are OK, as there is nothing to compile.
3128 Iter := For_Each_Source (Data.Tree, Proj);
3129 loop
3130 Src_Id := Prj.Element (Iter);
3131 exit when Src_Id = No_Source
3132 or else Src_Id.Language.Config.Kind /= File_Based
3133 or else Src_Id.Kind /= Spec;
3134 Next (Iter);
3135 end loop;
3137 if Src_Id /= No_Source then
3138 Error_Msg_Name_1 := Project.Name;
3139 Error_Msg_Name_2 := Proj.Name;
3141 if Extends then
3142 if Project.Library_Kind /= Static then
3143 Error_Msg
3144 (Data.Flags,
3145 Continuation.all &
3148 Project.Location, Project);
3149 Continuation := Continuation_String'Access;
3150 end if;
3152 elsif not Unchecked_Shared_Lib_Imports
3153 and then Project.Library_Kind /= Static
3154 then
3155 Error_Msg
3156 (Data.Flags,
3157 Continuation.all &
3160 Project.Location, Project);
3161 Continuation := Continuation_String'Access;
3162 end if;
3163 end if;
3165 elsif Project.Library_Kind /= Static
3166 and then not Lib_Standalone.Default
3168 and then Proj.Library_Kind /= Static
3169 then
3170 -- An encapsulated library must depend only on static libraries
3172 Error_Msg_Name_1 := Project.Name;
3173 Error_Msg_Name_2 := Proj.Name;
3175 Error_Msg
3176 (Data.Flags,
3177 Continuation.all &
3180 Project.Location, Project);
3181 Continuation := Continuation_String'Access;
3183 elsif Project.Library_Kind /= Static
3184 and then Proj.Library_Kind = Static
3185 and then
3186 (Lib_Standalone.Default
3187 or else
3189 then
3190 Error_Msg_Name_1 := Project.Name;
3191 Error_Msg_Name_2 := Proj.Name;
3193 if Extends then
3194 Error_Msg
3195 (Data.Flags,
3196 Continuation.all &
3199 Project.Location, Project);
3200 Continuation := Continuation_String'Access;
3202 elsif not Unchecked_Shared_Lib_Imports then
3203 Error_Msg
3204 (Data.Flags,
3205 Continuation.all &
3208 Project.Location, Project);
3209 Continuation := Continuation_String'Access;
3210 end if;
3212 end if;
3213 end if;
3214 end Check_Library;
3216 Dir_Exists : Boolean;
3218 -- Start of processing for Check_Library_Attributes
3220 begin
3221 Library_Directory_Present := Lib_Dir.Value /= Empty_String;
3223 -- Special case of extending project
3225 if Project.Extends /= No_Project then
3227 -- If the project extended is a library project, we inherit the
3228 -- library name, if it is not redefined; we check that the library
3229 -- directory is specified.
3231 if Project.Extends.Library then
3232 if Project.Qualifier = Standard then
3233 Error_Msg
3234 (Data.Flags,
3236 Project.Location, Project);
3238 else
3239 if Lib_Name.Default then
3240 Project.Library_Name := Project.Extends.Library_Name;
3241 end if;
3243 if Lib_Dir.Default then
3244 if not Project.Virtual then
3245 Error_Msg
3246 (Data.Flags,
3249 Project.Location, Project);
3251 else
3252 -- For a virtual project extending a library project,
3253 -- inherit library directory and library kind.
3255 Project.Library_Dir := Project.Extends.Library_Dir;
3256 Library_Directory_Present := True;
3257 Project.Library_Kind := Project.Extends.Library_Kind;
3258 end if;
3259 end if;
3260 end if;
3261 end if;
3262 end if;
3264 pragma Assert (Lib_Name.Kind = Single);
3266 if Lib_Name.Value = Empty_String then
3267 if Current_Verbosity = High
3268 and then Project.Library_Name = No_Name
3269 then
3270 Debug_Indent;
3272 end if;
3274 else
3275 -- There is no restriction on the syntax of library names
3277 Project.Library_Name := Lib_Name.Value;
3278 end if;
3280 if Project.Library_Name /= No_Name then
3281 if Current_Verbosity = High then
3282 Write_Attr
3284 end if;
3286 pragma Assert (Lib_Dir.Kind = Single);
3288 if not Library_Directory_Present then
3291 else
3292 -- Find path name (unless inherited), check that it is a directory
3294 if Project.Library_Dir = No_Path_Information then
3295 Locate_Directory
3296 (Project,
3297 File_Name_Type (Lib_Dir.Value),
3298 Path => Project.Library_Dir,
3299 Dir_Exists => Dir_Exists,
3300 Data => Data,
3302 Must_Exist => False,
3303 Location => Lib_Dir.Location,
3304 Externally_Built => Project.Externally_Built);
3306 else
3307 Dir_Exists :=
3308 Is_Directory
3309 (Get_Name_String (Project.Library_Dir.Display_Name));
3310 end if;
3312 if not Dir_Exists then
3313 if Directories_Must_Exist_In_Projects then
3315 -- Get the absolute name of the library directory that does
3316 -- not exist, to report an error.
3318 Err_Vars.Error_Msg_File_1 :=
3319 File_Name_Type (Project.Library_Dir.Display_Name);
3320 Error_Msg
3321 (Data.Flags,
3323 Lib_Dir.Location, Project);
3324 end if;
3326 -- Checks for object/source directories
3328 elsif not Project.Externally_Built
3330 -- An aggregate library does not have sources or objects, so
3331 -- these tests are not required in this case.
3333 and then Project.Qualifier /= Aggregate_Library
3334 then
3335 -- Library directory cannot be the same as Object directory
3337 if Project.Library_Dir.Name = Project.Object_Directory.Name then
3338 Error_Msg
3339 (Data.Flags,
3342 Lib_Dir.Location, Project);
3343 Project.Library_Dir := No_Path_Information;
3345 else
3346 declare
3347 OK : Boolean := True;
3348 Dirs_Id : String_List_Id;
3349 Dir_Elem : String_Element;
3350 Pid : Project_List;
3352 begin
3353 -- The library directory cannot be the same as a source
3354 -- directory of the current project.
3356 Dirs_Id := Project.Source_Dirs;
3357 while Dirs_Id /= Nil_String loop
3358 Dir_Elem := Shared.String_Elements.Table (Dirs_Id);
3359 Dirs_Id := Dir_Elem.Next;
3361 if Project.Library_Dir.Name =
3362 Path_Name_Type (Dir_Elem.Value)
3363 then
3364 Err_Vars.Error_Msg_File_1 :=
3365 File_Name_Type (Dir_Elem.Value);
3366 Error_Msg
3367 (Data.Flags,
3370 Lib_Dir.Location, Project);
3371 OK := False;
3372 exit;
3373 end if;
3374 end loop;
3376 if OK then
3378 -- The library directory cannot be the same as a
3379 -- source directory of another project either.
3381 Pid := Data.Tree.Projects;
3382 Project_Loop : loop
3383 exit Project_Loop when Pid = null;
3385 if Pid.Project /= Project then
3386 Dirs_Id := Pid.Project.Source_Dirs;
3388 Dir_Loop : while Dirs_Id /= Nil_String loop
3389 Dir_Elem :=
3390 Shared.String_Elements.Table (Dirs_Id);
3391 Dirs_Id := Dir_Elem.Next;
3393 if Project.Library_Dir.Name =
3394 Path_Name_Type (Dir_Elem.Value)
3395 then
3396 Err_Vars.Error_Msg_File_1 :=
3397 File_Name_Type (Dir_Elem.Value);
3398 Err_Vars.Error_Msg_Name_1 :=
3399 Pid.Project.Name;
3401 Error_Msg
3402 (Data.Flags,
3405 Lib_Dir.Location, Project);
3406 OK := False;
3407 exit Project_Loop;
3408 end if;
3409 end loop Dir_Loop;
3410 end if;
3412 Pid := Pid.Next;
3413 end loop Project_Loop;
3414 end if;
3416 if not OK then
3417 Project.Library_Dir := No_Path_Information;
3419 elsif Current_Verbosity = High then
3421 -- Display the Library directory in high verbosity
3423 Write_Attr
3425 Get_Name_String (Project.Library_Dir.Display_Name));
3426 end if;
3427 end;
3428 end if;
3429 end if;
3430 end if;
3432 end if;
3434 Project.Library :=
3435 Project.Library_Dir /= No_Path_Information
3436 and then Project.Library_Name /= No_Name;
3438 if Project.Extends = No_Project then
3439 case Project.Qualifier is
3440 when Standard =>
3441 if Project.Library then
3442 Error_Msg
3443 (Data.Flags,
3445 Lib_Name.Location, Project);
3446 end if;
3448 when Library | Aggregate_Library =>
3449 if not Project.Library then
3450 if Project.Library_Name = No_Name then
3451 Error_Msg
3452 (Data.Flags,
3454 Project.Location, Project);
3456 if not Library_Directory_Present then
3457 Error_Msg
3458 (Data.Flags,
3460 Project.Location, Project);
3461 end if;
3463 elsif Project.Library_Dir = No_Path_Information then
3464 Error_Msg
3465 (Data.Flags,
3467 Project.Location, Project);
3468 end if;
3469 end if;
3471 when others =>
3472 null;
3473 end case;
3474 end if;
3476 if Project.Library then
3477 Support_For_Libraries := Project.Config.Lib_Support;
3479 if not Project.Externally_Built
3480 and then Support_For_Libraries = Prj.None
3481 then
3482 Error_Msg
3483 (Data.Flags,
3485 Lib_Name.Location, Project);
3486 Project.Library := False;
3488 else
3489 if Lib_ALI_Dir.Value = Empty_String then
3491 Project.Library_ALI_Dir := Project.Library_Dir;
3493 else
3494 -- Find path name, check that it is a directory
3496 Locate_Directory
3497 (Project,
3498 File_Name_Type (Lib_ALI_Dir.Value),
3499 Path => Project.Library_ALI_Dir,
3501 Dir_Exists => Dir_Exists,
3502 Data => Data,
3503 Must_Exist => False,
3504 Location => Lib_ALI_Dir.Location,
3505 Externally_Built => Project.Externally_Built);
3507 if not Dir_Exists then
3509 -- Get the absolute name of the library ALI directory that
3510 -- does not exist, to report an error.
3512 Err_Vars.Error_Msg_File_1 :=
3513 File_Name_Type (Project.Library_ALI_Dir.Display_Name);
3514 Error_Msg
3515 (Data.Flags,
3517 Lib_ALI_Dir.Location, Project);
3518 end if;
3520 if not Project.Externally_Built
3521 and then Project.Library_ALI_Dir /= Project.Library_Dir
3522 then
3523 -- The library ALI directory cannot be the same as the
3524 -- Object directory.
3526 if Project.Library_ALI_Dir = Project.Object_Directory then
3527 Error_Msg
3528 (Data.Flags,
3531 Lib_ALI_Dir.Location, Project);
3532 Project.Library_ALI_Dir := No_Path_Information;
3534 else
3535 declare
3536 OK : Boolean := True;
3537 Dirs_Id : String_List_Id;
3538 Dir_Elem : String_Element;
3539 Pid : Project_List;
3541 begin
3542 -- The library ALI directory cannot be the same as
3543 -- a source directory of the current project.
3545 Dirs_Id := Project.Source_Dirs;
3546 while Dirs_Id /= Nil_String loop
3547 Dir_Elem := Shared.String_Elements.Table (Dirs_Id);
3548 Dirs_Id := Dir_Elem.Next;
3550 if Project.Library_ALI_Dir.Name =
3551 Path_Name_Type (Dir_Elem.Value)
3552 then
3553 Err_Vars.Error_Msg_File_1 :=
3554 File_Name_Type (Dir_Elem.Value);
3555 Error_Msg
3556 (Data.Flags,
3559 Lib_ALI_Dir.Location, Project);
3560 OK := False;
3561 exit;
3562 end if;
3563 end loop;
3565 if OK then
3567 -- The library ALI directory cannot be the same as
3568 -- a source directory of another project either.
3570 Pid := Data.Tree.Projects;
3571 ALI_Project_Loop : loop
3572 exit ALI_Project_Loop when Pid = null;
3574 if Pid.Project /= Project then
3575 Dirs_Id := Pid.Project.Source_Dirs;
3577 ALI_Dir_Loop :
3578 while Dirs_Id /= Nil_String loop
3579 Dir_Elem :=
3580 Shared.String_Elements.Table (Dirs_Id);
3581 Dirs_Id := Dir_Elem.Next;
3583 if Project.Library_ALI_Dir.Name =
3584 Path_Name_Type (Dir_Elem.Value)
3585 then
3586 Err_Vars.Error_Msg_File_1 :=
3587 File_Name_Type (Dir_Elem.Value);
3588 Err_Vars.Error_Msg_Name_1 :=
3589 Pid.Project.Name;
3591 Error_Msg
3592 (Data.Flags,
3596 Lib_ALI_Dir.Location, Project);
3597 OK := False;
3598 exit ALI_Project_Loop;
3599 end if;
3600 end loop ALI_Dir_Loop;
3601 end if;
3602 Pid := Pid.Next;
3603 end loop ALI_Project_Loop;
3604 end if;
3606 if not OK then
3607 Project.Library_ALI_Dir := No_Path_Information;
3609 elsif Current_Verbosity = High then
3611 -- Display Library ALI directory in high verbosity
3613 Write_Attr
3615 Get_Name_String
3616 (Project.Library_ALI_Dir.Display_Name));
3617 end if;
3618 end;
3619 end if;
3620 end if;
3621 end if;
3623 pragma Assert (Lib_Version.Kind = Single);
3625 if Lib_Version.Value = Empty_String then
3628 else
3629 Project.Lib_Internal_Name := Lib_Version.Value;
3630 end if;
3632 pragma Assert (The_Lib_Kind.Kind = Single);
3634 if The_Lib_Kind.Value = Empty_String then
3637 else
3638 Get_Name_String (The_Lib_Kind.Value);
3640 declare
3641 Kind_Name : constant String :=
3642 To_Lower (Name_Buffer (1 .. Name_Len));
3644 OK : Boolean := True;
3646 begin
3648 Project.Library_Kind := Static;
3651 Project.Library_Kind := Dynamic;
3654 Project.Library_Kind := Relocatable;
3656 else
3657 Error_Msg
3658 (Data.Flags,
3660 The_Lib_Kind.Location, Project);
3661 OK := False;
3662 end if;
3664 if Current_Verbosity = High and then OK then
3666 end if;
3668 if Project.Library_Kind /= Static then
3669 if not Project.Externally_Built
3670 and then Support_For_Libraries = Prj.Static_Only
3671 then
3672 Error_Msg
3673 (Data.Flags,
3676 The_Lib_Kind.Location, Project);
3677 Project.Library := False;
3679 else
3680 -- Check if (obsolescent) attribute Library_GCC or
3681 -- Linker'Driver is declared.
3683 if Lib_GCC.Value /= Empty_String then
3684 Error_Msg
3685 (Data.Flags,
3688 Lib_GCC.Location, Project);
3689 Project.Config.Shared_Lib_Driver :=
3690 File_Name_Type (Lib_GCC.Value);
3692 else
3693 declare
3694 Linker : constant Package_Id :=
3695 Value_Of
3696 (Name_Linker,
3697 Project.Decl.Packages,
3698 Shared);
3699 Driver : constant Variable_Value :=
3700 Value_Of
3701 (Name => No_Name,
3702 Attribute_Or_Array_Name =>
3703 Name_Driver,
3704 In_Package => Linker,
3705 Shared => Shared);
3707 begin
3708 if Driver /= Nil_Variable_Value
3709 and then Driver.Value /= Empty_String
3710 then
3711 Project.Config.Shared_Lib_Driver :=
3712 File_Name_Type (Driver.Value);
3713 end if;
3714 end;
3715 end if;
3716 end if;
3717 end if;
3718 end;
3719 end if;
3721 if Project.Library
3722 and then Project.Qualifier /= Aggregate_Library
3723 then
3724 Debug_Output ("this is a library project file");
3726 Check_Library (Project.Extends, Extends => True);
3728 Imported_Project_List := Project.Imported_Projects;
3729 while Imported_Project_List /= null loop
3730 Check_Library
3731 (Imported_Project_List.Project,
3732 Extends => False);
3733 Imported_Project_List := Imported_Project_List.Next;
3734 end loop;
3735 end if;
3736 end if;
3737 end if;
3739 -- Check if Linker'Switches or Linker'Default_Switches are declared.
3740 -- Warn if they are declared, as it is a common error to think that
3741 -- library are "linked" with Linker switches.
3743 if Project.Library then
3744 declare
3745 Linker_Package_Id : constant Package_Id :=
3746 Util.Value_Of
3747 (Name_Linker,
3748 Project.Decl.Packages, Shared);
3749 Linker_Package : Package_Element;
3750 Switches : Array_Element_Id := No_Array_Element;
3752 begin
3753 if Linker_Package_Id /= No_Package then
3754 Linker_Package := Shared.Packages.Table (Linker_Package_Id);
3756 Switches :=
3757 Value_Of
3758 (Name => Name_Switches,
3759 In_Arrays => Linker_Package.Decl.Arrays,
3760 Shared => Shared);
3762 if Switches = No_Array_Element then
3763 Switches :=
3764 Value_Of
3765 (Name => Name_Default_Switches,
3766 In_Arrays => Linker_Package.Decl.Arrays,
3767 Shared => Shared);
3768 end if;
3770 if Switches /= No_Array_Element then
3771 Error_Msg
3772 (Data.Flags,
3774 "projects",
3775 No_Location, Project);
3776 end if;
3777 end if;
3778 end;
3779 end if;
3781 if Project.Extends /= No_Project and then Project.Extends.Library then
3783 -- Remove the library name from Lib_Data_Table
3785 for J in 1 .. Lib_Data_Table.Last loop
3786 if Lib_Data_Table.Table (J).Proj = Project.Extends then
3787 Lib_Data_Table.Table (J) :=
3788 Lib_Data_Table.Table (Lib_Data_Table.Last);
3789 Lib_Data_Table.Set_Last (Lib_Data_Table.Last - 1);
3790 exit;
3791 end if;
3792 end loop;
3793 end if;
3795 if Project.Library and then not Lib_Name.Default then
3797 -- Check if the same library name is used in an other library project
3799 for J in 1 .. Lib_Data_Table.Last loop
3800 if Lib_Data_Table.Table (J).Name = Project.Library_Name
3801 and then Lib_Data_Table.Table (J).Tree = Data.Tree
3802 then
3803 Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name;
3804 Error_Msg
3805 (Data.Flags,
3806 "Library name cannot be the same as in project %%",
3807 Lib_Name.Location, Project);
3808 Project.Library := False;
3809 exit;
3810 end if;
3811 end loop;
3812 end if;
3814 if not Lib_Standalone.Default
3815 and then Project.Library_Kind = Static
3816 then
3817 -- An standalone library must be a shared library
3819 Error_Msg_Name_1 := Project.Name;
3821 Error_Msg
3822 (Data.Flags,
3823 Continuation.all &
3824 "standalone library project %% must be a shared library",
3825 Project.Location, Project);
3826 Continuation := Continuation_String'Access;
3827 end if;
3829 -- Check that aggregated libraries do not share the aggregate
3830 -- Library_ALI_Dir.
3832 if Project.Qualifier = Aggregate_Library then
3833 Check_Aggregate_Library_Dirs;
3834 end if;
3836 if Project.Library and not Data.In_Aggregate_Lib then
3838 -- Record the library name
3840 Lib_Data_Table.Append
3841 ((Name => Project.Library_Name,
3842 Proj => Project,
3843 Tree => Data.Tree));
3844 end if;
3845 end Check_Library_Attributes;
3847 --------------------------
3848 -- Check_Package_Naming --
3849 --------------------------
3851 procedure Check_Package_Naming
3852 (Project : Project_Id;
3853 Data : in out Tree_Processing_Data)
3854 is
3855 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
3856 Naming_Id : constant Package_Id :=
3857 Util.Value_Of
3858 (Name_Naming, Project.Decl.Packages, Shared);
3859 Naming : Package_Element;
3861 Ada_Body_Suffix_Loc : Source_Ptr := No_Location;
3863 procedure Check_Naming;
3864 -- Check the validity of the Naming package (suffixes valid, ...)
3866 procedure Check_Common
3867 (Dot_Replacement : in out File_Name_Type;
3868 Casing : in out Casing_Type;
3869 Casing_Defined : out Boolean;
3870 Separate_Suffix : in out File_Name_Type;
3871 Sep_Suffix_Loc : out Source_Ptr);
3872 -- Check attributes common
3874 procedure Process_Exceptions_File_Based
3875 (Lang_Id : Language_Ptr;
3876 Kind : Source_Kind);
3877 procedure Process_Exceptions_Unit_Based
3878 (Lang_Id : Language_Ptr;
3879 Kind : Source_Kind);
3880 -- Process the naming exceptions for the two types of languages
3882 procedure Initialize_Naming_Data;
3883 -- Initialize internal naming data for the various languages
3885 ------------------
3886 -- Check_Common --
3887 ------------------
3889 procedure Check_Common
3890 (Dot_Replacement : in out File_Name_Type;
3891 Casing : in out Casing_Type;
3892 Casing_Defined : out Boolean;
3893 Separate_Suffix : in out File_Name_Type;
3894 Sep_Suffix_Loc : out Source_Ptr)
3895 is
3896 Dot_Repl : constant Variable_Value :=
3897 Util.Value_Of
3898 (Name_Dot_Replacement,
3899 Naming.Decl.Attributes,
3900 Shared);
3901 Casing_String : constant Variable_Value :=
3902 Util.Value_Of
3903 (Name_Casing,
3904 Naming.Decl.Attributes,
3905 Shared);
3906 Sep_Suffix : constant Variable_Value :=
3907 Util.Value_Of
3908 (Name_Separate_Suffix,
3909 Naming.Decl.Attributes,
3910 Shared);
3911 Dot_Repl_Loc : Source_Ptr;
3913 begin
3914 Sep_Suffix_Loc := No_Location;
3916 if not Dot_Repl.Default then
3917 pragma Assert
3918 (Dot_Repl.Kind = Single, "Dot_Replacement is not a string");
3920 if Length_Of_Name (Dot_Repl.Value) = 0 then
3921 Error_Msg
3922 (Data.Flags, "Dot_Replacement cannot be empty",
3923 Dot_Repl.Location, Project);
3924 end if;
3926 Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value);
3927 Dot_Repl_Loc := Dot_Repl.Location;
3929 declare
3930 Repl : constant String := Get_Name_String (Dot_Replacement);
3932 begin
3933 -- Dot_Replacement cannot
3934 -- - be empty
3935 -- - start or end with an alphanumeric
3940 if Repl'Length = 0
3941 or else Is_Alphanumeric (Repl (Repl'First))
3942 or else Is_Alphanumeric (Repl (Repl'Last))
3944 and then
3945 (Repl'Length = 1
3946 or else
3947 Is_Alphanumeric (Repl (Repl'First + 1))))
3948 or else (Repl'Length > 1
3949 and then
3950 Index (Source => Repl, Pattern => ".") /= 0)
3951 then
3952 Error_Msg
3953 (Data.Flags,
3956 Dot_Repl_Loc, Project);
3957 end if;
3958 end;
3959 end if;
3961 if Dot_Replacement /= No_File then
3962 Write_Attr
3964 end if;
3966 Casing_Defined := False;
3968 if not Casing_String.Default then
3969 pragma Assert
3972 declare
3973 Casing_Image : constant String :=
3974 Get_Name_String (Casing_String.Value);
3976 begin
3977 if Casing_Image'Length = 0 then
3978 Error_Msg
3979 (Data.Flags,
3981 Casing_String.Location, Project);
3982 end if;
3984 Casing := Value (Casing_Image);
3985 Casing_Defined := True;
3987 exception
3988 when Constraint_Error =>
3989 Name_Len := Casing_Image'Length;
3990 Name_Buffer (1 .. Name_Len) := Casing_Image;
3991 Err_Vars.Error_Msg_Name_1 := Name_Find;
3992 Error_Msg
3993 (Data.Flags,
3995 Casing_String.Location, Project);
3996 end;
3997 end if;
4001 if not Sep_Suffix.Default then
4002 if Length_Of_Name (Sep_Suffix.Value) = 0 then
4003 Error_Msg
4004 (Data.Flags,
4006 Sep_Suffix.Location, Project);
4008 else
4009 Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value);
4010 Sep_Suffix_Loc := Sep_Suffix.Location;
4012 Check_Illegal_Suffix
4013 (Project, Separate_Suffix,
4015 Data);
4016 end if;
4017 end if;
4019 if Separate_Suffix /= No_File then
4020 Write_Attr
4022 end if;
4023 end Check_Common;
4025 -----------------------------------
4026 -- Process_Exceptions_File_Based --
4027 -----------------------------------
4029 procedure Process_Exceptions_File_Based
4030 (Lang_Id : Language_Ptr;
4031 Kind : Source_Kind)
4032 is
4033 Lang : constant Name_Id := Lang_Id.Name;
4034 Exceptions : Array_Element_Id;
4035 Exception_List : Variable_Value;
4036 Element_Id : String_List_Id;
4037 Element : String_Element;
4038 File_Name : File_Name_Type;
4039 Source : Source_Id;
4041 begin
4042 case Kind is
4043 when Impl | Sep =>
4044 Exceptions :=
4045 Value_Of
4046 (Name_Implementation_Exceptions,
4047 In_Arrays => Naming.Decl.Arrays,
4048 Shared => Shared);
4050 when Spec =>
4051 Exceptions :=
4052 Value_Of
4053 (Name_Specification_Exceptions,
4054 In_Arrays => Naming.Decl.Arrays,
4055 Shared => Shared);
4056 end case;
4058 Exception_List :=
4059 Value_Of
4060 (Index => Lang,
4061 In_Array => Exceptions,
4062 Shared => Shared);
4064 if Exception_List /= Nil_Variable_Value then
4065 Element_Id := Exception_List.Values;
4066 while Element_Id /= Nil_String loop
4067 Element := Shared.String_Elements.Table (Element_Id);
4068 File_Name := Canonical_Case_File_Name (Element.Value);
4070 Source :=
4071 Source_Files_Htable.Get
4072 (Data.Tree.Source_Files_HT, File_Name);
4073 while Source /= No_Source
4074 and then Source.Project /= Project
4075 loop
4076 Source := Source.Next_With_File_Name;
4077 end loop;
4079 if Source = No_Source then
4080 Add_Source
4081 (Id => Source,
4082 Data => Data,
4083 Project => Project,
4084 Source_Dir_Rank => 0,
4085 Lang_Id => Lang_Id,
4086 Kind => Kind,
4087 File_Name => File_Name,
4088 Display_File => File_Name_Type (Element.Value),
4089 Naming_Exception => Yes,
4090 Location => Element.Location);
4092 else
4093 -- Check if the file name is already recorded for another
4094 -- language or another kind.
4096 if Source.Language /= Lang_Id then
4097 Error_Msg
4098 (Data.Flags,
4100 Element.Location, Project);
4102 elsif Source.Kind /= Kind then
4103 Error_Msg
4104 (Data.Flags,
4106 Element.Location, Project);
4107 end if;
4109 -- If the file is already recorded for the same
4110 -- language and the same kind, it means that the file
4111 -- name appears several times in the *_Exceptions
4112 -- attribute; so there is nothing to do.
4113 end if;
4115 Element_Id := Element.Next;
4116 end loop;
4117 end if;
4118 end Process_Exceptions_File_Based;
4120 -----------------------------------
4121 -- Process_Exceptions_Unit_Based --
4122 -----------------------------------
4124 procedure Process_Exceptions_Unit_Based
4125 (Lang_Id : Language_Ptr;
4126 Kind : Source_Kind)
4127 is
4128 Exceptions : Array_Element_Id;
4129 Element : Array_Element;
4130 Unit : Name_Id;
4131 Index : Int;
4132 File_Name : File_Name_Type;
4133 Source : Source_Id;
4135 Naming_Exception : Naming_Exception_Type;
4137 begin
4138 case Kind is
4139 when Impl | Sep =>
4140 Exceptions :=
4141 Value_Of
4142 (Name_Body,
4143 In_Arrays => Naming.Decl.Arrays,
4144 Shared => Shared);
4146 if Exceptions = No_Array_Element then
4147 Exceptions :=
4148 Value_Of
4149 (Name_Implementation,
4150 In_Arrays => Naming.Decl.Arrays,
4151 Shared => Shared);
4152 end if;
4154 when Spec =>
4155 Exceptions :=
4156 Value_Of
4157 (Name_Spec,
4158 In_Arrays => Naming.Decl.Arrays,
4159 Shared => Shared);
4161 if Exceptions = No_Array_Element then
4162 Exceptions :=
4163 Value_Of
4164 (Name_Specification,
4165 In_Arrays => Naming.Decl.Arrays,
4166 Shared => Shared);
4167 end if;
4168 end case;
4170 while Exceptions /= No_Array_Element loop
4171 Element := Shared.Array_Elements.Table (Exceptions);
4173 if Element.Restricted then
4174 Naming_Exception := Inherited;
4175 else
4176 Naming_Exception := Yes;
4177 end if;
4179 File_Name := Canonical_Case_File_Name (Element.Value.Value);
4181 Get_Name_String (Element.Index);
4182 To_Lower (Name_Buffer (1 .. Name_Len));
4183 Index := Element.Value.Index;
4185 -- Check if it is a valid unit name
4187 Get_Name_String (Element.Index);
4188 Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit);
4190 if Unit = No_Name then
4191 Err_Vars.Error_Msg_Name_1 := Element.Index;
4192 Error_Msg
4193 (Data.Flags,
4195 Element.Value.Location, Project);
4196 end if;
4198 if Unit /= No_Name then
4199 Add_Source
4200 (Id => Source,
4201 Data => Data,
4202 Project => Project,
4203 Source_Dir_Rank => 0,
4204 Lang_Id => Lang_Id,
4205 Kind => Kind,
4206 File_Name => File_Name,
4207 Display_File => File_Name_Type (Element.Value.Value),
4208 Unit => Unit,
4209 Index => Index,
4210 Location => Element.Value.Location,
4211 Naming_Exception => Naming_Exception);
4212 end if;
4214 Exceptions := Element.Next;
4215 end loop;
4216 end Process_Exceptions_Unit_Based;
4218 ------------------
4219 -- Check_Naming --
4220 ------------------
4222 procedure Check_Naming is
4223 Dot_Replacement : File_Name_Type :=
4224 File_Name_Type
4225 (First_Name_Id + Character'Pos ('-'));
4226 Separate_Suffix : File_Name_Type := No_File;
4227 Casing : Casing_Type := All_Lower_Case;
4228 Casing_Defined : Boolean;
4229 Lang_Id : Language_Ptr;
4230 Sep_Suffix_Loc : Source_Ptr;
4231 Suffix : Variable_Value;
4232 Lang : Name_Id;
4234 begin
4235 Check_Common
4236 (Dot_Replacement => Dot_Replacement,
4237 Casing => Casing,
4238 Casing_Defined => Casing_Defined,
4239 Separate_Suffix => Separate_Suffix,
4240 Sep_Suffix_Loc => Sep_Suffix_Loc);
4242 -- For all unit based languages, if any, set the specified value
4243 -- of Dot_Replacement, Casing and/or Separate_Suffix. Do not
4244 -- systematically overwrite, since the defaults come from the
4245 -- configuration file.
4247 if Dot_Replacement /= No_File
4248 or else Casing_Defined
4249 or else Separate_Suffix /= No_File
4250 then
4251 Lang_Id := Project.Languages;
4252 while Lang_Id /= No_Language_Index loop
4253 if Lang_Id.Config.Kind = Unit_Based then
4254 if Dot_Replacement /= No_File then
4255 Lang_Id.Config.Naming_Data.Dot_Replacement :=
4256 Dot_Replacement;
4257 end if;
4259 if Casing_Defined then
4260 Lang_Id.Config.Naming_Data.Casing := Casing;
4261 end if;
4262 end if;
4264 Lang_Id := Lang_Id.Next;
4265 end loop;
4266 end if;
4268 -- Next, get the spec and body suffixes
4270 Lang_Id := Project.Languages;
4271 while Lang_Id /= No_Language_Index loop
4272 Lang := Lang_Id.Name;
4274 -- Spec_Suffix
4276 Suffix := Value_Of
4277 (Name => Lang,
4278 Attribute_Or_Array_Name => Name_Spec_Suffix,
4279 In_Package => Naming_Id,
4280 Shared => Shared);
4282 if Suffix = Nil_Variable_Value then
4283 Suffix := Value_Of
4284 (Name => Lang,
4285 Attribute_Or_Array_Name => Name_Specification_Suffix,
4286 In_Package => Naming_Id,
4287 Shared => Shared);
4288 end if;
4290 if Suffix /= Nil_Variable_Value then
4291 Lang_Id.Config.Naming_Data.Spec_Suffix :=
4292 File_Name_Type (Suffix.Value);
4294 Check_Illegal_Suffix
4295 (Project,
4296 Lang_Id.Config.Naming_Data.Spec_Suffix,
4297 Lang_Id.Config.Naming_Data.Dot_Replacement,
4300 Write_Attr
4302 Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix));
4303 end if;
4305 -- Body_Suffix
4307 Suffix :=
4308 Value_Of
4309 (Name => Lang,
4310 Attribute_Or_Array_Name => Name_Body_Suffix,
4311 In_Package => Naming_Id,
4312 Shared => Shared);
4314 if Suffix = Nil_Variable_Value then
4315 Suffix :=
4316 Value_Of
4317 (Name => Lang,
4318 Attribute_Or_Array_Name => Name_Implementation_Suffix,
4319 In_Package => Naming_Id,
4320 Shared => Shared);
4321 end if;
4323 if Suffix /= Nil_Variable_Value then
4324 Lang_Id.Config.Naming_Data.Body_Suffix :=
4325 File_Name_Type (Suffix.Value);
4327 -- The default value of separate suffix should be the same as
4328 -- the body suffix, so we need to compute that first.
4330 if Separate_Suffix = No_File then
4331 Lang_Id.Config.Naming_Data.Separate_Suffix :=
4332 Lang_Id.Config.Naming_Data.Body_Suffix;
4333 Write_Attr
4335 Get_Name_String
4336 (Lang_Id.Config.Naming_Data.Separate_Suffix));
4337 else
4338 Lang_Id.Config.Naming_Data.Separate_Suffix :=
4339 Separate_Suffix;
4340 end if;
4342 Check_Illegal_Suffix
4343 (Project,
4344 Lang_Id.Config.Naming_Data.Body_Suffix,
4345 Lang_Id.Config.Naming_Data.Dot_Replacement,
4348 Write_Attr
4350 Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix));
4352 elsif Separate_Suffix /= No_File then
4353 Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix;
4354 end if;
4356 -- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix,
4357 -- since that would cause a clear ambiguity. Note that we do allow
4358 -- a Spec_Suffix to have the same termination as one of these,
4359 -- which causes a potential ambiguity, but we resolve that by
4360 -- matching the longest possible suffix.
4362 if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File
4363 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
4364 Lang_Id.Config.Naming_Data.Body_Suffix
4365 then
4366 Error_Msg
4367 (Data.Flags,
4369 & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)
4371 Ada_Body_Suffix_Loc, Project);
4372 end if;
4374 if Lang_Id.Config.Naming_Data.Body_Suffix /=
4375 Lang_Id.Config.Naming_Data.Separate_Suffix
4376 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
4377 Lang_Id.Config.Naming_Data.Separate_Suffix
4378 then
4379 Error_Msg
4380 (Data.Flags,
4382 & Get_Name_String
4383 (Lang_Id.Config.Naming_Data.Separate_Suffix)
4385 Sep_Suffix_Loc, Project);
4386 end if;
4388 Lang_Id := Lang_Id.Next;
4389 end loop;
4391 -- Get the naming exceptions for all languages, but not for virtual
4392 -- projects.
4394 if not Project.Virtual then
4395 for Kind in Spec_Or_Body loop
4396 Lang_Id := Project.Languages;
4397 while Lang_Id /= No_Language_Index loop
4398 case Lang_Id.Config.Kind is
4399 when File_Based =>
4400 Process_Exceptions_File_Based (Lang_Id, Kind);
4402 when Unit_Based =>
4403 Process_Exceptions_Unit_Based (Lang_Id, Kind);
4404 end case;
4406 Lang_Id := Lang_Id.Next;
4407 end loop;
4408 end loop;
4409 end if;
4410 end Check_Naming;
4412 ----------------------------
4413 -- Initialize_Naming_Data --
4414 ----------------------------
4416 procedure Initialize_Naming_Data is
4417 Specs : Array_Element_Id :=
4418 Util.Value_Of
4419 (Name_Spec_Suffix,
4420 Naming.Decl.Arrays,
4421 Shared);
4423 Impls : Array_Element_Id :=
4424 Util.Value_Of
4425 (Name_Body_Suffix,
4426 Naming.Decl.Arrays,
4427 Shared);
4429 Lang : Language_Ptr;
4430 Lang_Name : Name_Id;
4431 Value : Variable_Value;
4432 Extended : Project_Id;
4434 begin
4435 -- At this stage, the project already contains the default extensions
4436 -- for the various languages. We now merge those suffixes read in the
4437 -- user project, and they override the default.
4439 while Specs /= No_Array_Element loop
4440 Lang_Name := Shared.Array_Elements.Table (Specs).Index;
4441 Lang :=
4442 Get_Language_From_Name
4443 (Project, Name => Get_Name_String (Lang_Name));
4445 -- An extending project inherits its parent projects' languages
4446 -- so if needed we should create entries for those languages
4448 if Lang = null then
4449 Extended := Project.Extends;
4450 while Extended /= null loop
4451 Lang := Get_Language_From_Name
4452 (Extended, Name => Get_Name_String (Lang_Name));
4453 exit when Lang /= null;
4455 Extended := Extended.Extends;
4456 end loop;
4458 if Lang /= null then
4459 Lang := new Language_Data'(Lang.all);
4460 Lang.First_Source := null;
4461 Lang.Next := Project.Languages;
4462 Project.Languages := Lang;
4463 end if;
4464 end if;
4466 -- If language was not found in project or the projects it extends
4468 if Lang = null then
4469 Debug_Output
4471 Lang_Name);
4473 else
4474 Value := Shared.Array_Elements.Table (Specs).Value;
4476 if Value.Kind = Single then
4477 Lang.Config.Naming_Data.Spec_Suffix :=
4478 Canonical_Case_File_Name (Value.Value);
4479 end if;
4480 end if;
4482 Specs := Shared.Array_Elements.Table (Specs).Next;
4483 end loop;
4485 while Impls /= No_Array_Element loop
4486 Lang_Name := Shared.Array_Elements.Table (Impls).Index;
4487 Lang :=
4488 Get_Language_From_Name
4489 (Project, Name => Get_Name_String (Lang_Name));
4491 if Lang = null then
4492 Debug_Output
4494 Lang_Name);
4495 else
4496 Value := Shared.Array_Elements.Table (Impls).Value;
4498 if Lang.Name = Name_Ada then
4499 Ada_Body_Suffix_Loc := Value.Location;
4500 end if;
4502 if Value.Kind = Single then
4503 Lang.Config.Naming_Data.Body_Suffix :=
4504 Canonical_Case_File_Name (Value.Value);
4505 end if;
4506 end if;
4508 Impls := Shared.Array_Elements.Table (Impls).Next;
4509 end loop;
4510 end Initialize_Naming_Data;
4512 -- Start of processing for Check_Naming_Schemes
4514 begin
4515 -- No Naming package or parsing a configuration file? nothing to do
4517 if Naming_Id /= No_Package
4518 and then Project.Qualifier /= Configuration
4519 then
4520 Naming := Shared.Packages.Table (Naming_Id);
4522 Initialize_Naming_Data;
4523 Check_Naming;
4525 end if;
4526 end Check_Package_Naming;
4528 ---------------------------------
4529 -- Check_Programming_Languages --
4530 ---------------------------------
4532 procedure Check_Programming_Languages
4533 (Project : Project_Id;
4534 Data : in out Tree_Processing_Data)
4535 is
4536 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
4538 Languages : Variable_Value := Nil_Variable_Value;
4539 Def_Lang : Variable_Value := Nil_Variable_Value;
4540 Def_Lang_Id : Name_Id;
4542 procedure Add_Language (Name, Display_Name : Name_Id);
4543 -- Add a new language to the list of languages for the project.
4544 -- Nothing is done if the language has already been defined
4546 ------------------
4547 -- Add_Language --
4548 ------------------
4550 procedure Add_Language (Name, Display_Name : Name_Id) is
4551 Lang : Language_Ptr;
4553 begin
4554 Lang := Project.Languages;
4555 while Lang /= No_Language_Index loop
4556 if Name = Lang.Name then
4557 return;
4558 end if;
4560 Lang := Lang.Next;
4561 end loop;
4563 Lang := new Language_Data'(No_Language_Data);
4564 Lang.Next := Project.Languages;
4565 Project.Languages := Lang;
4566 Lang.Name := Name;
4567 Lang.Display_Name := Display_Name;
4568 end Add_Language;
4570 -- Start of processing for Check_Programming_Languages
4572 begin
4573 Project.Languages := null;
4574 Languages :=
4575 Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, Shared);
4576 Def_Lang :=
4577 Prj.Util.Value_Of
4578 (Name_Default_Language, Project.Decl.Attributes, Shared);
4580 if Project.Source_Dirs /= Nil_String then
4582 -- Check if languages are specified in this project
4584 if Languages.Default then
4586 -- Fail if there is no default language defined
4588 if Def_Lang.Default then
4589 Error_Msg
4590 (Data.Flags,
4592 Project.Location, Project);
4593 Def_Lang_Id := No_Name;
4595 else
4596 Get_Name_String (Def_Lang.Value);
4597 To_Lower (Name_Buffer (1 .. Name_Len));
4598 Def_Lang_Id := Name_Find;
4599 end if;
4601 if Def_Lang_Id /= No_Name then
4602 Get_Name_String (Def_Lang_Id);
4603 Name_Buffer (1) := GNAT.Case_Util.To_Upper (Name_Buffer (1));
4604 Add_Language
4605 (Name => Def_Lang_Id,
4606 Display_Name => Name_Find);
4607 end if;
4609 else
4610 declare
4611 Current : String_List_Id := Languages.Values;
4612 Element : String_Element;
4614 begin
4615 -- If there are no languages declared, there are no sources
4617 if Current = Nil_String then
4618 Project.Source_Dirs := Nil_String;
4620 if Project.Qualifier = Standard then
4621 Error_Msg
4622 (Data.Flags,
4624 Languages.Location, Project);
4625 end if;
4627 else
4628 -- Look through all the languages specified in attribute
4629 -- Languages.
4631 while Current /= Nil_String loop
4632 Element := Shared.String_Elements.Table (Current);
4633 Get_Name_String (Element.Value);
4634 To_Lower (Name_Buffer (1 .. Name_Len));
4636 Add_Language
4637 (Name => Name_Find,
4638 Display_Name => Element.Value);
4640 Current := Element.Next;
4641 end loop;
4642 end if;
4643 end;
4644 end if;
4645 end if;
4646 end Check_Programming_Languages;
4648 -------------------------------
4649 -- Check_Stand_Alone_Library --
4650 -------------------------------
4652 procedure Check_Stand_Alone_Library
4653 (Project : Project_Id;
4654 Data : in out Tree_Processing_Data)
4655 is
4656 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
4658 Lib_Name : constant Prj.Variable_Value :=
4659 Prj.Util.Value_Of
4660 (Snames.Name_Library_Name,
4661 Project.Decl.Attributes,
4662 Shared);
4664 Lib_Standalone : constant Prj.Variable_Value :=
4665 Prj.Util.Value_Of
4666 (Snames.Name_Library_Standalone,
4667 Project.Decl.Attributes,
4668 Shared);
4670 Lib_Auto_Init : constant Prj.Variable_Value :=
4671 Prj.Util.Value_Of
4672 (Snames.Name_Library_Auto_Init,
4673 Project.Decl.Attributes,
4674 Shared);
4676 Lib_Src_Dir : constant Prj.Variable_Value :=
4677 Prj.Util.Value_Of
4678 (Snames.Name_Library_Src_Dir,
4679 Project.Decl.Attributes,
4680 Shared);
4682 Lib_Symbol_File : constant Prj.Variable_Value :=
4683 Prj.Util.Value_Of
4684 (Snames.Name_Library_Symbol_File,
4685 Project.Decl.Attributes,
4686 Shared);
4688 Lib_Symbol_Policy : constant Prj.Variable_Value :=
4689 Prj.Util.Value_Of
4690 (Snames.Name_Library_Symbol_Policy,
4691 Project.Decl.Attributes,
4692 Shared);
4694 Lib_Ref_Symbol_File : constant Prj.Variable_Value :=
4695 Prj.Util.Value_Of
4696 (Snames.Name_Library_Reference_Symbol_File,
4697 Project.Decl.Attributes,
4698 Shared);
4700 Auto_Init_Supported : Boolean;
4701 OK : Boolean := True;
4703 begin
4704 Auto_Init_Supported := Project.Config.Auto_Init_Supported;
4706 -- It is a stand-alone library project file if there is at least one
4707 -- unit in the declared or inherited interface.
4709 if Project.Lib_Interface_ALIs = Nil_String then
4710 if not Lib_Standalone.Default
4712 then
4713 Error_Msg
4714 (Data.Flags,
4716 Lib_Standalone.Location, Project);
4717 end if;
4719 else
4720 if Project.Standalone_Library = No then
4721 Project.Standalone_Library := Standard;
4722 end if;
4724 -- The name of a stand-alone library needs to have the syntax of an
4725 -- Ada identifier.
4727 declare
4728 Name : constant String := Get_Name_String (Project.Library_Name);
4729 OK : Boolean := Is_Letter (Name (Name'First));
4731 Underline : Boolean := False;
4733 begin
4734 for J in Name'First + 1 .. Name'Last loop
4735 exit when not OK;
4737 if Is_Alphanumeric (Name (J)) then
4738 Underline := False;
4740 elsif Name (J) = '_' then
4741 if Underline then
4742 OK := False;
4743 else
4744 Underline := True;
4745 end if;
4747 else
4748 OK := False;
4749 end if;
4750 end loop;
4752 OK := OK and not Underline;
4754 if not OK then
4755 Error_Msg
4756 (Data.Flags,
4758 Lib_Name.Location, Project);
4759 return;
4760 end if;
4761 end;
4763 if Lib_Standalone.Default then
4764 Project.Standalone_Library := Standard;
4766 else
4767 Get_Name_String (Lib_Standalone.Value);
4768 To_Lower (Name_Buffer (1 .. Name_Len));
4771 Project.Standalone_Library := Standard;
4774 Project.Standalone_Library := Encapsulated;
4777 Project.Standalone_Library := No;
4778 Error_Msg
4779 (Data.Flags,
4782 Lib_Standalone.Location, Project);
4784 else
4785 Error_Msg
4786 (Data.Flags,
4788 Lib_Standalone.Location, Project);
4789 end if;
4790 end if;
4792 -- Check value of attribute Library_Auto_Init and set Lib_Auto_Init
4793 -- accordingly.
4795 if Lib_Auto_Init.Default then
4797 -- If no attribute Library_Auto_Init is declared, then set auto
4798 -- init only if it is supported.
4800 Project.Lib_Auto_Init := Auto_Init_Supported;
4802 else
4803 Get_Name_String (Lib_Auto_Init.Value);
4804 To_Lower (Name_Buffer (1 .. Name_Len));
4807 Project.Lib_Auto_Init := False;
4810 if Auto_Init_Supported then
4811 Project.Lib_Auto_Init := True;
4813 else
4815 -- supported.
4817 Error_Msg
4818 (Data.Flags,
4821 Lib_Auto_Init.Location, Project);
4822 end if;
4824 else
4825 Error_Msg
4826 (Data.Flags,
4828 Lib_Auto_Init.Location, Project);
4829 end if;
4830 end if;
4832 -- If attribute Library_Src_Dir is defined and not the empty string,
4833 -- check if the directory exist and is not the object directory or
4834 -- one of the source directories. This is the directory where copies
4835 -- of the interface sources will be copied. Note that this directory
4836 -- may be the library directory.
4838 if Lib_Src_Dir.Value /= Empty_String then
4839 declare
4840 Dir_Id : constant File_Name_Type :=
4841 File_Name_Type (Lib_Src_Dir.Value);
4842 Dir_Exists : Boolean;
4844 begin
4845 Locate_Directory
4846 (Project,
4847 Dir_Id,
4848 Path => Project.Library_Src_Dir,
4849 Dir_Exists => Dir_Exists,
4850 Data => Data,
4851 Must_Exist => False,
4853 Location => Lib_Src_Dir.Location,
4854 Externally_Built => Project.Externally_Built);
4856 -- If directory does not exist, report an error
4858 if not Dir_Exists then
4860 -- Get the absolute name of the library directory that does
4861 -- not exist, to report an error.
4863 Err_Vars.Error_Msg_File_1 :=
4864 File_Name_Type (Project.Library_Src_Dir.Display_Name);
4865 Error_Msg
4866 (Data.Flags,
4868 Lib_Src_Dir.Location, Project);
4870 -- Report error if it is the same as the object directory
4872 elsif Project.Library_Src_Dir = Project.Object_Directory then
4873 Error_Msg
4874 (Data.Flags,
4877 Lib_Src_Dir.Location, Project);
4878 Project.Library_Src_Dir := No_Path_Information;
4880 else
4881 declare
4882 Src_Dirs : String_List_Id;
4883 Src_Dir : String_Element;
4884 Pid : Project_List;
4886 begin
4887 -- Interface copy directory cannot be one of the source
4888 -- directory of the current project.
4890 Src_Dirs := Project.Source_Dirs;
4891 while Src_Dirs /= Nil_String loop
4892 Src_Dir := Shared.String_Elements.Table (Src_Dirs);
4894 -- Report error if it is one of the source directories
4896 if Project.Library_Src_Dir.Name =
4897 Path_Name_Type (Src_Dir.Value)
4898 then
4899 Error_Msg
4900 (Data.Flags,
4903 Lib_Src_Dir.Location, Project);
4904 Project.Library_Src_Dir := No_Path_Information;
4905 exit;
4906 end if;
4908 Src_Dirs := Src_Dir.Next;
4909 end loop;
4911 if Project.Library_Src_Dir /= No_Path_Information then
4913 -- It cannot be a source directory of any other
4914 -- project either.
4916 Pid := Data.Tree.Projects;
4917 Project_Loop : loop
4918 exit Project_Loop when Pid = null;
4920 Src_Dirs := Pid.Project.Source_Dirs;
4921 Dir_Loop : while Src_Dirs /= Nil_String loop
4922 Src_Dir :=
4923 Shared.String_Elements.Table (Src_Dirs);
4925 -- Report error if it is one of the source
4926 -- directories.
4928 if Project.Library_Src_Dir.Name =
4929 Path_Name_Type (Src_Dir.Value)
4930 then
4931 Error_Msg_File_1 :=
4932 File_Name_Type (Src_Dir.Value);
4933 Error_Msg_Name_1 := Pid.Project.Name;
4934 Error_Msg
4935 (Data.Flags,
4939 Lib_Src_Dir.Location, Project);
4940 Project.Library_Src_Dir :=
4941 No_Path_Information;
4942 exit Project_Loop;
4943 end if;
4945 Src_Dirs := Src_Dir.Next;
4946 end loop Dir_Loop;
4948 Pid := Pid.Next;
4949 end loop Project_Loop;
4950 end if;
4951 end;
4953 -- In high verbosity, if there is a valid Library_Src_Dir,
4954 -- display its path name.
4956 if Project.Library_Src_Dir /= No_Path_Information
4957 and then Current_Verbosity = High
4958 then
4959 Write_Attr
4961 Get_Name_String (Project.Library_Src_Dir.Name));
4962 end if;
4963 end if;
4964 end;
4965 end if;
4967 -- Check the symbol related attributes
4969 -- First, the symbol policy
4971 if not Lib_Symbol_Policy.Default then
4972 declare
4973 Value : constant String :=
4974 To_Lower
4975 (Get_Name_String (Lib_Symbol_Policy.Value));
4977 begin
4978 -- Symbol policy must have one of a limited number of values
4981 Project.Symbol_Data.Symbol_Policy := Autonomous;
4984 Project.Symbol_Data.Symbol_Policy := Compliant;
4987 Project.Symbol_Data.Symbol_Policy := Controlled;
4990 Project.Symbol_Data.Symbol_Policy := Restricted;
4993 Project.Symbol_Data.Symbol_Policy := Direct;
4995 else
4996 Error_Msg
4997 (Data.Flags,
4999 Lib_Symbol_Policy.Location, Project);
5000 end if;
5001 end;
5002 end if;
5004 -- If attribute Library_Symbol_File is not specified, symbol policy
5005 -- cannot be Restricted.
5007 if Lib_Symbol_File.Default then
5008 if Project.Symbol_Data.Symbol_Policy = Restricted then
5009 Error_Msg
5010 (Data.Flags,
5013 Lib_Symbol_Policy.Location, Project);
5014 end if;
5016 else
5017 -- Library_Symbol_File is defined
5019 Project.Symbol_Data.Symbol_File :=
5020 Path_Name_Type (Lib_Symbol_File.Value);
5022 Get_Name_String (Lib_Symbol_File.Value);
5024 if Name_Len = 0 then
5025 Error_Msg
5026 (Data.Flags,
5028 Lib_Symbol_File.Location, Project);
5030 else
5031 OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
5033 if OK then
5034 for J in 1 .. Name_Len loop
5035 if Is_Directory_Separator (Name_Buffer (J)) then
5036 OK := False;
5037 exit;
5038 end if;
5039 end loop;
5040 end if;
5042 if not OK then
5043 Error_Msg_File_1 := File_Name_Type (Lib_Symbol_File.Value);
5044 Error_Msg
5045 (Data.Flags,
5048 Lib_Symbol_File.Location, Project);
5049 end if;
5050 end if;
5051 end if;
5053 -- If attribute Library_Reference_Symbol_File is not defined,
5054 -- symbol policy cannot be Compliant or Controlled.
5056 if Lib_Ref_Symbol_File.Default then
5057 if Project.Symbol_Data.Symbol_Policy = Compliant
5058 or else Project.Symbol_Data.Symbol_Policy = Controlled
5059 then
5060 Error_Msg
5061 (Data.Flags,
5063 Lib_Symbol_Policy.Location, Project);
5064 end if;
5066 else
5067 -- Library_Reference_Symbol_File is defined, check file exists
5069 Project.Symbol_Data.Reference :=
5070 Path_Name_Type (Lib_Ref_Symbol_File.Value);
5072 Get_Name_String (Lib_Ref_Symbol_File.Value);
5074 if Name_Len = 0 then
5075 Error_Msg
5076 (Data.Flags,
5078 Lib_Symbol_File.Location, Project);
5080 else
5081 if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then
5082 Name_Len := 0;
5083 Add_Str_To_Name_Buffer
5084 (Get_Name_String (Project.Directory.Name));
5085 Add_Str_To_Name_Buffer
5086 (Get_Name_String (Lib_Ref_Symbol_File.Value));
5087 Project.Symbol_Data.Reference := Name_Find;
5088 end if;
5090 if not Is_Regular_File
5091 (Get_Name_String (Project.Symbol_Data.Reference))
5092 then
5093 Error_Msg_File_1 :=
5094 File_Name_Type (Lib_Ref_Symbol_File.Value);
5096 -- For controlled and direct symbol policies, it is an error
5097 -- if the reference symbol file does not exist. For other
5098 -- symbol policies, this is just a warning
5100 Error_Msg_Warn :=
5101 Project.Symbol_Data.Symbol_Policy /= Controlled
5102 and then Project.Symbol_Data.Symbol_Policy /= Direct;
5104 Error_Msg
5105 (Data.Flags,
5107 Lib_Ref_Symbol_File.Location, Project);
5109 -- In addition in the non-controlled case, if symbol policy
5110 -- is Compliant, it is changed to Autonomous, because there
5111 -- is no reference to check against, and we don't want to
5112 -- fail in this case.
5114 if Project.Symbol_Data.Symbol_Policy /= Controlled then
5115 if Project.Symbol_Data.Symbol_Policy = Compliant then
5116 Project.Symbol_Data.Symbol_Policy := Autonomous;
5117 end if;
5118 end if;
5119 end if;
5121 -- If both the reference symbol file and the symbol file are
5122 -- defined, then check that they are not the same file.
5124 if Project.Symbol_Data.Symbol_File /= No_Path then
5125 Get_Name_String (Project.Symbol_Data.Symbol_File);
5127 if Name_Len > 0 then
5128 declare
5129 -- We do not need to pass a Directory to
5130 -- Normalize_Pathname, since the path_information
5131 -- already contains absolute information.
5133 Symb_Path : constant String :=
5134 Normalize_Pathname
5135 (Get_Name_String
5136 (Project.Object_Directory.Name) &
5137 Name_Buffer (1 .. Name_Len),
5139 Resolve_Links =>
5140 Opt.Follow_Links_For_Files);
5141 Ref_Path : constant String :=
5142 Normalize_Pathname
5143 (Get_Name_String
5144 (Project.Symbol_Data.Reference),
5146 Resolve_Links =>
5147 Opt.Follow_Links_For_Files);
5148 begin
5149 if Symb_Path = Ref_Path then
5150 Error_Msg
5151 (Data.Flags,
5154 Lib_Ref_Symbol_File.Location, Project);
5155 end if;
5156 end;
5157 end if;
5158 end if;
5159 end if;
5160 end if;
5161 end if;
5162 end Check_Stand_Alone_Library;
5164 ---------------------
5165 -- Check_Unit_Name --
5166 ---------------------
5168 procedure Check_Unit_Name (Name : String; Unit : out Name_Id) is
5169 The_Name : String := Name;
5170 Real_Name : Name_Id;
5171 Need_Letter : Boolean := True;
5172 Last_Underscore : Boolean := False;
5173 OK : Boolean := The_Name'Length > 0;
5174 First : Positive;
5176 function Is_Reserved (Name : Name_Id) return Boolean;
5177 function Is_Reserved (S : String) return Boolean;
5178 -- Check that the given name is not an Ada 95 reserved word. The reason
5179 -- for the Ada 95 here is that we do not want to exclude the case of an
5180 -- Ada 95 unit called Interface (for example). In Ada 2005, such a unit
5181 -- name would be rejected anyway by the compiler. That means there is no
5182 -- requirement that the project file parser reject this.
5184 -----------------
5185 -- Is_Reserved --
5186 -----------------
5188 function Is_Reserved (S : String) return Boolean is
5189 begin
5190 Name_Len := 0;
5191 Add_Str_To_Name_Buffer (S);
5192 return Is_Reserved (Name_Find);
5193 end Is_Reserved;
5195 -----------------
5196 -- Is_Reserved --
5197 -----------------
5199 function Is_Reserved (Name : Name_Id) return Boolean is
5200 begin
5201 if Get_Name_Table_Byte (Name) /= 0
5202 and then
5203 not Nam_In (Name, Name_Project, Name_Extends, Name_External)
5204 and then Name not in Ada_2005_Reserved_Words
5205 then
5206 Unit := No_Name;
5208 return True;
5210 else
5211 return False;
5212 end if;
5213 end Is_Reserved;
5215 -- Start of processing for Check_Unit_Name
5217 begin
5218 To_Lower (The_Name);
5220 Name_Len := The_Name'Length;
5221 Name_Buffer (1 .. Name_Len) := The_Name;
5223 Real_Name := Name_Find;
5225 if Is_Reserved (Real_Name) then
5226 return;
5227 end if;
5229 First := The_Name'First;
5231 for Index in The_Name'Range loop
5232 if Need_Letter then
5234 -- We need a letter (at the beginning, and following a dot),
5235 -- but we don't have one.
5237 if Is_Letter (The_Name (Index)) then
5238 Need_Letter := False;
5240 else
5241 OK := False;
5243 if Current_Verbosity = High then
5244 Debug_Indent;
5245 Write_Int (Types.Int (Index));
5247 Write_Char (The_Name (Index));
5249 end if;
5251 exit;
5252 end if;
5254 elsif Last_Underscore
5255 and then (The_Name (Index) = '_' or else The_Name (Index) = '.')
5256 then
5257 -- Two underscores are illegal, and a dot cannot follow
5258 -- an underscore.
5260 OK := False;
5262 if Current_Verbosity = High then
5263 Debug_Indent;
5264 Write_Int (Types.Int (Index));
5266 Write_Char (The_Name (Index));
5268 end if;
5270 exit;
5272 elsif The_Name (Index) = '.' then
5274 -- First, check if the name before the dot is not a reserved word
5276 if Is_Reserved (The_Name (First .. Index - 1)) then
5277 return;
5278 end if;
5280 First := Index + 1;
5282 -- We need a letter after a dot
5284 Need_Letter := True;
5286 elsif The_Name (Index) = '_' then
5287 Last_Underscore := True;
5289 else
5290 -- We need an letter or a digit
5292 Last_Underscore := False;
5294 if not Is_Alphanumeric (The_Name (Index)) then
5295 OK := False;
5297 if Current_Verbosity = High then
5298 Debug_Indent;
5299 Write_Int (Types.Int (Index));
5301 Write_Char (The_Name (Index));
5303 end if;
5305 exit;
5306 end if;
5307 end if;
5308 end loop;
5310 -- Cannot end with an underscore or a dot
5312 OK := OK and then not Need_Letter and then not Last_Underscore;
5314 if OK then
5315 if First /= Name'First
5316 and then Is_Reserved (The_Name (First .. The_Name'Last))
5317 then
5318 return;
5319 end if;
5321 Unit := Real_Name;
5323 else
5324 -- Signal a problem with No_Name
5326 Unit := No_Name;
5327 end if;
5328 end Check_Unit_Name;
5330 ----------------------------
5331 -- Compute_Directory_Last --
5332 ----------------------------
5334 function Compute_Directory_Last (Dir : String) return Natural is
5335 begin
5336 if Dir'Length > 1
5337 and then Is_Directory_Separator (Dir (Dir'Last - 1))
5338 then
5339 return Dir'Last - 1;
5340 else
5341 return Dir'Last;
5342 end if;
5343 end Compute_Directory_Last;
5345 ---------------------
5346 -- Get_Directories --
5347 ---------------------
5349 procedure Get_Directories
5350 (Project : Project_Id;
5351 Data : in out Tree_Processing_Data)
5352 is
5353 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
5355 Object_Dir : constant Variable_Value :=
5356 Util.Value_Of
5357 (Name_Object_Dir, Project.Decl.Attributes, Shared);
5359 Exec_Dir : constant Variable_Value :=
5360 Util.Value_Of
5361 (Name_Exec_Dir, Project.Decl.Attributes, Shared);
5363 Source_Dirs : constant Variable_Value :=
5364 Util.Value_Of
5365 (Name_Source_Dirs, Project.Decl.Attributes, Shared);
5367 Ignore_Source_Sub_Dirs : constant Variable_Value :=
5368 Util.Value_Of
5369 (Name_Ignore_Source_Sub_Dirs,
5370 Project.Decl.Attributes,
5371 Shared);
5373 Excluded_Source_Dirs : constant Variable_Value :=
5374 Util.Value_Of
5375 (Name_Excluded_Source_Dirs,
5376 Project.Decl.Attributes,
5377 Shared);
5379 Source_Files : constant Variable_Value :=
5380 Util.Value_Of
5381 (Name_Source_Files,
5382 Project.Decl.Attributes, Shared);
5384 Last_Source_Dir : String_List_Id := Nil_String;
5385 Last_Src_Dir_Rank : Number_List_Index := No_Number_List;
5387 Languages : constant Variable_Value :=
5388 Prj.Util.Value_Of
5389 (Name_Languages, Project.Decl.Attributes, Shared);
5391 Remove_Source_Dirs : Boolean := False;
5393 procedure Add_To_Or_Remove_From_Source_Dirs
5394 (Path : Path_Information;
5395 Rank : Natural);
5396 -- When Removed = False, the directory Path_Id to the list of
5397 -- source_dirs if not already in the list. When Removed = True,
5398 -- removed directory Path_Id if in the list.
5400 procedure Find_Source_Dirs is new Expand_Subdirectory_Pattern
5401 (Add_To_Or_Remove_From_Source_Dirs);
5403 ---------------------------------------
5404 -- Add_To_Or_Remove_From_Source_Dirs --
5405 ---------------------------------------
5407 procedure Add_To_Or_Remove_From_Source_Dirs
5408 (Path : Path_Information;
5409 Rank : Natural)
5410 is
5411 List : String_List_Id;
5412 Prev : String_List_Id;
5413 Rank_List : Number_List_Index;
5414 Prev_Rank : Number_List_Index;
5415 Element : String_Element;
5417 begin
5418 Prev := Nil_String;
5419 Prev_Rank := No_Number_List;
5420 List := Project.Source_Dirs;
5421 Rank_List := Project.Source_Dir_Ranks;
5422 while List /= Nil_String loop
5423 Element := Shared.String_Elements.Table (List);
5424 exit when Element.Value = Name_Id (Path.Name);
5425 Prev := List;
5426 List := Element.Next;
5427 Prev_Rank := Rank_List;
5428 Rank_List := Shared.Number_Lists.Table (Prev_Rank).Next;
5429 end loop;
5431 -- The directory is in the list if List is not Nil_String
5433 if not Remove_Source_Dirs and then List = Nil_String then
5436 String_Element_Table.Increment_Last (Shared.String_Elements);
5437 Element :=
5438 (Value => Name_Id (Path.Name),
5439 Index => 0,
5440 Display_Value => Name_Id (Path.Display_Name),
5441 Location => No_Location,
5442 Flag => False,
5443 Next => Nil_String);
5445 Number_List_Table.Increment_Last (Shared.Number_Lists);
5447 if Last_Source_Dir = Nil_String then
5449 -- This is the first source directory
5451 Project.Source_Dirs :=
5452 String_Element_Table.Last (Shared.String_Elements);
5453 Project.Source_Dir_Ranks :=
5454 Number_List_Table.Last (Shared.Number_Lists);
5456 else
5457 -- We already have source directories, link the previous
5458 -- last to the new one.
5460 Shared.String_Elements.Table (Last_Source_Dir).Next :=
5461 String_Element_Table.Last (Shared.String_Elements);
5462 Shared.Number_Lists.Table (Last_Src_Dir_Rank).Next :=
5463 Number_List_Table.Last (Shared.Number_Lists);
5464 end if;
5466 -- And register this source directory as the new last
5468 Last_Source_Dir :=
5469 String_Element_Table.Last (Shared.String_Elements);
5470 Shared.String_Elements.Table (Last_Source_Dir) := Element;
5471 Last_Src_Dir_Rank := Number_List_Table.Last (Shared.Number_Lists);
5472 Shared.Number_Lists.Table (Last_Src_Dir_Rank) :=
5473 (Number => Rank, Next => No_Number_List);
5475 elsif Remove_Source_Dirs and then List /= Nil_String then
5477 -- Remove source dir if present
5479 if Prev = Nil_String then
5480 Project.Source_Dirs := Shared.String_Elements.Table (List).Next;
5481 Project.Source_Dir_Ranks :=
5482 Shared.Number_Lists.Table (Rank_List).Next;
5484 else
5485 Shared.String_Elements.Table (Prev).Next :=
5486 Shared.String_Elements.Table (List).Next;
5487 Shared.Number_Lists.Table (Prev_Rank).Next :=
5488 Shared.Number_Lists.Table (Rank_List).Next;
5489 end if;
5490 end if;
5491 end Add_To_Or_Remove_From_Source_Dirs;
5493 -- Local declarations
5495 Dir_Exists : Boolean;
5497 No_Sources : constant Boolean :=
5498 Project.Qualifier = Abstract_Project
5499 or else (((not Source_Files.Default
5500 and then Source_Files.Values = Nil_String)
5501 or else
5502 (not Source_Dirs.Default
5503 and then Source_Dirs.Values = Nil_String)
5504 or else
5505 (not Languages.Default
5506 and then Languages.Values = Nil_String))
5507 and then Project.Extends = No_Project);
5509 -- Start of processing for Get_Directories
5511 begin
5514 -- Set the object directory to its default which may be nil, if there
5515 -- is no sources in the project.
5517 if No_Sources then
5518 Project.Object_Directory := No_Path_Information;
5519 else
5520 Project.Object_Directory := Project.Directory;
5521 end if;
5523 -- Check the object directory
5525 if Object_Dir.Value /= Empty_String then
5526 Get_Name_String (Object_Dir.Value);
5528 if Name_Len = 0 then
5529 Error_Msg
5530 (Data.Flags,
5532 Object_Dir.Location, Project);
5534 elsif Setup_Projects
5535 and then No_Sources
5536 and then Project.Extends = No_Project
5537 then
5538 -- Do not create an object directory for a non extending project
5539 -- with no sources.
5541 Locate_Directory
5542 (Project,
5543 File_Name_Type (Object_Dir.Value),
5544 Path => Project.Object_Directory,
5545 Dir_Exists => Dir_Exists,
5546 Data => Data,
5547 Location => Object_Dir.Location,
5548 Must_Exist => False,
5549 Externally_Built => Project.Externally_Built);
5551 else
5552 -- We check that the specified object directory does exist.
5553 -- However, even when it doesn't exist, we set it to a default
5554 -- value. This is for the benefit of tools that recover from
5555 -- errors; for example, these tools could create the non existent
5556 -- directory. We always return an absolute directory name though.
5558 Locate_Directory
5559 (Project,
5560 File_Name_Type (Object_Dir.Value),
5561 Path => Project.Object_Directory,
5563 Dir_Exists => Dir_Exists,
5564 Data => Data,
5565 Location => Object_Dir.Location,
5566 Must_Exist => False,
5567 Externally_Built => Project.Externally_Built);
5569 if not Dir_Exists and then not Project.Externally_Built then
5570 if Opt.Directories_Must_Exist_In_Projects then
5572 -- The object directory does not exist, report an error if
5573 -- the project is not externally built.
5575 Err_Vars.Error_Msg_File_1 :=
5576 File_Name_Type (Object_Dir.Value);
5577 Error_Or_Warning
5578 (Data.Flags, Data.Flags.Require_Obj_Dirs,
5580 Project.Location, Project);
5581 end if;
5582 end if;
5583 end if;
5585 elsif not No_Sources and then Subdirs /= null then
5586 Name_Len := 1;
5587 Name_Buffer (1) := '.';
5588 Locate_Directory
5589 (Project,
5590 Name_Find,
5591 Path => Project.Object_Directory,
5593 Dir_Exists => Dir_Exists,
5594 Data => Data,
5595 Location => Object_Dir.Location,
5596 Externally_Built => Project.Externally_Built);
5597 end if;
5599 if Current_Verbosity = High then
5600 if Project.Object_Directory = No_Path_Information then
5602 else
5603 Write_Attr
5605 Get_Name_String (Project.Object_Directory.Display_Name));
5606 end if;
5607 end if;
5609 -- Check the exec directory
5611 -- We set the object directory to its default
5613 Project.Exec_Directory := Project.Object_Directory;
5615 if Exec_Dir.Value /= Empty_String then
5616 Get_Name_String (Exec_Dir.Value);
5618 if Name_Len = 0 then
5619 Error_Msg
5620 (Data.Flags,
5622 Exec_Dir.Location, Project);
5624 elsif Setup_Projects
5625 and then No_Sources
5626 and then Project.Extends = No_Project
5627 then
5628 -- Do not create an exec directory for a non extending project
5629 -- with no sources.
5631 Locate_Directory
5632 (Project,
5633 File_Name_Type (Exec_Dir.Value),
5634 Path => Project.Exec_Directory,
5635 Dir_Exists => Dir_Exists,
5636 Data => Data,
5637 Location => Exec_Dir.Location,
5638 Externally_Built => Project.Externally_Built);
5640 else
5641 -- We check that the specified exec directory does exist
5643 Locate_Directory
5644 (Project,
5645 File_Name_Type (Exec_Dir.Value),
5646 Path => Project.Exec_Directory,
5647 Dir_Exists => Dir_Exists,
5648 Data => Data,
5650 Location => Exec_Dir.Location,
5651 Externally_Built => Project.Externally_Built);
5653 if not Dir_Exists then
5654 if Opt.Directories_Must_Exist_In_Projects then
5655 Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value);
5656 Error_Or_Warning
5657 (Data.Flags, Data.Flags.Missing_Source_Files,
5660 else
5661 Project.Exec_Directory := No_Path_Information;
5662 end if;
5663 end if;
5664 end if;
5665 end if;
5667 if Current_Verbosity = High then
5668 if Project.Exec_Directory = No_Path_Information then
5670 else
5671 Debug_Output
5673 Name_Id (Project.Exec_Directory.Display_Name));
5674 end if;
5675 end if;
5677 -- Look for the source directories
5683 if not Source_Files.Default and then Source_Files.Values = Nil_String
5684 then
5685 Project.Source_Dirs := Nil_String;
5687 if Project.Qualifier = Standard then
5688 Error_Msg
5689 (Data.Flags,
5691 Source_Files.Location, Project);
5692 end if;
5694 elsif Source_Dirs.Default then
5696 -- No Source_Dirs specified: the single source directory is the one
5697 -- containing the project file.
5699 Remove_Source_Dirs := False;
5700 Add_To_Or_Remove_From_Source_Dirs
5701 (Path => (Name => Project.Directory.Name,
5702 Display_Name => Project.Directory.Display_Name),
5703 Rank => 1);
5705 else
5706 Remove_Source_Dirs := False;
5707 Find_Source_Dirs
5708 (Project => Project,
5709 Data => Data,
5710 Patterns => Source_Dirs.Values,
5711 Ignore => Ignore_Source_Sub_Dirs.Values,
5712 Search_For => Search_Directories,
5713 Resolve_Links => Opt.Follow_Links_For_Dirs);
5715 if Project.Source_Dirs = Nil_String
5716 and then Project.Qualifier = Standard
5717 then
5718 Error_Msg
5719 (Data.Flags,
5721 Source_Dirs.Location, Project);
5722 end if;
5723 end if;
5725 if not Excluded_Source_Dirs.Default
5726 and then Excluded_Source_Dirs.Values /= Nil_String
5727 then
5728 Remove_Source_Dirs := True;
5729 Find_Source_Dirs
5730 (Project => Project,
5731 Data => Data,
5732 Patterns => Excluded_Source_Dirs.Values,
5733 Ignore => Nil_String,
5734 Search_For => Search_Directories,
5735 Resolve_Links => Opt.Follow_Links_For_Dirs);
5736 end if;
5740 declare
5741 Current : String_List_Id := Project.Source_Dirs;
5742 Element : String_Element;
5744 begin
5745 while Current /= Nil_String loop
5746 Element := Shared.String_Elements.Table (Current);
5747 if Element.Value /= No_Name then
5748 Element.Value :=
5749 Name_Id (Canonical_Case_File_Name (Element.Value));
5750 Shared.String_Elements.Table (Current) := Element;
5751 end if;
5753 Current := Element.Next;
5754 end loop;
5755 end;
5756 end Get_Directories;
5758 ---------------
5759 -- Get_Mains --
5760 ---------------
5762 procedure Get_Mains
5763 (Project : Project_Id;
5764 Data : in out Tree_Processing_Data)
5765 is
5766 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
5768 Mains : constant Variable_Value :=
5769 Prj.Util.Value_Of
5770 (Name_Main, Project.Decl.Attributes, Shared);
5771 List : String_List_Id;
5772 Elem : String_Element;
5774 begin
5775 Project.Mains := Mains.Values;
5777 -- If no Mains were specified, and if we are an extending project,
5778 -- inherit the Mains from the project we are extending.
5780 if Mains.Default then
5781 if not Project.Library and then Project.Extends /= No_Project then
5782 Project.Mains := Project.Extends.Mains;
5783 end if;
5785 -- In a library project file, Main cannot be specified
5787 elsif Project.Library then
5788 Error_Msg
5789 (Data.Flags,
5791 Mains.Location, Project);
5793 else
5794 List := Mains.Values;
5795 while List /= Nil_String loop
5796 Elem := Shared.String_Elements.Table (List);
5798 if Length_Of_Name (Elem.Value) = 0 then
5799 Error_Msg
5800 (Data.Flags,
5802 Elem.Location, Project);
5803 exit;
5804 end if;
5806 List := Elem.Next;
5807 end loop;
5808 end if;
5809 end Get_Mains;
5811 ---------------------------
5812 -- Get_Sources_From_File --
5813 ---------------------------
5815 procedure Get_Sources_From_File
5816 (Path : String;
5817 Location : Source_Ptr;
5818 Project : in out Project_Processing_Data;
5819 Data : in out Tree_Processing_Data)
5820 is
5821 File : Prj.Util.Text_File;
5822 Line : String (1 .. 250);
5823 Last : Natural;
5824 Source_Name : File_Name_Type;
5825 Name_Loc : Name_Location;
5827 begin
5828 if Current_Verbosity = High then
5830 end if;
5832 -- Open the file
5834 Prj.Util.Open (File, Path);
5836 if not Prj.Util.Is_Valid (File) then
5837 Error_Msg
5838 (Data.Flags, "file does not exist", Location, Project.Project);
5840 else
5841 -- Read the lines one by one
5843 while not Prj.Util.End_Of_File (File) loop
5844 Prj.Util.Get_Line (File, Line, Last);
5846 -- A non empty, non comment line should contain a file name
5848 if Last /= 0 and then (Last = 1 or else Line (1 .. 2) /= "--") then
5849 Name_Len := Last;
5850 Name_Buffer (1 .. Name_Len) := Line (1 .. Last);
5851 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
5852 Source_Name := Name_Find;
5854 -- Check that there is no directory information
5856 for J in 1 .. Last loop
5857 if Is_Directory_Separator (Line (J)) then
5858 Error_Msg_File_1 := Source_Name;
5859 Error_Msg
5860 (Data.Flags,
5861 "file name cannot include directory information ({)",
5862 Location, Project.Project);
5863 exit;
5864 end if;
5865 end loop;
5867 Name_Loc := Source_Names_Htable.Get
5868 (Project.Source_Names, Source_Name);
5870 if Name_Loc = No_Name_Location then
5871 Name_Loc :=
5872 (Name => Source_Name,
5873 Location => Location,
5874 Source => No_Source,
5875 Listed => True,
5876 Found => False);
5878 else
5879 Name_Loc.Listed := True;
5880 end if;
5882 Source_Names_Htable.Set
5883 (Project.Source_Names, Source_Name, Name_Loc);
5884 end if;
5885 end loop;
5887 Prj.Util.Close (File);
5889 end if;
5890 end Get_Sources_From_File;
5892 ------------------
5893 -- No_Space_Img --
5894 ------------------
5896 function No_Space_Img (N : Natural) return String is
5897 Image : constant String := N'Img;
5898 begin
5899 return Image (2 .. Image'Last);
5900 end No_Space_Img;
5902 -----------------------
5903 -- Compute_Unit_Name --
5904 -----------------------
5906 procedure Compute_Unit_Name
5907 (File_Name : File_Name_Type;
5908 Naming : Lang_Naming_Data;
5909 Kind : out Source_Kind;
5910 Unit : out Name_Id;
5911 Project : Project_Processing_Data)
5912 is
5913 Filename : constant String := Get_Name_String (File_Name);
5914 Last : Integer := Filename'Last;
5915 Sep_Len : Integer;
5916 Body_Len : Integer;
5917 Spec_Len : Integer;
5919 Unit_Except : Unit_Exception;
5920 Masked : Boolean := False;
5922 begin
5923 Unit := No_Name;
5924 Kind := Spec;
5926 if Naming.Separate_Suffix = No_File
5927 or else Naming.Body_Suffix = No_File
5928 or else Naming.Spec_Suffix = No_File
5929 then
5930 return;
5931 end if;
5933 if Naming.Dot_Replacement = No_File then
5934 Debug_Output ("no dot_replacement specified");
5935 return;
5936 end if;
5938 Sep_Len := Integer (Length_Of_Name (Naming.Separate_Suffix));
5939 Spec_Len := Integer (Length_Of_Name (Naming.Spec_Suffix));
5940 Body_Len := Integer (Length_Of_Name (Naming.Body_Suffix));
5942 -- Choose the longest suffix that matches. If there are several matches,
5943 -- give priority to specs, then bodies, then separates.
5945 if Naming.Separate_Suffix /= Naming.Body_Suffix
5946 and then Suffix_Matches (Filename, Naming.Separate_Suffix)
5947 then
5948 Last := Filename'Last - Sep_Len;
5949 Kind := Sep;
5950 end if;
5952 if Filename'Last - Body_Len <= Last
5953 and then Suffix_Matches (Filename, Naming.Body_Suffix)
5954 then
5955 Last := Natural'Min (Last, Filename'Last - Body_Len);
5956 Kind := Impl;
5957 end if;
5959 if Filename'Last - Spec_Len <= Last
5960 and then Suffix_Matches (Filename, Naming.Spec_Suffix)
5961 then
5962 Last := Natural'Min (Last, Filename'Last - Spec_Len);
5963 Kind := Spec;
5964 end if;
5966 if Last = Filename'Last then
5967 Debug_Output ("no matching suffix");
5968 return;
5969 end if;
5971 -- Check that the casing matches
5973 if File_Names_Case_Sensitive then
5974 case Naming.Casing is
5975 when All_Lower_Case =>
5976 for J in Filename'First .. Last loop
5977 if Is_Letter (Filename (J))
5978 and then not Is_Lower (Filename (J))
5979 then
5980 Debug_Output ("invalid casing");
5981 return;
5982 end if;
5983 end loop;
5985 when All_Upper_Case =>
5986 for J in Filename'First .. Last loop
5987 if Is_Letter (Filename (J))
5988 and then not Is_Upper (Filename (J))
5989 then
5990 Debug_Output ("invalid casing");
5991 return;
5992 end if;
5993 end loop;
5995 when Mixed_Case | Unknown =>
5996 null;
5997 end case;
5998 end if;
6000 -- If Dot_Replacement is not a single dot, then there should not
6001 -- be any dot in the name.
6003 declare
6004 Dot_Repl : constant String :=
6005 Get_Name_String (Naming.Dot_Replacement);
6007 begin
6008 if Dot_Repl /= "." then
6009 for Index in Filename'First .. Last loop
6011 Debug_Output ("invalid name, contains dot");
6012 return;
6013 end if;
6014 end loop;
6016 Replace_Into_Name_Buffer
6019 else
6020 Name_Len := Last - Filename'First + 1;
6021 Name_Buffer (1 .. Name_Len) := Filename (Filename'First .. Last);
6022 Fixed.Translate
6023 (Source => Name_Buffer (1 .. Name_Len),
6024 Mapping => Lower_Case_Map);
6025 end if;
6026 end;
6028 -- In the standard GNAT naming scheme, check for special cases: children
6029 -- or separates of A, G, I or S, and run time sources.
6031 if Is_Standard_GNAT_Naming (Naming) and then Name_Len >= 3 then
6032 declare
6033 S1 : constant Character := Name_Buffer (1);
6034 S2 : constant Character := Name_Buffer (2);
6035 S3 : constant Character := Name_Buffer (3);
6037 begin
6040 -- Children or separates of packages A, G, I or S. These names
6041 -- are x__ ... or x~... (where x is a, g, i, or s). Both
6042 -- versions (x__... and x~...) are allowed in all platforms,
6043 -- because it is not possible to know the platform before
6044 -- processing of the project files.
6048 Name_Buffer (3 .. Name_Len - 1) :=
6049 Name_Buffer (4 .. Name_Len);
6050 Name_Len := Name_Len - 1;
6057 -- If it is potentially a run time source
6059 null;
6060 end if;
6061 end if;
6062 end;
6063 end if;
6065 -- Name_Buffer contains the name of the unit in lower-cases. Check
6066 -- that this is a valid unit name
6068 Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit);
6070 -- If there is a naming exception for the same unit, the file is not
6071 -- a source for the unit.
6073 if Unit /= No_Name then
6074 Unit_Except :=
6075 Unit_Exceptions_Htable.Get (Project.Unit_Exceptions, Unit);
6077 if Kind = Spec then
6078 Masked := Unit_Except.Spec /= No_File
6079 and then
6080 Unit_Except.Spec /= File_Name;
6081 else
6082 Masked := Unit_Except.Impl /= No_File
6083 and then
6084 Unit_Except.Impl /= File_Name;
6085 end if;
6087 if Masked then
6088 if Current_Verbosity = High then
6089 Debug_Indent;
6090 Write_Str (" """ & Filename & """ contains the ");
6092 if Kind = Spec then
6093 Write_Str ("spec of a unit found in """);
6094 Write_Str (Get_Name_String (Unit_Except.Spec));
6095 else
6096 Write_Str ("body of a unit found in """);
6097 Write_Str (Get_Name_String (Unit_Except.Impl));
6098 end if;
6100 Write_Line (""" (ignored)");
6101 end if;
6103 Unit := No_Name;
6104 end if;
6105 end if;
6107 if Unit /= No_Name and then Current_Verbosity = High then
6108 case Kind is
6109 when Spec => Debug_Output ("spec of", Unit);
6110 when Impl => Debug_Output ("body of", Unit);
6111 when Sep => Debug_Output ("sep of", Unit);
6112 end case;
6113 end if;
6114 end Compute_Unit_Name;
6116 --------------------------
6117 -- Check_Illegal_Suffix --
6118 --------------------------
6120 procedure Check_Illegal_Suffix
6121 (Project : Project_Id;
6122 Suffix : File_Name_Type;
6123 Dot_Replacement : File_Name_Type;
6124 Attribute_Name : String;
6125 Location : Source_Ptr;
6126 Data : in out Tree_Processing_Data)
6127 is
6128 Suffix_Str : constant String := Get_Name_String (Suffix);
6130 begin
6131 if Suffix_Str'Length = 0 then
6133 -- Always valid
6135 return;
6137 elsif Index (Suffix_Str, ".") = 0 then
6138 Err_Vars.Error_Msg_File_1 := Suffix;
6139 Error_Msg
6140 (Data.Flags,
6141 "{ is illegal for " & Attribute_Name & ": must have a dot",
6142 Location, Project);
6143 return;
6144 end if;
6146 -- Case of dot replacement is a single dot, and first character of
6147 -- suffix is also a dot.
6149 if Dot_Replacement /= No_File
6150 and then Get_Name_String (Dot_Replacement) = "."
6152 then
6153 for Index in Suffix_Str'First + 1 .. Suffix_Str'Last loop
6155 -- If there are multiple dots in the name
6159 -- It is illegal to have a letter following the initial dot
6161 if Is_Letter (Suffix_Str (Suffix_Str'First + 1)) then
6162 Err_Vars.Error_Msg_File_1 := Suffix;
6163 Error_Msg
6164 (Data.Flags,
6165 "{ is illegal for " & Attribute_Name
6166 & ": ambiguous prefix when Dot_Replacement is a dot",
6167 Location, Project);
6168 end if;
6169 return;
6170 end if;
6171 end loop;
6172 end if;
6173 end Check_Illegal_Suffix;
6175 ----------------------
6176 -- Locate_Directory --
6177 ----------------------
6179 procedure Locate_Directory
6180 (Project : Project_Id;
6181 Name : File_Name_Type;
6182 Path : out Path_Information;
6183 Dir_Exists : out Boolean;
6184 Data : in out Tree_Processing_Data;
6185 Create : String := "";
6186 Location : Source_Ptr := No_Location;
6187 Must_Exist : Boolean := True;
6188 Externally_Built : Boolean := False)
6189 is
6190 Parent : constant Path_Name_Type :=
6191 Project.Directory.Display_Name;
6192 The_Parent : constant String :=
6193 Get_Name_String (Parent);
6194 The_Parent_Last : constant Natural :=
6195 Compute_Directory_Last (The_Parent);
6196 Full_Name : File_Name_Type;
6197 The_Name : File_Name_Type;
6199 begin
6200 Get_Name_String (Name);
6202 -- Add Subdirs.all if it is a directory that may be created and
6203 -- Subdirs is not null;
6205 if Create /= "" and then Subdirs /= null then
6206 if Name_Buffer (Name_Len) /= Directory_Separator then
6207 Add_Char_To_Name_Buffer (Directory_Separator);
6208 end if;
6210 Add_Str_To_Name_Buffer (Subdirs.all);
6211 end if;
6215 for J in 1 .. Name_Len loop
6217 Name_Buffer (J) := Directory_Separator;
6218 end if;
6219 end loop;
6221 The_Name := Name_Find;
6223 if Current_Verbosity = High then
6224 Debug_Indent;
6225 Write_Str ("Locate_Directory (""");
6226 Write_Str (Get_Name_String (The_Name));
6227 Write_Str (""", in """);
6228 Write_Str (The_Parent);
6229 Write_Line (""")");
6230 end if;
6232 Path := No_Path_Information;
6233 Dir_Exists := False;
6235 if Is_Absolute_Path (Get_Name_String (The_Name)) then
6236 Full_Name := The_Name;
6238 else
6239 Name_Len := 0;
6240 Add_Str_To_Name_Buffer
6241 (The_Parent (The_Parent'First .. The_Parent_Last));
6242 Add_Str_To_Name_Buffer (Get_Name_String (The_Name));
6243 Full_Name := Name_Find;
6244 end if;
6246 declare
6247 Full_Path_Name : String_Access :=
6250 begin
6253 then
6256 -- If project is externally built, do not create a subdir,
6257 -- use the specified directory, without the subdir.
6263 else
6265 Add_Str_To_Name_Buffer
6272 else
6273 begin
6274 Create_Path (Full_Path_Name.all);
6276 if not Quiet_Output then
6277 Write_Str (Create);
6278 Write_Str (" directory """);
6279 Write_Str (Full_Path_Name.all);
6280 Write_Str (""" created for project ");
6281 Write_Line (Get_Name_String (Project.Name));
6282 end if;
6284 exception
6285 when Use_Error =>
6287 -- Output message with name of directory. Note that we
6288 -- use the ~ insertion method here in case the name
6289 -- has special characters in it.
6291 Error_Msg_Strlen := Full_Path_Name'Length;
6292 Error_Msg_String (1 .. Error_Msg_Strlen) :=
6293 Full_Path_Name.all;
6294 Error_Msg
6295 (Data.Flags,
6296 "could not create " & Create & " directory ~",
6297 Location,
6298 Project);
6299 end;
6300 end if;
6301 end if;
6302 end if;
6304 Dir_Exists := Is_Directory (Full_Path_Name.all);
6306 if not Must_Exist or Dir_Exists then
6307 declare
6308 Normed : constant String :=
6309 Normalize_Pathname
6310 (Full_Path_Name.all,
6311 Directory =>
6312 The_Parent (The_Parent'First .. The_Parent_Last),
6313 Resolve_Links => False,
6314 Case_Sensitive => True);
6316 Canonical_Path : constant String :=
6317 Normalize_Pathname
6318 (Normed,
6319 Directory =>
6320 The_Parent
6321 (The_Parent'First .. The_Parent_Last),
6322 Resolve_Links =>
6323 Opt.Follow_Links_For_Dirs,
6324 Case_Sensitive => False);
6326 begin
6327 Name_Len := Normed'Length;
6328 Name_Buffer (1 .. Name_Len) := Normed;
6330 -- Directories should always end with a directory separator
6332 if Name_Buffer (Name_Len) /= Directory_Separator then
6333 Add_Char_To_Name_Buffer (Directory_Separator);
6334 end if;
6336 Path.Display_Name := Name_Find;
6338 Name_Len := Canonical_Path'Length;
6339 Name_Buffer (1 .. Name_Len) := Canonical_Path;
6341 if Name_Buffer (Name_Len) /= Directory_Separator then
6342 Add_Char_To_Name_Buffer (Directory_Separator);
6343 end if;
6345 Path.Name := Name_Find;
6346 end;
6347 end if;
6349 Free (Full_Path_Name);
6350 end;
6351 end Locate_Directory;
6353 ---------------------------
6354 -- Find_Excluded_Sources --
6355 ---------------------------
6357 procedure Find_Excluded_Sources
6358 (Project : in out Project_Processing_Data;
6359 Data : in out Tree_Processing_Data)
6360 is
6361 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
6363 Excluded_Source_List_File : constant Variable_Value :=
6364 Util.Value_Of
6365 (Name_Excluded_Source_List_File,
6366 Project.Project.Decl.Attributes,
6367 Shared);
6368 Excluded_Sources : Variable_Value := Util.Value_Of
6369 (Name_Excluded_Source_Files,
6370 Project.Project.Decl.Attributes,
6371 Shared);
6373 Current : String_List_Id;
6374 Element : String_Element;
6375 Location : Source_Ptr;
6376 Name : File_Name_Type;
6377 File : Prj.Util.Text_File;
6378 Line : String (1 .. 300);
6379 Last : Natural;
6380 Locally_Removed : Boolean := False;
6382 begin
6383 -- If Excluded_Source_Files is not declared, check Locally_Removed_Files
6385 if Excluded_Sources.Default then
6386 Locally_Removed := True;
6387 Excluded_Sources :=
6388 Util.Value_Of
6389 (Name_Locally_Removed_Files,
6390 Project.Project.Decl.Attributes, Shared);
6391 end if;
6393 -- If there are excluded sources, put them in the table
6395 if not Excluded_Sources.Default then
6396 if not Excluded_Source_List_File.Default then
6397 if Locally_Removed then
6398 Error_Msg
6399 (Data.Flags,
6400 "?both attributes Locally_Removed_Files and " &
6401 "Excluded_Source_List_File are present",
6402 Excluded_Source_List_File.Location, Project.Project);
6403 else
6404 Error_Msg
6405 (Data.Flags,
6406 "?both attributes Excluded_Source_Files and " &
6407 "Excluded_Source_List_File are present",
6408 Excluded_Source_List_File.Location, Project.Project);
6409 end if;
6410 end if;
6412 Current := Excluded_Sources.Values;
6413 while Current /= Nil_String loop
6414 Element := Shared.String_Elements.Table (Current);
6415 Name := Canonical_Case_File_Name (Element.Value);
6417 -- If the element has no location, then use the location of
6418 -- Excluded_Sources to report possible errors.
6420 if Element.Location = No_Location then
6421 Location := Excluded_Sources.Location;
6422 else
6423 Location := Element.Location;
6424 end if;
6426 Excluded_Sources_Htable.Set
6427 (Project.Excluded, Name,
6428 (Name, No_File, 0, False, Location));
6429 Current := Element.Next;
6430 end loop;
6432 elsif not Excluded_Source_List_File.Default then
6433 Location := Excluded_Source_List_File.Location;
6435 declare
6436 Source_File_Name : constant File_Name_Type :=
6437 File_Name_Type
6438 (Excluded_Source_List_File.Value);
6439 Source_File_Line : Natural := 0;
6441 Source_File_Path_Name : constant String :=
6442 Path_Name_Of
6443 (Source_File_Name,
6444 Project.Project.Directory.Name);
6446 begin
6447 if Source_File_Path_Name'Length = 0 then
6448 Err_Vars.Error_Msg_File_1 :=
6449 File_Name_Type (Excluded_Source_List_File.Value);
6450 Error_Msg
6451 (Data.Flags,
6452 "file with excluded sources { does not exist",
6453 Excluded_Source_List_File.Location, Project.Project);
6455 else
6456 -- Open the file
6458 Prj.Util.Open (File, Source_File_Path_Name);
6460 if not Prj.Util.Is_Valid (File) then
6461 Error_Msg
6462 (Data.Flags, "file does not exist",
6463 Location, Project.Project);
6464 else
6465 -- Read the lines one by one
6467 while not Prj.Util.End_Of_File (File) loop
6468 Prj.Util.Get_Line (File, Line, Last);
6469 Source_File_Line := Source_File_Line + 1;
6471 -- Non empty, non comment line should contain a file name
6473 if Last /= 0
6474 and then (Last = 1 or else Line (1 .. 2) /= "--")
6475 then
6476 Name_Len := Last;
6477 Name_Buffer (1 .. Name_Len) := Line (1 .. Last);
6478 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
6479 Name := Name_Find;
6481 -- Check that there is no directory information
6483 for J in 1 .. Last loop
6484 if Is_Directory_Separator (Line (J)) then
6485 Error_Msg_File_1 := Name;
6486 Error_Msg
6487 (Data.Flags,
6488 "file name cannot include "
6489 & "directory information ({)",
6490 Location, Project.Project);
6491 exit;
6492 end if;
6493 end loop;
6495 Excluded_Sources_Htable.Set
6496 (Project.Excluded,
6497 Name,
6498 (Name, Source_File_Name, Source_File_Line,
6499 False, Location));
6500 end if;
6501 end loop;
6503 Prj.Util.Close (File);
6504 end if;
6505 end if;
6506 end;
6507 end if;
6508 end Find_Excluded_Sources;
6510 ------------------
6511 -- Find_Sources --
6512 ------------------
6514 procedure Find_Sources
6515 (Project : in out Project_Processing_Data;
6516 Data : in out Tree_Processing_Data)
6517 is
6518 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
6520 Sources : constant Variable_Value :=
6521 Util.Value_Of
6522 (Name_Source_Files,
6523 Project.Project.Decl.Attributes,
6524 Shared);
6526 Source_List_File : constant Variable_Value :=
6527 Util.Value_Of
6528 (Name_Source_List_File,
6529 Project.Project.Decl.Attributes,
6530 Shared);
6532 Name_Loc : Name_Location;
6533 Has_Explicit_Sources : Boolean;
6535 begin
6536 pragma Assert (Sources.Kind = List, "Source_Files is not a list");
6537 pragma Assert
6538 (Source_List_File.Kind = Single,
6539 "Source_List_File is not a single string");
6541 Project.Source_List_File_Location := Source_List_File.Location;
6543 -- If the user has specified a Source_Files attribute
6545 if not Sources.Default then
6546 if not Source_List_File.Default then
6547 Error_Msg
6548 (Data.Flags,
6549 "?both attributes source_files and " &
6550 "source_list_file are present",
6551 Source_List_File.Location, Project.Project);
6552 end if;
6554 -- Sources is a list of file names
6556 declare
6557 Current : String_List_Id := Sources.Values;
6558 Element : String_Element;
6559 Location : Source_Ptr;
6560 Name : File_Name_Type;
6562 begin
6563 if Current = Nil_String then
6564 Project.Project.Languages := No_Language_Index;
6566 -- This project contains no source. For projects that don't
6567 -- extend other projects, this also means that there is no
6568 -- need for an object directory, if not specified.
6570 if Project.Project.Extends = No_Project
6571 and then
6572 Project.Project.Object_Directory = Project.Project.Directory
6573 and then not (Project.Project.Qualifier = Aggregate_Library)
6574 then
6575 Project.Project.Object_Directory := No_Path_Information;
6576 end if;
6577 end if;
6579 while Current /= Nil_String loop
6580 Element := Shared.String_Elements.Table (Current);
6581 Name := Canonical_Case_File_Name (Element.Value);
6582 Get_Name_String (Element.Value);
6584 -- If the element has no location, then use the location of
6585 -- Sources to report possible errors.
6587 if Element.Location = No_Location then
6588 Location := Sources.Location;
6589 else
6590 Location := Element.Location;
6591 end if;
6593 -- Check that there is no directory information
6595 for J in 1 .. Name_Len loop
6596 if Is_Directory_Separator (Name_Buffer (J)) then
6597 Error_Msg_File_1 := Name;
6598 Error_Msg
6599 (Data.Flags,
6600 "file name cannot include directory " &
6601 "information ({)",
6602 Location, Project.Project);
6603 exit;
6604 end if;
6605 end loop;
6607 -- Check whether the file is already there: the same file name
6608 -- may be in the list. If the source is missing, the error will
6609 -- be on the first mention of the source file name.
6611 Name_Loc := Source_Names_Htable.Get
6612 (Project.Source_Names, Name);
6614 if Name_Loc = No_Name_Location then
6615 Name_Loc :=
6616 (Name => Name,
6617 Location => Location,
6618 Source => No_Source,
6619 Listed => True,
6620 Found => False);
6622 else
6623 Name_Loc.Listed := True;
6624 end if;
6626 Source_Names_Htable.Set
6627 (Project.Source_Names, Name, Name_Loc);
6629 Current := Element.Next;
6630 end loop;
6632 Has_Explicit_Sources := True;
6633 end;
6635 -- If we have no Source_Files attribute, check the Source_List_File
6636 -- attribute.
6638 elsif not Source_List_File.Default then
6640 -- Source_List_File is the name of the file that contains the source
6641 -- file names.
6643 declare
6644 Source_File_Path_Name : constant String :=
6645 Path_Name_Of
6646 (File_Name_Type
6647 (Source_List_File.Value),
6648 Project.Project.
6649 Directory.Display_Name);
6651 begin
6652 Has_Explicit_Sources := True;
6654 if Source_File_Path_Name'Length = 0 then
6655 Err_Vars.Error_Msg_File_1 :=
6656 File_Name_Type (Source_List_File.Value);
6657 Error_Msg
6658 (Data.Flags,
6659 "file with sources { does not exist",
6660 Source_List_File.Location, Project.Project);
6662 else
6663 Get_Sources_From_File
6664 (Source_File_Path_Name, Source_List_File.Location,
6665 Project, Data);
6666 end if;
6667 end;
6669 else
6670 -- Neither Source_Files nor Source_List_File has been specified. Find
6671 -- all the files that satisfy the naming scheme in all the source
6672 -- directories.
6674 Has_Explicit_Sources := False;
6675 end if;
6677 -- Remove any exception that is not in the specified list of sources
6679 if Has_Explicit_Sources then
6680 declare
6681 Source : Source_Id;
6682 Iter : Source_Iterator;
6683 NL : Name_Location;
6684 Again : Boolean;
6685 begin
6686 Iter_Loop :
6687 loop
6688 Again := False;
6689 Iter := For_Each_Source (Data.Tree, Project.Project);
6691 Source_Loop :
6692 loop
6693 Source := Prj.Element (Iter);
6694 exit Source_Loop when Source = No_Source;
6696 if Source.Naming_Exception /= No then
6697 NL := Source_Names_Htable.Get
6698 (Project.Source_Names, Source.File);
6700 if NL /= No_Name_Location and then not NL.Listed then
6702 -- Remove the exception
6704 Source_Names_Htable.Set
6705 (Project.Source_Names,
6706 Source.File,
6707 No_Name_Location);
6708 Remove_Source (Data.Tree, Source, No_Source);
6710 if Source.Naming_Exception = Yes then
6711 Error_Msg_Name_1 := Name_Id (Source.File);
6712 Error_Msg
6713 (Data.Flags,
6714 "? unknown source file %%",
6715 NL.Location,
6716 Project.Project);
6717 end if;
6719 Again := True;
6720 exit Source_Loop;
6721 end if;
6722 end if;
6724 Next (Iter);
6725 end loop Source_Loop;
6727 exit Iter_Loop when not Again;
6728 end loop Iter_Loop;
6729 end;
6730 end if;
6732 Search_Directories
6733 (Project,
6734 Data => Data,
6735 For_All_Sources => Sources.Default and then Source_List_File.Default);
6737 -- Check if all exceptions have been found
6739 declare
6740 Source : Source_Id;
6741 Iter : Source_Iterator;
6742 Found : Boolean := False;
6744 begin
6745 Iter := For_Each_Source (Data.Tree, Project.Project);
6746 loop
6747 Source := Prj.Element (Iter);
6748 exit when Source = No_Source;
6750 -- If the full source path is unknown for this source_id, there
6751 -- could be several reasons:
6752 -- * we simply did not find the file itself, this is an error
6753 -- * we have a multi-unit source file. Another Source_Id from
6754 -- the same file has received the full path, so we need to
6755 -- propagate it.
6757 if Source.Path = No_Path_Information then
6758 if Source.Naming_Exception = Yes then
6759 if Source.Unit /= No_Unit_Index then
6760 Found := False;
6762 if Source.Index /= 0 then -- Only multi-unit files
6763 declare
6764 S : Source_Id :=
6765 Source_Files_Htable.Get
6766 (Data.Tree.Source_Files_HT, Source.File);
6768 begin
6769 while S /= null loop
6770 if S.Path /= No_Path_Information then
6771 Source.Path := S.Path;
6772 Found := True;
6774 if Current_Verbosity = High then
6775 Debug_Output
6776 ("setting full path for "
6777 & Get_Name_String (Source.File)
6778 & " at" & Source.Index'Img
6779 & " to "
6780 & Get_Name_String (Source.Path.Name));
6781 end if;
6783 exit;
6784 end if;
6786 S := S.Next_With_File_Name;
6787 end loop;
6788 end;
6789 end if;
6791 if not Found then
6792 Error_Msg_Name_1 := Name_Id (Source.Display_File);
6793 Error_Msg_Name_2 := Source.Unit.Name;
6794 Error_Or_Warning
6795 (Data.Flags, Data.Flags.Missing_Source_Files,
6797 No_Location, Project.Project);
6798 end if;
6799 end if;
6801 if Source.Path = No_Path_Information then
6802 Remove_Source (Data.Tree, Source, No_Source);
6803 end if;
6805 elsif Source.Naming_Exception = Inherited then
6806 Remove_Source (Data.Tree, Source, No_Source);
6807 end if;
6808 end if;
6810 Next (Iter);
6811 end loop;
6812 end;
6814 -- It is an error if a source file name in a source list or in a source
6815 -- list file is not found.
6817 if Has_Explicit_Sources then
6818 declare
6819 NL : Name_Location;
6820 First_Error : Boolean;
6822 begin
6823 NL := Source_Names_Htable.Get_First (Project.Source_Names);
6824 First_Error := True;
6825 while NL /= No_Name_Location loop
6826 if not NL.Found then
6827 Err_Vars.Error_Msg_File_1 := NL.Name;
6828 if First_Error then
6829 Error_Or_Warning
6830 (Data.Flags, Data.Flags.Missing_Source_Files,
6831 "source file { not found",
6832 NL.Location, Project.Project);
6833 First_Error := False;
6834 else
6835 Error_Or_Warning
6836 (Data.Flags, Data.Flags.Missing_Source_Files,
6838 NL.Location, Project.Project);
6839 end if;
6840 end if;
6842 NL := Source_Names_Htable.Get_Next (Project.Source_Names);
6843 end loop;
6844 end;
6845 end if;
6846 end Find_Sources;
6848 ----------------
6849 -- Initialize --
6850 ----------------
6852 procedure Initialize
6853 (Data : out Tree_Processing_Data;
6854 Tree : Project_Tree_Ref;
6855 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
6856 Flags : Prj.Processing_Flags)
6857 is
6858 begin
6859 Data.Tree := Tree;
6860 Data.Node_Tree := Node_Tree;
6861 Data.Flags := Flags;
6862 end Initialize;
6864 ----------
6865 -- Free --
6866 ----------
6868 procedure Free (Data : in out Tree_Processing_Data) is
6869 pragma Unreferenced (Data);
6870 begin
6871 null;
6872 end Free;
6874 ----------------
6875 -- Initialize --
6876 ----------------
6878 procedure Initialize
6879 (Data : in out Project_Processing_Data;
6880 Project : Project_Id)
6881 is
6882 begin
6883 Data.Project := Project;
6884 end Initialize;
6886 ----------
6887 -- Free --
6888 ----------
6890 procedure Free (Data : in out Project_Processing_Data) is
6891 begin
6892 Source_Names_Htable.Reset (Data.Source_Names);
6893 Unit_Exceptions_Htable.Reset (Data.Unit_Exceptions);
6894 Excluded_Sources_Htable.Reset (Data.Excluded);
6895 end Free;
6897 -------------------------------
6898 -- Check_File_Naming_Schemes --
6899 -------------------------------
6901 procedure Check_File_Naming_Schemes
6902 (Project : Project_Processing_Data;
6903 File_Name : File_Name_Type;
6904 Alternate_Languages : out Language_List;
6905 Language : out Language_Ptr;
6906 Display_Language_Name : out Name_Id;
6907 Unit : out Name_Id;
6908 Lang_Kind : out Language_Kind;
6909 Kind : out Source_Kind)
6910 is
6911 Filename : constant String := Get_Name_String (File_Name);
6912 Config : Language_Config;
6913 Tmp_Lang : Language_Ptr;
6915 Header_File : Boolean := False;
6916 -- True if we found at least one language for which the file is a header
6917 -- In such a case, we search for all possible languages where this is
6918 -- also a header (C and C++ for instance), since the file might be used
6919 -- for several such languages.
6921 procedure Check_File_Based_Lang;
6922 -- Does the naming scheme test for file-based languages. For those,
6923 -- there is no Unit. Just check if the file name has the implementation
6924 -- or, if it is specified, the template suffix of the language.
6925 --
6926 -- Returns True if the file belongs to the current language and we
6927 -- should stop searching for matching languages. Not that a given header
6928 -- file could belong to several languages (C and C++ for instance). Thus
6929 -- if we found a header we'll check whether it matches other languages.
6931 ---------------------------
6932 -- Check_File_Based_Lang --
6933 ---------------------------
6935 procedure Check_File_Based_Lang is
6936 begin
6937 if not Header_File
6938 and then Suffix_Matches (Filename, Config.Naming_Data.Body_Suffix)
6939 then
6940 Unit := No_Name;
6941 Kind := Impl;
6942 Language := Tmp_Lang;
6944 Debug_Output
6945 ("implementation of language ", Display_Language_Name);
6947 elsif Suffix_Matches (Filename, Config.Naming_Data.Spec_Suffix) then
6948 Debug_Output
6949 ("header of language ", Display_Language_Name);
6951 if Header_File then
6952 Alternate_Languages := new Language_List_Element'
6956 else
6965 -- Start of processing for Check_File_Naming_Schemes
6967 begin
6978 Debug_Output
6990 Check_File_Based_Lang;
6995 -- We know it belongs to a least a file_based language, no
6996 -- need to check unit-based ones.
6999 Compute_Unit_Name
7021 -------------------
7022 -- Override_Kind --
7023 -------------------
7026 begin
7027 -- If the file was previously already associated with a unit, change it
7032 then
7033 -- If we had another file referencing the same unit (for instance it
7034 -- was in an extended project), that source file is in fact invisible
7035 -- from now on, and in particular doesn't belong to the same unit.
7036 -- If the source is an inherited naming exception, then it may not
7037 -- really exist: the source potentially replaced is left untouched.
7058 else
7064 ----------------
7065 -- Check_File --
7066 ----------------
7068 procedure Check_File
7078 is
7080 Source_Names_Htable.Get
7092 begin
7094 Debug_Increase_Indent
7102 else
7105 -- Check if it is OK to have the same file name in several
7106 -- source directories.
7110 then
7112 Error_Msg
7118 else
7121 Source_Names_Htable.Set
7127 else
7128 -- Set the full path for the source_id (which might have been
7129 -- created when parsing the naming exceptions, and therefore
7130 -- might not have the full path).
7131 -- We only set this for this source_id, but not for other
7132 -- source_id in the same file (case of multi-unit source files)
7133 -- For the latter, they will be set in Find_Sources when we
7134 -- check that all source_id have known full paths.
7135 -- Doing this later saves one htable lookup per file in the
7136 -- common case where the user is not using multi-unit files.
7140 Source_Paths_Htable.Set
7143 -- Check if this is a subunit
7147 then
7156 -- If this is an inherited naming exception, make sure that
7157 -- the naming exception it replaces is no longer a source.
7160 declare
7164 begin
7192 Units_Htable.Set
7203 Check_File_Naming_Schemes
7215 -- A file name in a list must be a source of a language
7218 then
7220 Error_Msg
7226 else
7227 Add_Source
7241 -- If it is a source specified in a list, update the entry in
7242 -- the Source_Names table.
7246 Source_Names_Htable.Set
7252 Debug_Decrease_Indent;
7255 ---------------------------------
7256 -- Expand_Subdirectory_Pattern --
7257 ---------------------------------
7259 procedure Expand_Subdirectory_Pattern
7266 is
7276 -- Hash table stores recursive source directories, to avoid looking
7277 -- several times, and to avoid cycles that may be introduced by symbolic
7278 -- links.
7281 -- Pattern to use when matching file names
7285 procedure Find_Pattern
7289 -- Find a specific pattern
7291 function Recursive_Find_Dirs
7294 -- Search all the subdirectories (recursively) of Path.
7295 -- Return True if at least one file or directory was processed
7297 function Subdirectory_Matches
7300 -- Called when a matching directory was found. If the user is in fact
7301 -- searching for files, we then search for those files matching the
7302 -- pattern within the directory.
7303 -- Return True if at least one file or directory was processed
7305 --------------------------
7306 -- Subdirectory_Matches --
7307 --------------------------
7309 function Subdirectory_Matches
7312 is
7319 begin
7327 loop
7334 then
7353 -------------------------
7354 -- Recursive_Find_Dirs --
7355 -------------------------
7357 function Recursive_Find_Dirs
7360 is
7367 begin
7380 loop
7385 declare
7387 Normalize_Pathname
7396 begin
7399 declare
7403 begin
7407 Get_Name_String
7409 Canonical_Case_File_Name
7426 Success :=
7438 exception
7443 ------------------
7444 -- Find_Pattern --
7445 ------------------
7447 procedure Find_Pattern
7451 is
7461 begin
7464 -- If we are looking for files, find the pattern for the files
7469 loop
7475 Error_Or_Warning
7482 Debug_Indent;
7489 File_Pattern := Compile
7494 -- If we had just "*.gpr", this is equivalent to "./*.gpr"
7501 Recursive :=
7504 and then
7519 Locate_Directory
7529 Error_Or_Warning
7537 -- Links have been resolved if necessary, and Path_Name
7538 -- always ends with a directory separator.
7542 else
7553 Error_Or_Warning
7563 -- Local variables
7569 -- Start of processing for Expand_Subdirectory_Pattern
7571 begin
7582 ------------------------
7583 -- Search_Directories --
7584 ------------------------
7586 procedure Search_Directories
7590 is
7603 begin
7606 -- Loop through subdirectories
7612 begin
7616 -- Use Element.Value in this test, not Display_Value, because we
7617 -- want the symbolic links to be resolved when appropriate.
7620 declare
7629 Get_Name_String
7632 -- Display_Source_Directory is to allow us to open a UTF-8
7633 -- encoded directory on Windows.
7635 begin
7637 Debug_Increase_Indent
7643 -- We look to every entry in the source directory
7647 loop
7651 -- In fast project loading mode (without -eL), the user
7652 -- guarantees that no directory has a name which is a
7653 -- valid source name, so we can avoid doing a system call
7654 -- here. This provides a very significant speed up on
7655 -- slow file systems (remote files for instance).
7658 or else Is_Regular_File
7660 then
7667 else
7668 Canonical_Case_File_Name
7673 declare
7675 Normalize_Pathname
7677 Directory =>
7678 Source_Directory
7680 Dir_Last),
7681 Resolve_Links =>
7687 Excluded_Sources_Htable.Get
7691 begin
7697 else
7698 Canonical_Case_File_Name
7706 Excluded_Sources_Htable.Set
7709 Debug_Output
7713 -- Will mark the file as removed, but we
7714 -- still need to add it to the list: if we
7715 -- don't, the file will not appear in the
7716 -- mapping file and will cause the compiler
7717 -- to fail.
7723 -- Preserve the user's original casing and use of
7724 -- links. The display_value (a directory) already
7725 -- ends with a directory separator by construction,
7726 -- so no need to add one.
7731 Check_File
7743 else
7750 Debug_Decrease_Indent;
7755 exception
7767 ----------------------------
7768 -- Load_Naming_Exceptions --
7769 ----------------------------
7771 procedure Load_Naming_Exceptions
7774 is
7778 begin
7780 loop
7784 -- An excluded file cannot also be an exception file name
7787 No_File_Found
7788 then
7790 Error_Msg
7796 Debug_Output
7800 Source_Names_Htable.Set
7804 (Name => Source.File,
7805 Location => Source.Location,
7806 Source => Source,
7807 Listed => False,
7808 Found => False));
7810 -- If this is an Ada exception, record in table Unit_Exceptions
7812 if Source.Unit /= No_Unit_Index then
7813 declare
7814 Unit_Except : Unit_Exception :=
7815 Unit_Exceptions_Htable.Get
7816 (Project.Unit_Exceptions, Source.Unit.Name);
7818 begin
7819 Unit_Except.Name := Source.Unit.Name;
7821 if Source.Kind = Spec then
7822 Unit_Except.Spec := Source.File;
7823 else
7824 Unit_Except.Impl := Source.File;
7825 end if;
7827 Unit_Exceptions_Htable.Set
7828 (Project.Unit_Exceptions, Source.Unit.Name, Unit_Except);
7829 end;
7830 end if;
7832 Next (Iter);
7833 end loop;
7834 end Load_Naming_Exceptions;
7836 ----------------------
7837 -- Look_For_Sources --
7838 ----------------------
7840 procedure Look_For_Sources
7841 (Project : in out Project_Processing_Data;
7842 Data : in out Tree_Processing_Data)
7843 is
7844 Object_Files : Object_File_Names_Htable.Instance;
7845 Iter : Source_Iterator;
7846 Src : Source_Id;
7848 procedure Check_Object (Src : Source_Id);
7849 -- Check if object file name of Src is already used in the project tree,
7850 -- and report an error if so.
7852 procedure Check_Object_Files;
7853 -- Check that no two sources of this project have the same object file
7855 procedure Mark_Excluded_Sources;
7856 -- Mark as such the sources that are declared as excluded
7858 procedure Check_Missing_Sources;
7859 -- Check whether one of the languages has no sources, and report an
7860 -- error when appropriate
7862 procedure Get_Sources_From_Source_Info;
7863 -- Get the source information from the tables that were created when a
7864 -- source info file was read.
7866 ---------------------------
7867 -- Check_Missing_Sources --
7868 ---------------------------
7870 procedure Check_Missing_Sources is
7871 Extending : constant Boolean :=
7872 Project.Project.Extends /= No_Project;
7873 Language : Language_Ptr;
7874 Source : Source_Id;
7875 Alt_Lang : Language_List;
7876 Continuation : Boolean := False;
7877 Iter : Source_Iterator;
7878 begin
7879 if not Project.Project.Externally_Built and then not Extending then
7880 Language := Project.Project.Languages;
7881 while Language /= No_Language_Index loop
7883 -- If there are no sources for this language, check if there
7884 -- are sources for which this is an alternate language.
7886 if Language.First_Source = No_Source
7887 and then (Data.Flags.Require_Sources_Other_Lang
7888 or else Language.Name = Name_Ada)
7889 then
7890 Iter := For_Each_Source (In_Tree => Data.Tree,
7891 Project => Project.Project);
7892 Source_Loop : loop
7893 Source := Element (Iter);
7894 exit Source_Loop when Source = No_Source
7895 or else Source.Language = Language;
7897 Alt_Lang := Source.Alternate_Languages;
7898 while Alt_Lang /= null loop
7899 exit Source_Loop when Alt_Lang.Language = Language;
7900 Alt_Lang := Alt_Lang.Next;
7901 end loop;
7903 Next (Iter);
7904 end loop Source_Loop;
7906 if Source = No_Source then
7907 Report_No_Sources
7908 (Project.Project,
7909 Get_Name_String (Language.Display_Name),
7910 Data,
7911 Project.Source_List_File_Location,
7912 Continuation);
7913 Continuation := True;
7914 end if;
7915 end if;
7917 Language := Language.Next;
7918 end loop;
7919 end if;
7920 end Check_Missing_Sources;
7922 ------------------
7923 -- Check_Object --
7924 ------------------
7926 procedure Check_Object (Src : Source_Id) is
7927 Source : Source_Id;
7929 begin
7930 Source := Object_File_Names_Htable.Get (Object_Files, Src.Object);
7932 -- We cannot just check on "Source /= Src", since we might have
7933 -- two different entries for the same file (and since that's
7934 -- the same file it is expected that it has the same object)
7936 if Source /= No_Source
7937 and then Source.Replaced_By = No_Source
7938 and then Source.Path /= Src.Path
7939 and then Source.Index = 0
7940 and then Src.Index = 0
7941 and then Is_Extending (Src.Project, Source.Project)
7942 then
7943 Error_Msg_File_1 := Src.File;
7944 Error_Msg_File_2 := Source.File;
7945 Error_Msg
7946 (Data.Flags,
7948 No_Location, Project.Project);
7950 else
7951 Object_File_Names_Htable.Set (Object_Files, Src.Object, Src);
7952 end if;
7953 end Check_Object;
7955 ---------------------------
7956 -- Mark_Excluded_Sources --
7957 ---------------------------
7959 procedure Mark_Excluded_Sources is
7960 Source : Source_Id := No_Source;
7961 Excluded : File_Found;
7962 Proj : Project_Id;
7964 begin
7965 -- Minor optimization: if there are no excluded files, no need to
7966 -- traverse the list of sources. We cannot however also check whether
7967 -- the existing exceptions have ".Found" set to True (indicating we
7968 -- found them before) because we need to do some final processing on
7969 -- them in any case.
7971 if Excluded_Sources_Htable.Get_First (Project.Excluded) /=
7972 No_File_Found
7973 then
7974 Proj := Project.Project;
7975 while Proj /= No_Project loop
7976 Iter := For_Each_Source (Data.Tree, Proj);
7977 while Prj.Element (Iter) /= No_Source loop
7978 Source := Prj.Element (Iter);
7979 Excluded := Excluded_Sources_Htable.Get
7980 (Project.Excluded, Source.File);
7982 if Excluded /= No_File_Found then
7983 Source.In_Interfaces := False;
7984 Source.Locally_Removed := True;
7986 if Proj = Project.Project then
7987 Source.Suppressed := True;
7988 end if;
7990 if Current_Verbosity = High then
7991 Debug_Indent;
7992 Write_Str ("removing file ");
7993 Write_Line
7994 (Get_Name_String (Excluded.File)
7995 & " " & Get_Name_String (Source.Project.Name));
7996 end if;
7998 Excluded_Sources_Htable.Remove
7999 (Project.Excluded, Source.File);
8000 end if;
8002 Next (Iter);
8003 end loop;
8005 Proj := Proj.Extends;
8006 end loop;
8007 end if;
8009 -- If we have any excluded element left, that means we did not find
8010 -- the source file
8012 Excluded := Excluded_Sources_Htable.Get_First (Project.Excluded);
8013 while Excluded /= No_File_Found loop
8014 if not Excluded.Found then
8016 -- Check if the file belongs to another imported project to
8017 -- provide a better error message.
8019 Src := Find_Source
8020 (In_Tree => Data.Tree,
8021 Project => Project.Project,
8022 In_Imported_Only => True,
8023 Base_Name => Excluded.File);
8025 Err_Vars.Error_Msg_File_1 := Excluded.File;
8027 if Src = No_Source then
8028 if Excluded.Excl_File = No_File then
8029 Error_Msg
8030 (Data.Flags,
8031 "unknown file {", Excluded.Location, Project.Project);
8033 else
8034 Error_Msg
8035 (Data.Flags,
8036 "in " &
8037 Get_Name_String (Excluded.Excl_File) & ":" &
8038 No_Space_Img (Excluded.Excl_Line) &
8039 ": unknown file {", Excluded.Location, Project.Project);
8040 end if;
8042 else
8043 if Excluded.Excl_File = No_File then
8044 Error_Msg
8045 (Data.Flags,
8046 "cannot remove a source from an imported project: {",
8047 Excluded.Location, Project.Project);
8049 else
8050 Error_Msg
8051 (Data.Flags,
8052 "in " &
8053 Get_Name_String (Excluded.Excl_File) & ":" &
8054 No_Space_Img (Excluded.Excl_Line) &
8055 ": cannot remove a source from an imported project: {",
8056 Excluded.Location, Project.Project);
8057 end if;
8058 end if;
8059 end if;
8061 Excluded := Excluded_Sources_Htable.Get_Next (Project.Excluded);
8062 end loop;
8063 end Mark_Excluded_Sources;
8065 ------------------------
8066 -- Check_Object_Files --
8067 ------------------------
8069 procedure Check_Object_Files is
8070 Iter : Source_Iterator;
8071 Src_Id : Source_Id;
8072 Src_Ind : Source_File_Index;
8074 begin
8075 Iter := For_Each_Source (Data.Tree);
8076 loop
8077 Src_Id := Prj.Element (Iter);
8078 exit when Src_Id = No_Source;
8080 if Is_Compilable (Src_Id)
8081 and then Src_Id.Language.Config.Object_Generated
8082 and then Is_Extending (Project.Project, Src_Id.Project)
8083 then
8084 if Src_Id.Unit = No_Unit_Index then
8085 if Src_Id.Kind = Impl then
8086 Check_Object (Src_Id);
8087 end if;
8089 else
8090 case Src_Id.Kind is
8091 when Spec =>
8092 if Other_Part (Src_Id) = No_Source then
8093 Check_Object (Src_Id);
8094 end if;
8096 when Sep =>
8097 null;
8099 when Impl =>
8100 if Other_Part (Src_Id) /= No_Source then
8101 Check_Object (Src_Id);
8103 else
8104 -- Check if it is a subunit
8106 Src_Ind :=
8107 Sinput.P.Load_Project_File
8108 (Get_Name_String (Src_Id.Path.Display_Name));
8110 if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
8111 Override_Kind (Src_Id, Sep);
8112 else
8113 Check_Object (Src_Id);
8114 end if;
8115 end if;
8116 end case;
8117 end if;
8118 end if;
8120 Next (Iter);
8121 end loop;
8122 end Check_Object_Files;
8124 ----------------------------------
8125 -- Get_Sources_From_Source_Info --
8126 ----------------------------------
8128 procedure Get_Sources_From_Source_Info is
8129 Iter : Source_Info_Iterator;
8130 Src : Source_Info;
8131 Id : Source_Id;
8132 Lang_Id : Language_Ptr;
8134 begin
8135 Initialize (Iter, Project.Project.Name);
8137 loop
8138 Src := Source_Info_Of (Iter);
8140 exit when Src = No_Source_Info;
8142 Id := new Source_Data;
8144 Id.Project := Project.Project;
8146 Lang_Id := Project.Project.Languages;
8147 while Lang_Id /= No_Language_Index
8148 and then Lang_Id.Name /= Src.Language
8149 loop
8150 Lang_Id := Lang_Id.Next;
8151 end loop;
8153 if Lang_Id = No_Language_Index then
8154 Prj.Com.Fail
8155 ("unknown language " &
8156 Get_Name_String (Src.Language) &
8157 " for project " &
8158 Get_Name_String (Src.Project) &
8159 " in source info file");
8160 end if;
8162 Id.Language := Lang_Id;
8163 Id.Kind := Src.Kind;
8164 Id.Index := Src.Index;
8166 Id.Path :=
8167 (Path_Name_Type (Src.Display_Path_Name),
8168 Path_Name_Type (Src.Path_Name));
8170 Name_Len := 0;
8171 Add_Str_To_Name_Buffer
8172 (Directories.Simple_Name (Get_Name_String (Src.Path_Name)));
8173 Id.File := Name_Find;
8175 Id.Next_With_File_Name :=
8176 Source_Files_Htable.Get (Data.Tree.Source_Files_HT, Id.File);
8177 Source_Files_Htable.Set (Data.Tree.Source_Files_HT, Id.File, Id);
8179 Name_Len := 0;
8180 Add_Str_To_Name_Buffer
8181 (Directories.Simple_Name
8182 (Get_Name_String (Src.Display_Path_Name)));
8183 Id.Display_File := Name_Find;
8185 Id.Dep_Name :=
8186 Dependency_Name (Id.File, Id.Language.Config.Dependency_Kind);
8187 Id.Naming_Exception := Src.Naming_Exception;
8188 Id.Object :=
8189 Object_Name (Id.File, Id.Language.Config.Object_File_Suffix);
8190 Id.Switches := Switches_Name (Id.File);
8192 -- Add the source id to the Unit_Sources_HT hash table, if the
8193 -- unit name is not null.
8195 if Src.Kind /= Sep and then Src.Unit_Name /= No_Name then
8196 declare
8197 UData : Unit_Index :=
8198 Units_Htable.Get (Data.Tree.Units_HT, Src.Unit_Name);
8199 begin
8200 if UData = No_Unit_Index then
8201 UData := new Unit_Data;
8202 UData.Name := Src.Unit_Name;
8203 Units_Htable.Set
8204 (Data.Tree.Units_HT, Src.Unit_Name, UData);
8205 end if;
8207 Id.Unit := UData;
8208 end;
8210 -- Note that this updates Unit information as well
8212 Override_Kind (Id, Id.Kind);
8213 end if;
8215 if Src.Index /= 0 then
8216 Project.Project.Has_Multi_Unit_Sources := True;
8217 end if;
8219 -- Add the source to the language list
8221 Id.Next_In_Lang := Id.Language.First_Source;
8222 Id.Language.First_Source := Id;
8224 Next (Iter);
8225 end loop;
8226 end Get_Sources_From_Source_Info;
8228 -- Start of processing for Look_For_Sources
8230 begin
8231 if Data.Tree.Source_Info_File_Exists then
8232 Get_Sources_From_Source_Info;
8234 else
8235 if Project.Project.Source_Dirs /= Nil_String then
8236 Find_Excluded_Sources (Project, Data);
8238 if Project.Project.Languages /= No_Language_Index then
8239 Load_Naming_Exceptions (Project, Data);
8240 Find_Sources (Project, Data);
8241 Mark_Excluded_Sources;
8242 Check_Object_Files;
8243 Check_Missing_Sources;
8244 end if;
8245 end if;
8247 Object_File_Names_Htable.Reset (Object_Files);
8248 end if;
8249 end Look_For_Sources;
8251 ------------------
8252 -- Path_Name_Of --
8253 ------------------
8255 function Path_Name_Of
8256 (File_Name : File_Name_Type;
8257 Directory : Path_Name_Type) return String
8258 is
8259 Result : String_Access;
8260 The_Directory : constant String := Get_Name_String (Directory);
8262 begin
8263 Debug_Output ("Path_Name_Of file name=", Name_Id (File_Name));
8264 Debug_Output ("Path_Name_Of directory=", Name_Id (Directory));
8265 Get_Name_String (File_Name);
8266 Result :=
8267 Locate_Regular_File
8268 (File_Name => Name_Buffer (1 .. Name_Len),
8269 Path => The_Directory);
8271 if Result = null then
8272 return "";
8273 else
8274 declare
8275 R : constant String := Result.all;
8276 begin
8277 Free (Result);
8278 return R;
8279 end;
8280 end if;
8281 end Path_Name_Of;
8283 -------------------
8284 -- Remove_Source --
8285 -------------------
8287 procedure Remove_Source
8288 (Tree : Project_Tree_Ref;
8289 Id : Source_Id;
8290 Replaced_By : Source_Id)
8291 is
8292 Source : Source_Id;
8294 begin
8295 if Current_Verbosity = High then
8296 Debug_Indent;
8297 Write_Str ("removing source ");
8298 Write_Str (Get_Name_String (Id.File));
8300 if Id.Index /= 0 then
8301 Write_Str (" at" & Id.Index'Img);
8302 end if;
8304 Write_Eol;
8305 end if;
8307 if Replaced_By /= No_Source then
8308 Id.Replaced_By := Replaced_By;
8309 Replaced_By.Declared_In_Interfaces := Id.Declared_In_Interfaces;
8311 if Id.File /= Replaced_By.File then
8312 declare
8313 Replacement : constant File_Name_Type :=
8314 Replaced_Source_HTable.Get
8315 (Tree.Replaced_Sources, Id.File);
8317 begin
8318 Replaced_Source_HTable.Set
8319 (Tree.Replaced_Sources, Id.File, Replaced_By.File);
8321 if Replacement = No_File then
8322 Tree.Replaced_Source_Number :=
8323 Tree.Replaced_Source_Number + 1;
8324 end if;
8325 end;
8326 end if;
8327 end if;
8329 Id.In_Interfaces := False;
8330 Id.Locally_Removed := True;
8332 -- ??? Should we remove the source from the unit ? The file is not used,
8333 -- so probably should not be referenced from the unit. On the other hand
8334 -- it might give useful additional info
8335 -- if Id.Unit /= null then
8336 -- Id.Unit.File_Names (Id.Kind) := null;
8337 -- end if;
8339 Source := Id.Language.First_Source;
8341 if Source = Id then
8342 Id.Language.First_Source := Id.Next_In_Lang;
8344 else
8345 while Source.Next_In_Lang /= Id loop
8346 Source := Source.Next_In_Lang;
8347 end loop;
8349 Source.Next_In_Lang := Id.Next_In_Lang;
8350 end if;
8351 end Remove_Source;
8353 -----------------------
8354 -- Report_No_Sources --
8355 -----------------------
8357 procedure Report_No_Sources
8358 (Project : Project_Id;
8359 Lang_Name : String;
8360 Data : Tree_Processing_Data;
8361 Location : Source_Ptr;
8362 Continuation : Boolean := False)
8363 is
8364 begin
8365 case Data.Flags.When_No_Sources is
8366 when Silent =>
8367 null;
8369 when Warning | Error =>
8370 declare
8371 Msg : constant String :=
8372 "<there are no "
8373 & Lang_Name & " sources in this project";
8375 begin
8376 Error_Msg_Warn := Data.Flags.When_No_Sources = Warning;
8378 if Continuation then
8380 else
8381 Error_Msg (Data.Flags, Msg, Location, Project);
8382 end if;
8383 end;
8384 end case;
8385 end Report_No_Sources;
8387 ----------------------
8388 -- Show_Source_Dirs --
8389 ----------------------
8391 procedure Show_Source_Dirs
8392 (Project : Project_Id;
8393 Shared : Shared_Project_Tree_Data_Access)
8394 is
8395 Current : String_List_Id;
8396 Element : String_Element;
8398 begin
8399 if Project.Source_Dirs = Nil_String then
8400 Debug_Output ("no Source_Dirs");
8401 else
8402 Debug_Increase_Indent ("Source_Dirs:");
8404 Current := Project.Source_Dirs;
8405 while Current /= Nil_String loop
8406 Element := Shared.String_Elements.Table (Current);
8407 Debug_Output (Get_Name_String (Element.Display_Value));
8408 Current := Element.Next;
8409 end loop;
8411 Debug_Decrease_Indent ("end Source_Dirs.");
8412 end if;
8413 end Show_Source_Dirs;
8415 ---------------------------
8416 -- Process_Naming_Scheme --
8417 ---------------------------
8419 procedure Process_Naming_Scheme
8420 (Tree : Project_Tree_Ref;
8421 Root_Project : Project_Id;
8422 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
8423 Flags : Processing_Flags)
8424 is
8426 procedure Check
8427 (Project : Project_Id;
8428 In_Aggregate_Lib : Boolean;
8429 Data : in out Tree_Processing_Data);
8430 -- Process the naming scheme for a single project
8432 procedure Recursive_Check
8433 (Project : Project_Id;
8434 Prj_Tree : Project_Tree_Ref;
8435 Context : Project_Context;
8436 Data : in out Tree_Processing_Data);
8437 -- Check_Naming_Scheme for the project
8439 -----------
8440 -- Check --
8441 -----------
8443 procedure Check
8444 (Project : Project_Id;
8445 In_Aggregate_Lib : Boolean;
8446 Data : in out Tree_Processing_Data)
8447 is
8448 procedure Check_Aggregated;
8449 -- Check aggregated projects which should not be externally built
8451 ----------------------
8452 -- Check_Aggregated --
8453 ----------------------
8455 procedure Check_Aggregated is
8456 L : Aggregated_Project_List;
8458 begin
8459 -- Check that aggregated projects are not externally built
8461 L := Project.Aggregated_Projects;
8462 while L /= null loop
8463 declare
8464 Var : constant Prj.Variable_Value :=
8465 Prj.Util.Value_Of
8466 (Snames.Name_Externally_Built,
8467 L.Project.Decl.Attributes,
8468 Data.Tree.Shared);
8469 begin
8470 if not Var.Default then
8471 Error_Msg_Name_1 := L.Project.Display_Name;
8472 Error_Msg
8473 (Data.Flags,
8474 "cannot aggregate externally built project %%",
8475 Var.Location, Project);
8476 end if;
8477 end;
8479 L := L.Next;
8480 end loop;
8481 end Check_Aggregated;
8483 -- Local Variables
8485 Shared : constant Shared_Project_Tree_Data_Access :=
8486 Data.Tree.Shared;
8487 Prj_Data : Project_Processing_Data;
8489 -- Start of processing for Check
8491 begin
8492 Debug_Increase_Indent ("check", Project.Name);
8494 Initialize (Prj_Data, Project);
8496 Check_If_Externally_Built (Project, Data);
8498 case Project.Qualifier is
8499 when Aggregate =>
8500 Check_Aggregated;
8502 when Aggregate_Library =>
8503 Check_Aggregated;
8505 if Project.Object_Directory = No_Path_Information then
8506 Project.Object_Directory := Project.Directory;
8507 end if;
8509 when others =>
8510 Get_Directories (Project, Data);
8511 Check_Programming_Languages (Project, Data);
8513 if Current_Verbosity = High then
8514 Show_Source_Dirs (Project, Shared);
8515 end if;
8517 if Project.Qualifier = Abstract_Project then
8518 Check_Abstract_Project (Project, Data);
8519 end if;
8520 end case;
8522 -- Check configuration. Must be done for gnatmake (even though no
8523 -- user configuration file was provided) since the default config we
8524 -- generate indicates whether libraries are supported for instance.
8526 Check_Configuration (Project, Data);
8528 if Project.Qualifier /= Aggregate then
8529 Check_Library_Attributes (Project, Data);
8530 Check_Package_Naming (Project, Data);
8532 -- An aggregate library has no source, no need to look for them
8534 if Project.Qualifier /= Aggregate_Library then
8535 Look_For_Sources (Prj_Data, Data);
8536 end if;
8538 Check_Interfaces (Project, Data);
8540 -- If this library is part of an aggregated library don't check it
8541 -- as it has no sources by itself and so interface won't be found.
8543 if Project.Library and not In_Aggregate_Lib then
8544 Check_Stand_Alone_Library (Project, Data);
8545 end if;
8547 Get_Mains (Project, Data);
8548 end if;
8550 Free (Prj_Data);
8552 Debug_Decrease_Indent ("done check");
8553 end Check;
8555 ---------------------
8556 -- Recursive_Check --
8557 ---------------------
8559 procedure Recursive_Check
8560 (Project : Project_Id;
8561 Prj_Tree : Project_Tree_Ref;
8562 Context : Project_Context;
8563 Data : in out Tree_Processing_Data)
8564 is
8565 begin
8566 if Current_Verbosity = High then
8567 Debug_Increase_Indent
8568 ("Processing_Naming_Scheme for project", Project.Name);
8569 end if;
8571 Data.Tree := Prj_Tree;
8572 Data.In_Aggregate_Lib := Context.In_Aggregate_Lib;
8574 Check (Project, Context.In_Aggregate_Lib, Data);
8576 if Current_Verbosity = High then
8577 Debug_Decrease_Indent ("done Processing_Naming_Scheme");
8578 end if;
8579 end Recursive_Check;
8581 procedure Check_All_Projects is new For_Every_Project_Imported_Context
8582 (Tree_Processing_Data, Recursive_Check);
8583 -- Comment required???
8585 -- Local Variables
8587 Data : Tree_Processing_Data;
8589 -- Start of processing for Process_Naming_Scheme
8591 begin
8592 Lib_Data_Table.Init;
8593 Initialize (Data, Tree => Tree, Node_Tree => Node_Tree, Flags => Flags);
8594 Check_All_Projects (Root_Project, Tree, Data, Imported_First => True);
8595 Free (Data);
8597 -- Adjust language configs for projects that are extended
8599 declare
8600 List : Project_List;
8601 Proj : Project_Id;
8602 Exte : Project_Id;
8603 Lang : Language_Ptr;
8604 Elng : Language_Ptr;
8606 begin
8607 List := Tree.Projects;
8608 while List /= null loop
8609 Proj := List.Project;
8611 Exte := Proj;
8612 while Exte.Extended_By /= No_Project loop
8613 Exte := Exte.Extended_By;
8614 end loop;
8616 if Exte /= Proj then
8617 Lang := Proj.Languages;
8619 if Lang /= No_Language_Index then
8620 loop
8621 Elng := Get_Language_From_Name
8622 (Exte, Get_Name_String (Lang.Name));
8623 exit when Elng /= No_Language_Index;
8624 Exte := Exte.Extends;
8625 end loop;
8627 if Elng /= Lang then
8628 Lang.Config := Elng.Config;
8629 end if;
8630 end if;
8631 end if;
8633 List := List.Next;
8634 end loop;
8635 end;
8636 end Process_Naming_Scheme;
8638 end Prj.Nmsc;