| blob | f1538de9922a2ecc4d89b0357a32af2613a8e195 |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . N M S C --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2000-2013, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
56 -- Used in Check_Library for continuation error messages at the same
57 -- location.
59 type Name_Location is record
60 Name : File_Name_Type;
61 -- Key is duplicated, so that it is known when using functions Get_First
62 -- and Get_Next, as these functions only return an Element.
64 Location : Source_Ptr;
65 Source : Source_Id := No_Source;
66 Listed : Boolean := False;
67 Found : Boolean := False;
68 end record;
70 No_Name_Location : constant Name_Location :=
71 (Name => No_File,
72 Location => No_Location,
73 Source => No_Source,
74 Listed => False,
75 Found => False);
77 package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
78 (Header_Num => Header_Num,
79 Element => Name_Location,
80 No_Element => No_Name_Location,
81 Key => File_Name_Type,
82 Hash => Hash,
84 -- File name information found in string list attribute (Source_Files or
85 -- Source_List_File). Used to check that all referenced files were indeed
86 -- found on the disk.
88 type Unit_Exception is record
89 Name : Name_Id;
90 -- Key is duplicated, so that it is known when using functions Get_First
91 -- and Get_Next, as these functions only return an Element.
93 Spec : File_Name_Type;
94 Impl : File_Name_Type;
95 end record;
97 No_Unit_Exception : constant Unit_Exception := (No_Name, No_File, No_File);
99 package Unit_Exceptions_Htable is new GNAT.Dynamic_HTables.Simple_HTable
100 (Header_Num => Header_Num,
101 Element => Unit_Exception,
102 No_Element => No_Unit_Exception,
103 Key => Name_Id,
104 Hash => Hash,
106 -- Record special naming schemes for Ada units (name of spec file and name
107 -- of implementation file). The elements in this list come from the naming
108 -- exceptions specified in the project files.
110 type File_Found is record
111 File : File_Name_Type := No_File;
112 Excl_File : File_Name_Type := No_File;
113 Excl_Line : Natural := 0;
114 Found : Boolean := False;
115 Location : Source_Ptr := No_Location;
116 end record;
118 No_File_Found : constant File_Found :=
119 (No_File, No_File, 0, False, No_Location);
121 package Excluded_Sources_Htable is new GNAT.Dynamic_HTables.Simple_HTable
122 (Header_Num => Header_Num,
123 Element => File_Found,
124 No_Element => No_File_Found,
125 Key => File_Name_Type,
126 Hash => Hash,
128 -- A hash table to store the base names of excluded files, if any
130 package Object_File_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
131 (Header_Num => Header_Num,
132 Element => Source_Id,
133 No_Element => No_Source,
134 Key => File_Name_Type,
135 Hash => Hash,
137 -- A hash table to store the object file names for a project, to check that
138 -- two different sources have different object file names.
140 type Project_Processing_Data is record
141 Project : Project_Id;
142 Source_Names : Source_Names_Htable.Instance;
143 Unit_Exceptions : Unit_Exceptions_Htable.Instance;
144 Excluded : Excluded_Sources_Htable.Instance;
146 Source_List_File_Location : Source_Ptr;
147 -- Location of the Source_List_File attribute, for error messages
148 end record;
149 -- This is similar to Tree_Processing_Data, but contains project-specific
150 -- information which is only useful while processing the project, and can
151 -- be discarded as soon as we have finished processing the project
153 type Tree_Processing_Data is record
154 Tree : Project_Tree_Ref;
155 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
156 Flags : Prj.Processing_Flags;
157 In_Aggregate_Lib : Boolean;
158 end record;
159 -- Temporary data which is needed while parsing a project. It does not need
160 -- to be kept in memory once a project has been fully loaded, but is
161 -- necessary while performing consistency checks (duplicate sources,...)
162 -- This data must be initialized before processing any project, and the
163 -- same data is used for processing all projects in the tree.
165 type Lib_Data is record
166 Name : Name_Id;
167 Proj : Project_Id;
168 Tree : Project_Tree_Ref;
169 end record;
171 package Lib_Data_Table is new GNAT.Table
172 (Table_Component_Type => Lib_Data,
173 Table_Index_Type => Natural,
174 Table_Low_Bound => 1,
175 Table_Initial => 10,
176 Table_Increment => 100);
177 -- A table to record library names in order to check that two library
178 -- projects do not have the same library names.
180 procedure Initialize
181 (Data : out Tree_Processing_Data;
182 Tree : Project_Tree_Ref;
183 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
184 Flags : Prj.Processing_Flags);
185 -- Initialize Data
187 procedure Free (Data : in out Tree_Processing_Data);
188 -- Free the memory occupied by Data
190 procedure Initialize
191 (Data : in out Project_Processing_Data;
192 Project : Project_Id);
193 procedure Free (Data : in out Project_Processing_Data);
194 -- Initialize or free memory for a project-specific data
196 procedure Find_Excluded_Sources
197 (Project : in out Project_Processing_Data;
198 Data : in out Tree_Processing_Data);
199 -- Find the list of files that should not be considered as source files
200 -- for this project. Sets the list in the Project.Excluded_Sources_Htable.
202 procedure Override_Kind (Source : Source_Id; Kind : Source_Kind);
203 -- Override the reference kind for a source file. This properly updates
204 -- the unit data if necessary.
206 procedure Load_Naming_Exceptions
207 (Project : in out Project_Processing_Data;
208 Data : in out Tree_Processing_Data);
209 -- All source files in Data.First_Source are considered as naming
210 -- exceptions, and copied into the Source_Names and Unit_Exceptions tables
211 -- as appropriate.
213 type Search_Type is (Search_Files, Search_Directories);
215 generic
216 with procedure Callback
217 (Path : Path_Information;
218 Pattern_Index : Natural);
219 procedure Expand_Subdirectory_Pattern
220 (Project : Project_Id;
221 Data : in out Tree_Processing_Data;
222 Patterns : String_List_Id;
223 Ignore : String_List_Id;
224 Search_For : Search_Type;
225 Resolve_Links : Boolean);
226 -- Search the subdirectories of Project's directory for files or
227 -- directories that match the globbing patterns found in Patterns (for
229 -- Source_Dirs or Excluded_Source_Dirs attributes.
230 --
231 -- Every time such a file or directory is found, the callback is called.
232 -- Resolve_Links indicates whether we should resolve links while
233 -- normalizing names.
234 --
235 -- In the callback, Pattern_Index is the index within Patterns where the
236 -- expanded pattern was found (1 for the first element of Patterns and
237 -- all its matching directories, then 2,...).
238 --
239 -- We use a generic and not an access-to-subprogram because in some cases
240 -- this code is compiled with the restriction No_Implicit_Dynamic_Code.
241 -- An error message is raised if a pattern does not match any file.
243 procedure Add_Source
244 (Id : out Source_Id;
245 Data : in out Tree_Processing_Data;
246 Project : Project_Id;
247 Source_Dir_Rank : Natural;
248 Lang_Id : Language_Ptr;
249 Kind : Source_Kind;
250 File_Name : File_Name_Type;
251 Display_File : File_Name_Type;
252 Naming_Exception : Naming_Exception_Type := No;
253 Path : Path_Information := No_Path_Information;
254 Alternate_Languages : Language_List := null;
255 Unit : Name_Id := No_Name;
256 Index : Int := 0;
257 Locally_Removed : Boolean := False;
258 Location : Source_Ptr := No_Location);
259 -- Add a new source to the different lists: list of all sources in the
260 -- project tree, list of source of a project and list of sources of a
261 -- language. If Path is specified, the file is also added to
262 -- Source_Paths_HT. Location is used for error messages
264 function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type;
265 -- Same as Osint.Canonical_Case_File_Name but applies to Name_Id.
266 -- This alters Name_Buffer.
268 function Suffix_Matches
269 (Filename : String;
270 Suffix : File_Name_Type) return Boolean;
271 -- True if the file name ends with the given suffix. Always returns False
272 -- if Suffix is No_Name.
274 procedure Replace_Into_Name_Buffer
275 (Str : String;
276 Pattern : String;
277 Replacement : Character);
278 -- Copy Str into Name_Buffer, replacing Pattern with Replacement. Str is
279 -- converted to lower-case at the same time.
281 procedure Check_Abstract_Project
282 (Project : Project_Id;
283 Data : in out Tree_Processing_Data);
284 -- Check abstract projects attributes
286 procedure Check_Configuration
287 (Project : Project_Id;
288 Data : in out Tree_Processing_Data);
289 -- Check the configuration attributes for the project
291 procedure Check_If_Externally_Built
292 (Project : Project_Id;
293 Data : in out Tree_Processing_Data);
294 -- Check attribute Externally_Built of project Project in project tree
297 procedure Check_Interfaces
298 (Project : Project_Id;
299 Data : in out Tree_Processing_Data);
300 -- If a list of sources is specified in attribute Interfaces, set
301 -- In_Interfaces only for the sources specified in the list.
303 procedure Check_Library_Attributes
304 (Project : Project_Id;
305 Data : in out Tree_Processing_Data);
306 -- Check the library attributes of project Project in project tree
307 -- and modify its data Data accordingly.
309 procedure Check_Package_Naming
310 (Project : Project_Id;
311 Data : in out Tree_Processing_Data);
312 -- Check the naming scheme part of Data, and initialize the naming scheme
313 -- data in the config of the various languages.
315 procedure Check_Programming_Languages
316 (Project : Project_Id;
317 Data : in out Tree_Processing_Data);
318 -- Check attribute Languages for the project with data Data in project
319 -- tree Data.Tree and set the components of Data for all the programming
320 -- languages indicated in attribute Languages, if any.
322 procedure Check_Stand_Alone_Library
323 (Project : Project_Id;
324 Data : in out Tree_Processing_Data);
325 -- Check if project Project in project tree Data.Tree is a Stand-Alone
326 -- Library project, and modify its data Data accordingly if it is one.
328 procedure Check_Unit_Name (Name : String; Unit : out Name_Id);
329 -- Check that a name is a valid unit name
331 function Compute_Directory_Last (Dir : String) return Natural;
332 -- Return the index of the last significant character in Dir. This is used
333 -- to avoid duplicate '/' (slash) characters at the end of directory names.
335 procedure Search_Directories
336 (Project : in out Project_Processing_Data;
337 Data : in out Tree_Processing_Data;
338 For_All_Sources : Boolean);
339 -- Search the source directories to find the sources. If For_All_Sources is
340 -- True, check each regular file name against the naming schemes of the
341 -- various languages. Otherwise consider only the file names in hash table
342 -- Source_Names. If Allow_Duplicate_Basenames then files with identical
343 -- base names are permitted within a project for source-based languages
344 -- (never for unit based languages).
346 procedure Check_File
347 (Project : in out Project_Processing_Data;
348 Data : in out Tree_Processing_Data;
349 Source_Dir_Rank : Natural;
350 Path : Path_Name_Type;
351 Display_Path : Path_Name_Type;
352 File_Name : File_Name_Type;
353 Display_File_Name : File_Name_Type;
354 Locally_Removed : Boolean;
355 For_All_Sources : Boolean);
356 -- Check if file File_Name is a valid source of the project. This is used
357 -- in multi-language mode only. When the file matches one of the naming
358 -- schemes, it is added to various htables through Add_Source and to
359 -- Source_Paths_Htable.
360 --
361 -- File_Name is the same as Display_File_Name, but has been normalized.
362 -- They do not include the directory information.
363 --
364 -- Path and Display_Path on the other hand are the full path to the file.
365 -- Path must have been normalized (canonical casing and possibly links
366 -- resolved).
367 --
368 -- Source_Directory is the directory in which the file was found. It is
369 -- neither normalized nor has had links resolved, and must not end with a
370 -- a directory separator, to avoid duplicates later on.
371 --
372 -- If For_All_Sources is True, then all possible file names are analyzed
373 -- otherwise only those currently set in the Source_Names hash table.
375 procedure Check_File_Naming_Schemes
376 (Project : Project_Processing_Data;
377 File_Name : File_Name_Type;
378 Alternate_Languages : out Language_List;
379 Language : out Language_Ptr;
380 Display_Language_Name : out Name_Id;
381 Unit : out Name_Id;
382 Lang_Kind : out Language_Kind;
383 Kind : out Source_Kind);
384 -- Check if the file name File_Name conforms to one of the naming schemes
385 -- of the project. If the file does not match one of the naming schemes,
386 -- set Language to No_Language_Index. Filename is the name of the file
387 -- being investigated. It has been normalized (case-folded). File_Name is
388 -- the same value.
390 procedure Get_Directories
391 (Project : Project_Id;
392 Data : in out Tree_Processing_Data);
393 -- Get the object directory, the exec directory and the source directories
394 -- of a project.
396 procedure Get_Mains
397 (Project : Project_Id;
398 Data : in out Tree_Processing_Data);
399 -- Get the mains of a project from attribute Main, if it exists, and put
400 -- them in the project data.
402 procedure Get_Sources_From_File
403 (Path : String;
404 Location : Source_Ptr;
405 Project : in out Project_Processing_Data;
406 Data : in out Tree_Processing_Data);
407 -- Get the list of sources from a text file and put them in hash table
408 -- Source_Names.
410 procedure Find_Sources
411 (Project : in out Project_Processing_Data;
412 Data : in out Tree_Processing_Data);
413 -- Process the Source_Files and Source_List_File attributes, and store the
414 -- list of source files into the Source_Names htable. When these attributes
415 -- are not defined, find all files matching the naming schemes in the
416 -- source directories. If Allow_Duplicate_Basenames, then files with the
417 -- same base names are authorized within a project for source-based
418 -- languages (never for unit based languages)
420 procedure Compute_Unit_Name
421 (File_Name : File_Name_Type;
422 Naming : Lang_Naming_Data;
423 Kind : out Source_Kind;
424 Unit : out Name_Id;
425 Project : Project_Processing_Data);
426 -- Check whether the file matches the naming scheme. If it does,
427 -- compute its unit name. If Unit is set to No_Name on exit, none of the
428 -- other out parameters are relevant.
430 procedure Check_Illegal_Suffix
431 (Project : Project_Id;
432 Suffix : File_Name_Type;
433 Dot_Replacement : File_Name_Type;
434 Attribute_Name : String;
435 Location : Source_Ptr;
436 Data : in out Tree_Processing_Data);
437 -- Display an error message if the given suffix is illegal for some reason.
438 -- The name of the attribute we are testing is specified in Attribute_Name,
439 -- which is used in the error message. Location is the location where the
440 -- suffix is defined.
442 procedure Locate_Directory
443 (Project : Project_Id;
444 Name : File_Name_Type;
445 Path : out Path_Information;
446 Dir_Exists : out Boolean;
447 Data : in out Tree_Processing_Data;
449 Location : Source_Ptr := No_Location;
450 Must_Exist : Boolean := True;
451 Externally_Built : Boolean := False);
452 -- Locate a directory. Name is the directory name. Relative paths are
453 -- resolved relative to the project's directory. If the directory does not
454 -- exist and Setup_Projects is True and Create is a non null string, an
455 -- attempt is made to create the directory. If the directory does not
456 -- exist, it is either created if Setup_Projects is False (and then
457 -- returned), or simply returned without checking for its existence (if
458 -- Must_Exist is False) or No_Path_Information is returned. In all cases,
459 -- Dir_Exists indicates whether the directory now exists. Create is also
460 -- used for debugging traces to show which path we are computing.
462 procedure Look_For_Sources
463 (Project : in out Project_Processing_Data;
464 Data : in out Tree_Processing_Data);
465 -- Find all the sources of project Project in project tree Data.Tree and
466 -- update its Data accordingly. This assumes that the special naming
467 -- exceptions have already been processed.
469 function Path_Name_Of
470 (File_Name : File_Name_Type;
471 Directory : Path_Name_Type) return String;
472 -- Returns the path name of a (non project) file. Returns an empty string
473 -- if file cannot be found.
475 procedure Remove_Source
476 (Tree : Project_Tree_Ref;
477 Id : Source_Id;
478 Replaced_By : Source_Id);
479 -- Remove a file from the list of sources of a project. This might be
480 -- because the file is replaced by another one in an extending project,
481 -- or because a file was added as a naming exception but was not found
482 -- in the end.
484 procedure Report_No_Sources
485 (Project : Project_Id;
486 Lang_Name : String;
487 Data : Tree_Processing_Data;
488 Location : Source_Ptr;
489 Continuation : Boolean := False);
490 -- Report an error or a warning depending on the value of When_No_Sources
491 -- when there are no sources for language Lang_Name.
493 procedure Show_Source_Dirs
494 (Project : Project_Id;
495 Shared : Shared_Project_Tree_Data_Access);
496 -- List all the source directories of a project
498 procedure Write_Attr (Name, Value : String);
499 -- Debug print a value for a specific property. Does nothing when not in
500 -- debug mode
502 procedure Error_Or_Warning
503 (Flags : Processing_Flags;
504 Kind : Error_Warning;
505 Msg : String;
506 Location : Source_Ptr;
507 Project : Project_Id);
508 -- Emits either an error or warning message (or nothing), depending on Kind
510 function No_Space_Img (N : Natural) return String;
511 -- Image of a Natural without the initial space
513 ----------------------
514 -- Error_Or_Warning --
515 ----------------------
517 procedure Error_Or_Warning
518 (Flags : Processing_Flags;
519 Kind : Error_Warning;
520 Msg : String;
521 Location : Source_Ptr;
522 Project : Project_Id) is
523 begin
524 case Kind is
525 when Error => Error_Msg (Flags, Msg, Location, Project);
527 when Silent => null;
528 end case;
529 end Error_Or_Warning;
531 ------------------------------
532 -- Replace_Into_Name_Buffer --
533 ------------------------------
535 procedure Replace_Into_Name_Buffer
536 (Str : String;
537 Pattern : String;
538 Replacement : Character)
539 is
540 Max : constant Integer := Str'Last - Pattern'Length + 1;
541 J : Positive;
543 begin
544 Name_Len := 0;
546 J := Str'First;
547 while J <= Str'Last loop
548 Name_Len := Name_Len + 1;
550 if J <= Max
551 and then Str (J .. J + Pattern'Length - 1) = Pattern
552 then
553 Name_Buffer (Name_Len) := Replacement;
554 J := J + Pattern'Length;
556 else
557 Name_Buffer (Name_Len) := GNAT.Case_Util.To_Lower (Str (J));
558 J := J + 1;
559 end if;
560 end loop;
561 end Replace_Into_Name_Buffer;
563 --------------------
564 -- Suffix_Matches --
565 --------------------
567 function Suffix_Matches
568 (Filename : String;
569 Suffix : File_Name_Type) return Boolean
570 is
571 Min_Prefix_Length : Natural := 0;
573 begin
574 if Suffix = No_File or else Suffix = Empty_File then
575 return False;
576 end if;
578 declare
579 Suf : String := Get_Name_String (Suffix);
581 begin
582 -- On non case-sensitive systems, use proper suffix casing
584 Canonical_Case_File_Name (Suf);
586 -- The file name must end with the suffix (which is not an extension)
588 -- same name. To avoid dummy cases, though, a suffix starting with
589 -- '.' requires a file that is at least one character longer ('.cpp'
590 -- should not match a file with the same name).
592 if Suf (Suf'First) = '.' then
593 Min_Prefix_Length := 1;
594 end if;
596 return Filename'Length >= Suf'Length + Min_Prefix_Length
597 and then
598 Filename (Filename'Last - Suf'Length + 1 .. Filename'Last) = Suf;
599 end;
600 end Suffix_Matches;
602 ----------------
603 -- Write_Attr --
604 ----------------
606 procedure Write_Attr (Name, Value : String) is
607 begin
608 if Current_Verbosity = High then
610 end if;
611 end Write_Attr;
613 ----------------
614 -- Add_Source --
615 ----------------
617 procedure Add_Source
618 (Id : out Source_Id;
619 Data : in out Tree_Processing_Data;
620 Project : Project_Id;
621 Source_Dir_Rank : Natural;
622 Lang_Id : Language_Ptr;
623 Kind : Source_Kind;
624 File_Name : File_Name_Type;
625 Display_File : File_Name_Type;
626 Naming_Exception : Naming_Exception_Type := No;
627 Path : Path_Information := No_Path_Information;
628 Alternate_Languages : Language_List := null;
629 Unit : Name_Id := No_Name;
630 Index : Int := 0;
631 Locally_Removed : Boolean := False;
632 Location : Source_Ptr := No_Location)
633 is
634 Config : constant Language_Config := Lang_Id.Config;
635 UData : Unit_Index;
636 Add_Src : Boolean;
637 Source : Source_Id;
638 Prev_Unit : Unit_Index := No_Unit_Index;
639 Source_To_Replace : Source_Id := No_Source;
641 begin
642 -- Check if the same file name or unit is used in the prj tree
644 Add_Src := True;
646 if Unit /= No_Name then
647 Prev_Unit := Units_Htable.Get (Data.Tree.Units_HT, Unit);
648 end if;
650 if Prev_Unit /= No_Unit_Index
651 and then (Kind = Impl or else Kind = Spec)
652 and then Prev_Unit.File_Names (Kind) /= null
653 then
654 -- Suspicious, we need to check later whether this is authorized
656 Add_Src := False;
657 Source := Prev_Unit.File_Names (Kind);
659 else
660 Source := Source_Files_Htable.Get
661 (Data.Tree.Source_Files_HT, File_Name);
663 if Source /= No_Source and then Source.Index = Index then
664 Add_Src := False;
665 end if;
666 end if;
668 -- Always add the source if it is locally removed, to avoid incorrect
669 -- duplicate checks.
671 if Locally_Removed then
672 Add_Src := True;
674 -- A locally removed source may first replace a source in a project
675 -- being extended.
677 if Source /= No_Source
678 and then Is_Extending (Project, Source.Project)
679 and then Naming_Exception /= Inherited
680 then
681 Source_To_Replace := Source;
682 end if;
684 else
685 -- Duplication of file/unit in same project is allowed if order of
686 -- source directories is known, or if there is no compiler for the
687 -- language.
689 if Add_Src = False then
690 Add_Src := True;
692 if Project = Source.Project then
693 if Prev_Unit = No_Unit_Index then
694 if Data.Flags.Allow_Duplicate_Basenames then
695 Add_Src := True;
697 elsif Lang_Id.Config.Compiler_Driver = Empty_File then
698 Add_Src := True;
700 elsif Source_Dir_Rank /= Source.Source_Dir_Rank then
701 Add_Src := False;
703 else
704 Error_Msg_File_1 := File_Name;
705 Error_Msg
706 (Data.Flags, "duplicate source file name {",
707 Location, Project);
708 Add_Src := False;
709 end if;
711 else
712 if Source_Dir_Rank /= Source.Source_Dir_Rank then
713 Add_Src := False;
715 -- We might be seeing the same file through a different
716 -- path (for instance because of symbolic links).
718 elsif Source.Path.Name /= Path.Name then
719 if not Source.Duplicate_Unit then
720 Error_Msg_Name_1 := Unit;
721 Error_Msg
722 (Data.Flags,
724 Location,
725 Project);
726 Source.Duplicate_Unit := True;
727 end if;
729 Add_Src := False;
730 end if;
731 end if;
733 -- Do not allow the same unit name in different projects,
734 -- except if one is extending the other.
736 -- For a file based language, the same file name replaces a
737 -- file in a project being extended, but it is allowed to have
738 -- the same file name in unrelated projects.
740 elsif Is_Extending (Project, Source.Project) then
741 if not Locally_Removed
742 and then Naming_Exception /= Inherited
743 then
744 Source_To_Replace := Source;
745 end if;
747 elsif Prev_Unit /= No_Unit_Index
748 and then Prev_Unit.File_Names (Kind) /= null
749 and then not Source.Locally_Removed
750 and then Source.Replaced_By = No_Source
751 and then not Data.In_Aggregate_Lib
752 then
753 -- Path is set if this is a source we found on the disk, in
754 -- which case we can provide more explicit error message. Path
755 -- is unset when the source is added from one of the naming
756 -- exceptions in the project.
758 if Path /= No_Path_Information then
759 Error_Msg_Name_1 := Unit;
760 Error_Msg
761 (Data.Flags,
762 "unit %% cannot belong to several projects",
763 Location, Project);
765 Error_Msg_Name_1 := Project.Name;
766 Error_Msg_Name_2 := Name_Id (Path.Display_Name);
767 Error_Msg
770 Error_Msg_Name_1 := Source.Project.Name;
771 Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name);
772 Error_Msg
775 else
776 Error_Msg_Name_1 := Unit;
777 Error_Msg_Name_2 := Source.Project.Name;
778 Error_Msg
779 (Data.Flags, "unit %% already belongs to project %%",
780 Location, Project);
781 end if;
783 Add_Src := False;
785 elsif not Source.Locally_Removed
786 and then Source.Replaced_By /= No_Source
787 and then not Data.Flags.Allow_Duplicate_Basenames
788 and then Lang_Id.Config.Kind = Unit_Based
789 and then Source.Language.Config.Kind = Unit_Based
790 and then not Data.In_Aggregate_Lib
791 then
792 Error_Msg_File_1 := File_Name;
793 Error_Msg_File_2 := File_Name_Type (Source.Project.Name);
794 Error_Msg
795 (Data.Flags,
796 "{ is already a source of project {", Location, Project);
798 -- Add the file anyway, to avoid further warnings like
799 -- "language unknown".
801 Add_Src := True;
802 end if;
803 end if;
804 end if;
806 if not Add_Src then
807 return;
808 end if;
810 -- Add the new file
812 Id := new Source_Data;
814 if Current_Verbosity = High then
815 Debug_Indent;
816 Write_Str ("adding source File: ");
817 Write_Str (Get_Name_String (Display_File));
819 if Index /= 0 then
820 Write_Str (" at" & Index'Img);
821 end if;
823 if Lang_Id.Config.Kind = Unit_Based then
824 Write_Str (" Unit: ");
826 -- ??? in gprclean, it seems we sometimes pass an empty Unit name
827 -- (see test extended_projects).
829 if Unit /= No_Name then
830 Write_Str (Get_Name_String (Unit));
831 end if;
833 Write_Str (" Kind: ");
834 Write_Str (Source_Kind'Image (Kind));
835 end if;
837 Write_Eol;
838 end if;
840 Id.Project := Project;
841 Id.Location := Location;
842 Id.Source_Dir_Rank := Source_Dir_Rank;
843 Id.Language := Lang_Id;
844 Id.Kind := Kind;
845 Id.Alternate_Languages := Alternate_Languages;
846 Id.Locally_Removed := Locally_Removed;
847 Id.Index := Index;
848 Id.File := File_Name;
849 Id.Display_File := Display_File;
850 Id.Dep_Name := Dependency_Name
851 (File_Name, Lang_Id.Config.Dependency_Kind);
852 Id.Naming_Exception := Naming_Exception;
853 Id.Object := Object_Name
854 (File_Name, Config.Object_File_Suffix);
855 Id.Switches := Switches_Name (File_Name);
857 -- Add the source id to the Unit_Sources_HT hash table, if the unit name
858 -- is not null.
860 if Unit /= No_Name then
862 -- Note: we might be creating a dummy unit here, when we in fact have
863 -- a separate. For instance, file file-bar.adb will initially be
864 -- assumed to be the IMPL of unit "file.bar". Only later on (in
865 -- Check_Object_Files) will we parse those units that only have an
866 -- impl and no spec to make sure whether we have a Separate in fact
867 -- (that significantly reduces the number of times we need to parse
868 -- the files, since we are then only interested in those with no
869 -- spec). We still need those dummy units in the table, since that's
870 -- the name we find in the ALI file
872 UData := Units_Htable.Get (Data.Tree.Units_HT, Unit);
874 if UData = No_Unit_Index then
875 UData := new Unit_Data;
876 UData.Name := Unit;
878 if Naming_Exception /= Inherited then
879 Units_Htable.Set (Data.Tree.Units_HT, Unit, UData);
880 end if;
881 end if;
883 Id.Unit := UData;
885 -- Note that this updates Unit information as well
887 if Naming_Exception /= Inherited and then not Locally_Removed then
888 Override_Kind (Id, Kind);
889 end if;
890 end if;
892 if Path /= No_Path_Information then
893 Id.Path := Path;
894 Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path.Name, Id);
895 end if;
897 Id.Next_With_File_Name :=
898 Source_Files_Htable.Get (Data.Tree.Source_Files_HT, File_Name);
899 Source_Files_Htable.Set (Data.Tree.Source_Files_HT, File_Name, Id);
901 if Index /= 0 then
902 Project.Has_Multi_Unit_Sources := True;
903 end if;
905 -- Add the source to the language list
907 Id.Next_In_Lang := Lang_Id.First_Source;
908 Lang_Id.First_Source := Id;
910 if Source_To_Replace /= No_Source then
911 Remove_Source (Data.Tree, Source_To_Replace, Id);
912 end if;
914 if Data.Tree.Replaced_Source_Number > 0
915 and then
916 Replaced_Source_HTable.Get
917 (Data.Tree.Replaced_Sources, Id.File) /= No_File
918 then
919 Replaced_Source_HTable.Remove (Data.Tree.Replaced_Sources, Id.File);
920 Data.Tree.Replaced_Source_Number :=
921 Data.Tree.Replaced_Source_Number - 1;
922 end if;
923 end Add_Source;
925 ------------------------------
926 -- Canonical_Case_File_Name --
927 ------------------------------
929 function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type is
930 begin
931 if Osint.File_Names_Case_Sensitive then
932 return File_Name_Type (Name);
933 else
934 Get_Name_String (Name);
935 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
936 return Name_Find;
937 end if;
938 end Canonical_Case_File_Name;
940 ---------------------------------
941 -- Process_Aggregated_Projects --
942 ---------------------------------
944 procedure Process_Aggregated_Projects
945 (Tree : Project_Tree_Ref;
946 Project : Project_Id;
947 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
948 Flags : Processing_Flags)
949 is
950 Data : Tree_Processing_Data :=
951 (Tree => Tree,
952 Node_Tree => Node_Tree,
953 Flags => Flags,
954 In_Aggregate_Lib => False);
956 Project_Files : constant Prj.Variable_Value :=
957 Prj.Util.Value_Of
958 (Snames.Name_Project_Files,
959 Project.Decl.Attributes,
960 Tree.Shared);
962 Project_Path_For_Aggregate : Prj.Env.Project_Search_Path;
964 procedure Found_Project_File (Path : Path_Information; Rank : Natural);
965 -- Called for each project file aggregated by Project
967 procedure Expand_Project_Files is
968 new Expand_Subdirectory_Pattern (Callback => Found_Project_File);
969 -- Search for all project files referenced by the patterns given in
970 -- parameter. Calls Found_Project_File for each of them.
972 ------------------------
973 -- Found_Project_File --
974 ------------------------
976 procedure Found_Project_File (Path : Path_Information; Rank : Natural) is
977 pragma Unreferenced (Rank);
979 begin
980 if Path.Name /= Project.Path.Name then
981 Debug_Output ("aggregates: ", Name_Id (Path.Display_Name));
983 -- For usual "with" statement, this phase will have been done when
984 -- parsing the project itself. However, for aggregate projects, we
985 -- can only do this when processing the aggregate project, since
986 -- the exact list of project files or project directories can
987 -- depend on scenario variables.
988 --
989 -- We only load the projects explicitly here, but do not process
990 -- them. For the processing, Prj.Proc will take care of processing
991 -- them, within the same call to Recursive_Process (thus avoiding
992 -- the processing of a given project multiple times).
993 --
994 -- ??? We might already have loaded the project
996 Add_Aggregated_Project (Project, Path => Path.Name);
998 else
999 Debug_Output ("pattern returned the aggregate itself, ignored");
1000 end if;
1001 end Found_Project_File;
1003 -- Start of processing for Check_Aggregate_Project
1005 begin
1006 pragma Assert (Project.Qualifier in Aggregate_Project);
1008 if Project_Files.Default then
1009 Error_Msg_Name_1 := Snames.Name_Project_Files;
1010 Error_Msg
1011 (Flags,
1012 "Attribute %% must be specified in aggregate project",
1013 Project.Location, Project);
1014 return;
1015 end if;
1017 -- The aggregated projects are only searched relative to the directory
1018 -- of the aggregate project, not in the default project path.
1020 Initialize_Empty (Project_Path_For_Aggregate);
1022 Free (Project.Aggregated_Projects);
1024 -- Look for aggregated projects. For similarity with source files and
1025 -- dirs, the aggregated project files are not searched for on the
1026 -- project path, and are only found through the path specified in
1027 -- the Project_Files attribute.
1029 Expand_Project_Files
1030 (Project => Project,
1031 Data => Data,
1032 Patterns => Project_Files.Values,
1033 Ignore => Nil_String,
1034 Search_For => Search_Files,
1035 Resolve_Links => Opt.Follow_Links_For_Files);
1037 Free (Project_Path_For_Aggregate);
1038 end Process_Aggregated_Projects;
1040 ----------------------------
1041 -- Check_Abstract_Project --
1042 ----------------------------
1044 procedure Check_Abstract_Project
1045 (Project : Project_Id;
1046 Data : in out Tree_Processing_Data)
1047 is
1048 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
1050 Source_Dirs : constant Variable_Value :=
1051 Util.Value_Of
1052 (Name_Source_Dirs,
1053 Project.Decl.Attributes, Shared);
1054 Source_Files : constant Variable_Value :=
1055 Util.Value_Of
1056 (Name_Source_Files,
1057 Project.Decl.Attributes, Shared);
1058 Source_List_File : constant Variable_Value :=
1059 Util.Value_Of
1060 (Name_Source_List_File,
1061 Project.Decl.Attributes, Shared);
1062 Languages : constant Variable_Value :=
1063 Util.Value_Of
1064 (Name_Languages,
1065 Project.Decl.Attributes, Shared);
1067 begin
1068 if Project.Source_Dirs /= Nil_String then
1069 if Source_Dirs.Values = Nil_String
1070 and then Source_Files.Values = Nil_String
1071 and then Languages.Values = Nil_String
1072 and then Source_List_File.Default
1073 then
1074 Project.Source_Dirs := Nil_String;
1076 else
1077 Error_Msg
1078 (Data.Flags,
1079 "at least one of Source_Files, Source_Dirs or Languages "
1080 & "must be declared empty for an abstract project",
1081 Project.Location, Project);
1082 end if;
1083 end if;
1084 end Check_Abstract_Project;
1086 -------------------------
1087 -- Check_Configuration --
1088 -------------------------
1090 procedure Check_Configuration
1091 (Project : Project_Id;
1092 Data : in out Tree_Processing_Data)
1093 is
1094 Shared : constant Shared_Project_Tree_Data_Access :=
1095 Data.Tree.Shared;
1097 Dot_Replacement : File_Name_Type := No_File;
1098 Casing : Casing_Type := All_Lower_Case;
1099 Separate_Suffix : File_Name_Type := No_File;
1101 Lang_Index : Language_Ptr := No_Language_Index;
1102 -- The index of the language data being checked
1104 Prev_Index : Language_Ptr := No_Language_Index;
1105 -- The index of the previous language
1107 procedure Process_Project_Level_Simple_Attributes;
1108 -- Process the simple attributes at the project level
1110 procedure Process_Project_Level_Array_Attributes;
1111 -- Process the associate array attributes at the project level
1113 procedure Process_Packages;
1114 -- Read the packages of the project
1116 ----------------------
1117 -- Process_Packages --
1118 ----------------------
1120 procedure Process_Packages is
1121 Packages : Package_Id;
1122 Element : Package_Element;
1124 procedure Process_Binder (Arrays : Array_Id);
1125 -- Process the associated array attributes of package Binder
1127 procedure Process_Builder (Attributes : Variable_Id);
1128 -- Process the simple attributes of package Builder
1130 procedure Process_Clean (Arrays : Array_Id);
1131 -- Process the associated array attributes of package Clean
1133 procedure Process_Compiler (Arrays : Array_Id);
1134 -- Process the associated array attributes of package Compiler
1136 procedure Process_Naming (Attributes : Variable_Id);
1137 -- Process the simple attributes of package Naming
1139 procedure Process_Naming (Arrays : Array_Id);
1140 -- Process the associated array attributes of package Naming
1142 procedure Process_Linker (Attributes : Variable_Id);
1143 -- Process the simple attributes of package Linker of a
1144 -- configuration project.
1146 --------------------
1147 -- Process_Binder --
1148 --------------------
1150 procedure Process_Binder (Arrays : Array_Id) is
1151 Current_Array_Id : Array_Id;
1152 Current_Array : Array_Data;
1153 Element_Id : Array_Element_Id;
1154 Element : Array_Element;
1156 begin
1157 -- Process the associative array attribute of package Binder
1159 Current_Array_Id := Arrays;
1160 while Current_Array_Id /= No_Array loop
1161 Current_Array := Shared.Arrays.Table (Current_Array_Id);
1163 Element_Id := Current_Array.Value;
1164 while Element_Id /= No_Array_Element loop
1165 Element := Shared.Array_Elements.Table (Element_Id);
1167 if Element.Index /= All_Other_Names then
1169 -- Get the name of the language
1171 Lang_Index :=
1172 Get_Language_From_Name
1173 (Project, Get_Name_String (Element.Index));
1175 if Lang_Index /= No_Language_Index then
1176 case Current_Array.Name is
1177 when Name_Driver =>
1179 -- Attribute Driver (<language>)
1181 Lang_Index.Config.Binder_Driver :=
1182 File_Name_Type (Element.Value.Value);
1184 when Name_Required_Switches =>
1185 Put
1186 (Into_List =>
1187 Lang_Index.Config.Binder_Required_Switches,
1188 From_List => Element.Value.Values,
1189 In_Tree => Data.Tree);
1191 when Name_Prefix =>
1193 -- Attribute Prefix (<language>)
1195 Lang_Index.Config.Binder_Prefix :=
1196 Element.Value.Value;
1198 when Name_Objects_Path =>
1200 -- Attribute Objects_Path (<language>)
1202 Lang_Index.Config.Objects_Path :=
1203 Element.Value.Value;
1205 when Name_Objects_Path_File =>
1207 -- Attribute Objects_Path (<language>)
1209 Lang_Index.Config.Objects_Path_File :=
1210 Element.Value.Value;
1212 when others =>
1213 null;
1214 end case;
1215 end if;
1216 end if;
1218 Element_Id := Element.Next;
1219 end loop;
1221 Current_Array_Id := Current_Array.Next;
1222 end loop;
1223 end Process_Binder;
1225 ---------------------
1226 -- Process_Builder --
1227 ---------------------
1229 procedure Process_Builder (Attributes : Variable_Id) is
1230 Attribute_Id : Variable_Id;
1231 Attribute : Variable;
1233 begin
1234 -- Process non associated array attribute from package Builder
1236 Attribute_Id := Attributes;
1237 while Attribute_Id /= No_Variable loop
1238 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
1240 if not Attribute.Value.Default then
1241 if Attribute.Name = Name_Executable_Suffix then
1243 -- Attribute Executable_Suffix: the suffix of the
1244 -- executables.
1246 Project.Config.Executable_Suffix :=
1247 Attribute.Value.Value;
1248 end if;
1249 end if;
1251 Attribute_Id := Attribute.Next;
1252 end loop;
1253 end Process_Builder;
1255 -------------------
1256 -- Process_Clean --
1257 -------------------
1259 procedure Process_Clean (Arrays : Array_Id) is
1260 Current_Array_Id : Array_Id;
1261 Current_Array : Array_Data;
1262 Element_Id : Array_Element_Id;
1263 Element : Array_Element;
1264 List : String_List_Id;
1266 begin
1267 -- Process the associated array attributes of package Clean
1269 Current_Array_Id := Arrays;
1270 while Current_Array_Id /= No_Array loop
1271 Current_Array := Shared.Arrays.Table (Current_Array_Id);
1273 Element_Id := Current_Array.Value;
1274 while Element_Id /= No_Array_Element loop
1275 Element := Shared.Array_Elements.Table (Element_Id);
1277 -- Get the name of the language
1279 Lang_Index :=
1280 Get_Language_From_Name
1281 (Project, Get_Name_String (Element.Index));
1283 if Lang_Index /= No_Language_Index then
1284 case Current_Array.Name is
1286 -- Attribute Object_Artifact_Extensions (<language>)
1288 when Name_Object_Artifact_Extensions =>
1289 List := Element.Value.Values;
1291 if List /= Nil_String then
1292 Put (Into_List =>
1293 Lang_Index.Config.Clean_Object_Artifacts,
1294 From_List => List,
1295 In_Tree => Data.Tree);
1296 end if;
1298 -- Attribute Source_Artifact_Extensions (<language>)
1300 when Name_Source_Artifact_Extensions =>
1301 List := Element.Value.Values;
1303 if List /= Nil_String then
1304 Put (Into_List =>
1305 Lang_Index.Config.Clean_Source_Artifacts,
1306 From_List => List,
1307 In_Tree => Data.Tree);
1308 end if;
1310 when others =>
1311 null;
1312 end case;
1313 end if;
1315 Element_Id := Element.Next;
1316 end loop;
1318 Current_Array_Id := Current_Array.Next;
1319 end loop;
1320 end Process_Clean;
1322 ----------------------
1323 -- Process_Compiler --
1324 ----------------------
1326 procedure Process_Compiler (Arrays : Array_Id) is
1327 Current_Array_Id : Array_Id;
1328 Current_Array : Array_Data;
1329 Element_Id : Array_Element_Id;
1330 Element : Array_Element;
1331 List : String_List_Id;
1333 begin
1334 -- Process the associative array attribute of package Compiler
1336 Current_Array_Id := Arrays;
1337 while Current_Array_Id /= No_Array loop
1338 Current_Array := Shared.Arrays.Table (Current_Array_Id);
1340 Element_Id := Current_Array.Value;
1341 while Element_Id /= No_Array_Element loop
1342 Element := Shared.Array_Elements.Table (Element_Id);
1344 if Element.Index /= All_Other_Names then
1346 -- Get the name of the language
1348 Lang_Index := Get_Language_From_Name
1349 (Project, Get_Name_String (Element.Index));
1351 if Lang_Index /= No_Language_Index then
1352 case Current_Array.Name is
1354 -- Attribute Dependency_Kind (<language>)
1356 when Name_Dependency_Kind =>
1357 Get_Name_String (Element.Value.Value);
1359 begin
1360 Lang_Index.Config.Dependency_Kind :=
1361 Dependency_File_Kind'Value
1362 (Name_Buffer (1 .. Name_Len));
1364 exception
1365 when Constraint_Error =>
1366 Error_Msg
1367 (Data.Flags,
1368 "illegal value for Dependency_Kind",
1369 Element.Value.Location,
1370 Project);
1371 end;
1373 -- Attribute Dependency_Switches (<language>)
1375 when Name_Dependency_Switches =>
1376 if Lang_Index.Config.Dependency_Kind = None then
1377 Lang_Index.Config.Dependency_Kind := Makefile;
1378 end if;
1380 List := Element.Value.Values;
1382 if List /= Nil_String then
1383 Put (Into_List =>
1384 Lang_Index.Config.Dependency_Option,
1385 From_List => List,
1386 In_Tree => Data.Tree);
1387 end if;
1389 -- Attribute Dependency_Driver (<language>)
1391 when Name_Dependency_Driver =>
1392 if Lang_Index.Config.Dependency_Kind = None then
1393 Lang_Index.Config.Dependency_Kind := Makefile;
1394 end if;
1396 List := Element.Value.Values;
1398 if List /= Nil_String then
1399 Put (Into_List =>
1400 Lang_Index.Config.Compute_Dependency,
1401 From_List => List,
1402 In_Tree => Data.Tree);
1403 end if;
1405 -- Attribute Language_Kind (<language>)
1407 when Name_Language_Kind =>
1408 Get_Name_String (Element.Value.Value);
1410 begin
1411 Lang_Index.Config.Kind :=
1412 Language_Kind'Value
1413 (Name_Buffer (1 .. Name_Len));
1415 exception
1416 when Constraint_Error =>
1417 Error_Msg
1418 (Data.Flags,
1419 "illegal value for Language_Kind",
1420 Element.Value.Location,
1421 Project);
1422 end;
1424 -- Attribute Include_Switches (<language>)
1426 when Name_Include_Switches =>
1427 List := Element.Value.Values;
1429 if List = Nil_String then
1430 Error_Msg
1431 (Data.Flags, "include option cannot be null",
1432 Element.Value.Location, Project);
1433 end if;
1435 Put (Into_List => Lang_Index.Config.Include_Option,
1436 From_List => List,
1437 In_Tree => Data.Tree);
1439 -- Attribute Include_Path (<language>)
1441 when Name_Include_Path =>
1442 Lang_Index.Config.Include_Path :=
1443 Element.Value.Value;
1445 -- Attribute Include_Path_File (<language>)
1447 when Name_Include_Path_File =>
1448 Lang_Index.Config.Include_Path_File :=
1449 Element.Value.Value;
1451 -- Attribute Driver (<language>)
1453 when Name_Driver =>
1454 Lang_Index.Config.Compiler_Driver :=
1455 File_Name_Type (Element.Value.Value);
1457 when Name_Required_Switches
1458 | Name_Leading_Required_Switches
1459 =>
1460 Put (Into_List =>
1461 Lang_Index.Config.
1462 Compiler_Leading_Required_Switches,
1463 From_List => Element.Value.Values,
1464 In_Tree => Data.Tree);
1466 when Name_Trailing_Required_Switches =>
1467 Put (Into_List =>
1468 Lang_Index.Config.
1469 Compiler_Trailing_Required_Switches,
1470 From_List => Element.Value.Values,
1471 In_Tree => Data.Tree);
1473 when Name_Multi_Unit_Switches =>
1474 Put (Into_List =>
1475 Lang_Index.Config.Multi_Unit_Switches,
1476 From_List => Element.Value.Values,
1477 In_Tree => Data.Tree);
1479 when Name_Multi_Unit_Object_Separator =>
1480 Get_Name_String (Element.Value.Value);
1482 if Name_Len /= 1 then
1483 Error_Msg
1484 (Data.Flags,
1485 "multi-unit object separator must have " &
1486 "a single character",
1487 Element.Value.Location, Project);
1490 Error_Msg
1491 (Data.Flags,
1492 "multi-unit object separator cannot be " &
1493 "a space",
1494 Element.Value.Location, Project);
1496 else
1497 Lang_Index.Config.Multi_Unit_Object_Separator :=
1498 Name_Buffer (1);
1499 end if;
1501 when Name_Path_Syntax =>
1502 begin
1503 Lang_Index.Config.Path_Syntax :=
1504 Path_Syntax_Kind'Value
1505 (Get_Name_String (Element.Value.Value));
1507 exception
1508 when Constraint_Error =>
1509 Error_Msg
1510 (Data.Flags,
1511 "invalid value for Path_Syntax",
1512 Element.Value.Location, Project);
1513 end;
1515 when Name_Source_File_Switches =>
1516 Put (Into_List =>
1517 Lang_Index.Config.Source_File_Switches,
1518 From_List => Element.Value.Values,
1519 In_Tree => Data.Tree);
1521 when Name_Object_File_Suffix =>
1522 if Get_Name_String (Element.Value.Value) = "" then
1523 Error_Msg
1524 (Data.Flags,
1525 "object file suffix cannot be empty",
1526 Element.Value.Location, Project);
1528 else
1529 Lang_Index.Config.Object_File_Suffix :=
1530 Element.Value.Value;
1531 end if;
1533 when Name_Object_File_Switches =>
1534 Put (Into_List =>
1535 Lang_Index.Config.Object_File_Switches,
1536 From_List => Element.Value.Values,
1537 In_Tree => Data.Tree);
1539 when Name_Object_Path_Switches =>
1540 Put (Into_List =>
1541 Lang_Index.Config.Object_Path_Switches,
1542 From_List => Element.Value.Values,
1543 In_Tree => Data.Tree);
1545 -- Attribute Compiler_Pic_Option (<language>)
1547 when Name_Pic_Option =>
1548 List := Element.Value.Values;
1550 if List = Nil_String then
1551 Error_Msg
1552 (Data.Flags,
1553 "compiler PIC option cannot be null",
1554 Element.Value.Location, Project);
1555 end if;
1557 Put (Into_List =>
1558 Lang_Index.Config.Compilation_PIC_Option,
1559 From_List => List,
1560 In_Tree => Data.Tree);
1562 -- Attribute Mapping_File_Switches (<language>)
1564 when Name_Mapping_File_Switches =>
1565 List := Element.Value.Values;
1567 if List = Nil_String then
1568 Error_Msg
1569 (Data.Flags,
1570 "mapping file switches cannot be null",
1571 Element.Value.Location, Project);
1572 end if;
1574 Put (Into_List =>
1575 Lang_Index.Config.Mapping_File_Switches,
1576 From_List => List,
1577 In_Tree => Data.Tree);
1579 -- Attribute Mapping_Spec_Suffix (<language>)
1581 when Name_Mapping_Spec_Suffix =>
1582 Lang_Index.Config.Mapping_Spec_Suffix :=
1583 File_Name_Type (Element.Value.Value);
1585 -- Attribute Mapping_Body_Suffix (<language>)
1587 when Name_Mapping_Body_Suffix =>
1588 Lang_Index.Config.Mapping_Body_Suffix :=
1589 File_Name_Type (Element.Value.Value);
1591 -- Attribute Config_File_Switches (<language>)
1593 when Name_Config_File_Switches =>
1594 List := Element.Value.Values;
1596 if List = Nil_String then
1597 Error_Msg
1598 (Data.Flags,
1599 "config file switches cannot be null",
1600 Element.Value.Location, Project);
1601 end if;
1603 Put (Into_List =>
1604 Lang_Index.Config.Config_File_Switches,
1605 From_List => List,
1606 In_Tree => Data.Tree);
1608 -- Attribute Objects_Path (<language>)
1610 when Name_Objects_Path =>
1611 Lang_Index.Config.Objects_Path :=
1612 Element.Value.Value;
1614 -- Attribute Objects_Path_File (<language>)
1616 when Name_Objects_Path_File =>
1617 Lang_Index.Config.Objects_Path_File :=
1618 Element.Value.Value;
1620 -- Attribute Config_Body_File_Name (<language>)
1622 when Name_Config_Body_File_Name =>
1623 Lang_Index.Config.Config_Body :=
1624 Element.Value.Value;
1626 -- Attribute Config_Body_File_Name_Index (< Language>)
1628 when Name_Config_Body_File_Name_Index =>
1629 Lang_Index.Config.Config_Body_Index :=
1630 Element.Value.Value;
1632 -- Attribute Config_Body_File_Name_Pattern(<language>)
1634 when Name_Config_Body_File_Name_Pattern =>
1635 Lang_Index.Config.Config_Body_Pattern :=
1636 Element.Value.Value;
1638 -- Attribute Config_Spec_File_Name (<language>)
1640 when Name_Config_Spec_File_Name =>
1641 Lang_Index.Config.Config_Spec :=
1642 Element.Value.Value;
1644 -- Attribute Config_Spec_File_Name_Index (<language>)
1646 when Name_Config_Spec_File_Name_Index =>
1647 Lang_Index.Config.Config_Spec_Index :=
1648 Element.Value.Value;
1650 -- Attribute Config_Spec_File_Name_Pattern(<language>)
1652 when Name_Config_Spec_File_Name_Pattern =>
1653 Lang_Index.Config.Config_Spec_Pattern :=
1654 Element.Value.Value;
1656 -- Attribute Config_File_Unique (<language>)
1658 when Name_Config_File_Unique =>
1659 begin
1660 Lang_Index.Config.Config_File_Unique :=
1661 Boolean'Value
1662 (Get_Name_String (Element.Value.Value));
1663 exception
1664 when Constraint_Error =>
1665 Error_Msg
1666 (Data.Flags,
1667 "illegal value for Config_File_Unique",
1668 Element.Value.Location, Project);
1669 end;
1671 when others =>
1672 null;
1673 end case;
1674 end if;
1675 end if;
1677 Element_Id := Element.Next;
1678 end loop;
1680 Current_Array_Id := Current_Array.Next;
1681 end loop;
1682 end Process_Compiler;
1684 --------------------
1685 -- Process_Naming --
1686 --------------------
1688 procedure Process_Naming (Attributes : Variable_Id) is
1689 Attribute_Id : Variable_Id;
1690 Attribute : Variable;
1692 begin
1693 -- Process non associated array attribute from package Naming
1695 Attribute_Id := Attributes;
1696 while Attribute_Id /= No_Variable loop
1697 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
1699 if not Attribute.Value.Default then
1700 if Attribute.Name = Name_Separate_Suffix then
1702 -- Attribute Separate_Suffix
1704 Get_Name_String (Attribute.Value.Value);
1705 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1706 Separate_Suffix := Name_Find;
1708 elsif Attribute.Name = Name_Casing then
1710 -- Attribute Casing
1712 begin
1713 Casing :=
1714 Value (Get_Name_String (Attribute.Value.Value));
1716 exception
1717 when Constraint_Error =>
1718 Error_Msg
1719 (Data.Flags,
1720 "invalid value for Casing",
1721 Attribute.Value.Location, Project);
1722 end;
1724 elsif Attribute.Name = Name_Dot_Replacement then
1726 -- Attribute Dot_Replacement
1728 Dot_Replacement := File_Name_Type (Attribute.Value.Value);
1730 end if;
1731 end if;
1733 Attribute_Id := Attribute.Next;
1734 end loop;
1735 end Process_Naming;
1737 procedure Process_Naming (Arrays : Array_Id) is
1738 Current_Array_Id : Array_Id;
1739 Current_Array : Array_Data;
1740 Element_Id : Array_Element_Id;
1741 Element : Array_Element;
1743 begin
1744 -- Process the associative array attribute of package Naming
1746 Current_Array_Id := Arrays;
1747 while Current_Array_Id /= No_Array loop
1748 Current_Array := Shared.Arrays.Table (Current_Array_Id);
1750 Element_Id := Current_Array.Value;
1751 while Element_Id /= No_Array_Element loop
1752 Element := Shared.Array_Elements.Table (Element_Id);
1754 -- Get the name of the language
1756 Lang_Index := Get_Language_From_Name
1757 (Project, Get_Name_String (Element.Index));
1759 if Lang_Index /= No_Language_Index then
1760 case Current_Array.Name is
1761 when Name_Spec_Suffix | Name_Specification_Suffix =>
1763 -- Attribute Spec_Suffix (<language>)
1765 Get_Name_String (Element.Value.Value);
1766 Canonical_Case_File_Name
1767 (Name_Buffer (1 .. Name_Len));
1768 Lang_Index.Config.Naming_Data.Spec_Suffix :=
1769 Name_Find;
1771 when Name_Implementation_Suffix | Name_Body_Suffix =>
1773 Get_Name_String (Element.Value.Value);
1774 Canonical_Case_File_Name
1775 (Name_Buffer (1 .. Name_Len));
1777 -- Attribute Body_Suffix (<language>)
1779 Lang_Index.Config.Naming_Data.Body_Suffix :=
1780 Name_Find;
1781 Lang_Index.Config.Naming_Data.Separate_Suffix :=
1782 Lang_Index.Config.Naming_Data.Body_Suffix;
1784 when others =>
1785 null;
1786 end case;
1787 end if;
1789 Element_Id := Element.Next;
1790 end loop;
1792 Current_Array_Id := Current_Array.Next;
1793 end loop;
1794 end Process_Naming;
1796 --------------------
1797 -- Process_Linker --
1798 --------------------
1800 procedure Process_Linker (Attributes : Variable_Id) is
1801 Attribute_Id : Variable_Id;
1802 Attribute : Variable;
1804 begin
1805 -- Process non associated array attribute from package Linker
1807 Attribute_Id := Attributes;
1808 while Attribute_Id /= No_Variable loop
1809 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
1811 if not Attribute.Value.Default then
1812 if Attribute.Name = Name_Driver then
1814 -- Attribute Linker'Driver: the default linker to use
1816 Project.Config.Linker :=
1817 Path_Name_Type (Attribute.Value.Value);
1819 -- Linker'Driver is also used to link shared libraries
1820 -- if the obsolescent attribute Library_GCC has not been
1821 -- specified.
1823 if Project.Config.Shared_Lib_Driver = No_File then
1824 Project.Config.Shared_Lib_Driver :=
1825 File_Name_Type (Attribute.Value.Value);
1826 end if;
1828 elsif Attribute.Name = Name_Required_Switches then
1830 -- Attribute Required_Switches: the minimum trailing
1831 -- options to use when invoking the linker
1833 Put (Into_List =>
1834 Project.Config.Trailing_Linker_Required_Switches,
1835 From_List => Attribute.Value.Values,
1836 In_Tree => Data.Tree);
1838 elsif Attribute.Name = Name_Map_File_Option then
1839 Project.Config.Map_File_Option := Attribute.Value.Value;
1841 elsif Attribute.Name = Name_Max_Command_Line_Length then
1842 begin
1843 Project.Config.Max_Command_Line_Length :=
1844 Natural'Value (Get_Name_String
1845 (Attribute.Value.Value));
1847 exception
1848 when Constraint_Error =>
1849 Error_Msg
1850 (Data.Flags,
1851 "value must be positive or equal to 0",
1852 Attribute.Value.Location, Project);
1853 end;
1855 elsif Attribute.Name = Name_Response_File_Format then
1856 declare
1857 Name : Name_Id;
1859 begin
1860 Get_Name_String (Attribute.Value.Value);
1861 To_Lower (Name_Buffer (1 .. Name_Len));
1862 Name := Name_Find;
1864 if Name = Name_None then
1865 Project.Config.Resp_File_Format := None;
1867 elsif Name = Name_Gnu then
1868 Project.Config.Resp_File_Format := GNU;
1870 elsif Name = Name_Object_List then
1871 Project.Config.Resp_File_Format := Object_List;
1873 elsif Name = Name_Option_List then
1874 Project.Config.Resp_File_Format := Option_List;
1876 elsif Name_Buffer (1 .. Name_Len) = "gcc" then
1877 Project.Config.Resp_File_Format := GCC;
1879 elsif Name_Buffer (1 .. Name_Len) = "gcc_gnu" then
1880 Project.Config.Resp_File_Format := GCC_GNU;
1882 elsif
1883 Name_Buffer (1 .. Name_Len) = "gcc_option_list"
1884 then
1885 Project.Config.Resp_File_Format := GCC_Option_List;
1887 elsif
1888 Name_Buffer (1 .. Name_Len) = "gcc_object_list"
1889 then
1890 Project.Config.Resp_File_Format := GCC_Object_List;
1892 else
1893 Error_Msg
1894 (Data.Flags,
1895 "illegal response file format",
1896 Attribute.Value.Location, Project);
1897 end if;
1898 end;
1900 elsif Attribute.Name = Name_Response_File_Switches then
1901 Put (Into_List => Project.Config.Resp_File_Options,
1902 From_List => Attribute.Value.Values,
1903 In_Tree => Data.Tree);
1904 end if;
1905 end if;
1907 Attribute_Id := Attribute.Next;
1908 end loop;
1909 end Process_Linker;
1911 -- Start of processing for Process_Packages
1913 begin
1914 Packages := Project.Decl.Packages;
1915 while Packages /= No_Package loop
1916 Element := Shared.Packages.Table (Packages);
1918 case Element.Name is
1919 when Name_Binder =>
1921 -- Process attributes of package Binder
1923 Process_Binder (Element.Decl.Arrays);
1925 when Name_Builder =>
1927 -- Process attributes of package Builder
1929 Process_Builder (Element.Decl.Attributes);
1931 when Name_Clean =>
1933 -- Process attributes of package Clean
1935 Process_Clean (Element.Decl.Arrays);
1937 when Name_Compiler =>
1939 -- Process attributes of package Compiler
1941 Process_Compiler (Element.Decl.Arrays);
1943 when Name_Linker =>
1945 -- Process attributes of package Linker
1947 Process_Linker (Element.Decl.Attributes);
1949 when Name_Naming =>
1951 -- Process attributes of package Naming
1953 Process_Naming (Element.Decl.Attributes);
1954 Process_Naming (Element.Decl.Arrays);
1956 when others =>
1957 null;
1958 end case;
1960 Packages := Element.Next;
1961 end loop;
1962 end Process_Packages;
1964 ---------------------------------------------
1965 -- Process_Project_Level_Simple_Attributes --
1966 ---------------------------------------------
1968 procedure Process_Project_Level_Simple_Attributes is
1969 Attribute_Id : Variable_Id;
1970 Attribute : Variable;
1971 List : String_List_Id;
1973 begin
1974 -- Process non associated array attribute at project level
1976 Attribute_Id := Project.Decl.Attributes;
1977 while Attribute_Id /= No_Variable loop
1978 Attribute := Shared.Variable_Elements.Table (Attribute_Id);
1980 if not Attribute.Value.Default then
1981 if Attribute.Name = Name_Target then
1983 -- Attribute Target: the target specified
1985 Project.Config.Target := Attribute.Value.Value;
1987 elsif Attribute.Name = Name_Library_Builder then
1989 -- Attribute Library_Builder: the application to invoke
1990 -- to build libraries.
1992 Project.Config.Library_Builder :=
1993 Path_Name_Type (Attribute.Value.Value);
1995 elsif Attribute.Name = Name_Archive_Builder then
1997 -- Attribute Archive_Builder: the archive builder
1998 -- (usually "ar") and its minimum options (usually "cr").
2000 List := Attribute.Value.Values;
2002 if List = Nil_String then
2003 Error_Msg
2004 (Data.Flags,
2005 "archive builder cannot be null",
2006 Attribute.Value.Location, Project);
2007 end if;
2009 Put (Into_List => Project.Config.Archive_Builder,
2010 From_List => List,
2011 In_Tree => Data.Tree);
2013 elsif Attribute.Name = Name_Archive_Builder_Append_Option then
2015 -- Attribute Archive_Builder: the archive builder
2016 -- (usually "ar") and its minimum options (usually "cr").
2018 List := Attribute.Value.Values;
2020 if List /= Nil_String then
2021 Put
2022 (Into_List =>
2023 Project.Config.Archive_Builder_Append_Option,
2024 From_List => List,
2025 In_Tree => Data.Tree);
2026 end if;
2028 elsif Attribute.Name = Name_Archive_Indexer then
2030 -- Attribute Archive_Indexer: the optional archive
2031 -- indexer (usually "ranlib") with its minimum options
2032 -- (usually none).
2034 List := Attribute.Value.Values;
2036 if List = Nil_String then
2037 Error_Msg
2038 (Data.Flags,
2039 "archive indexer cannot be null",
2040 Attribute.Value.Location, Project);
2041 end if;
2043 Put (Into_List => Project.Config.Archive_Indexer,
2044 From_List => List,
2045 In_Tree => Data.Tree);
2047 elsif Attribute.Name = Name_Library_Partial_Linker then
2049 -- Attribute Library_Partial_Linker: the optional linker
2050 -- driver with its minimum options, to partially link
2051 -- archives.
2053 List := Attribute.Value.Values;
2055 if List = Nil_String then
2056 Error_Msg
2057 (Data.Flags,
2058 "partial linker cannot be null",
2059 Attribute.Value.Location, Project);
2060 end if;
2062 Put (Into_List => Project.Config.Lib_Partial_Linker,
2063 From_List => List,
2064 In_Tree => Data.Tree);
2066 elsif Attribute.Name = Name_Library_GCC then
2067 Project.Config.Shared_Lib_Driver :=
2068 File_Name_Type (Attribute.Value.Value);
2069 Error_Msg
2070 (Data.Flags,
2073 Attribute.Value.Location, Project);
2075 elsif Attribute.Name = Name_Archive_Suffix then
2076 Project.Config.Archive_Suffix :=
2077 File_Name_Type (Attribute.Value.Value);
2079 elsif Attribute.Name = Name_Linker_Executable_Option then
2081 -- Attribute Linker_Executable_Option: optional options
2084 List := Attribute.Value.Values;
2086 if List = Nil_String then
2087 Error_Msg
2088 (Data.Flags,
2090 Attribute.Value.Location, Project);
2091 end if;
2093 Put (Into_List => Project.Config.Linker_Executable_Option,
2094 From_List => List,
2095 In_Tree => Data.Tree);
2097 elsif Attribute.Name = Name_Linker_Lib_Dir_Option then
2099 -- Attribute Linker_Lib_Dir_Option: optional options
2100 -- to specify a library search directory. Defaults to
2103 Get_Name_String (Attribute.Value.Value);
2105 if Name_Len = 0 then
2106 Error_Msg
2107 (Data.Flags,
2109 Attribute.Value.Location, Project);
2110 end if;
2112 Project.Config.Linker_Lib_Dir_Option :=
2113 Attribute.Value.Value;
2115 elsif Attribute.Name = Name_Linker_Lib_Name_Option then
2117 -- Attribute Linker_Lib_Name_Option: optional options
2118 -- to specify the name of a library to be linked in.
2121 Get_Name_String (Attribute.Value.Value);
2123 if Name_Len = 0 then
2124 Error_Msg
2125 (Data.Flags,
2127 Attribute.Value.Location, Project);
2128 end if;
2130 Project.Config.Linker_Lib_Name_Option :=
2131 Attribute.Value.Value;
2133 elsif Attribute.Name = Name_Run_Path_Option then
2135 -- Attribute Run_Path_Option: optional options to
2136 -- specify a path for libraries.
2138 List := Attribute.Value.Values;
2140 if List /= Nil_String then
2141 Put (Into_List => Project.Config.Run_Path_Option,
2142 From_List => List,
2143 In_Tree => Data.Tree);
2144 end if;
2146 elsif Attribute.Name = Name_Run_Path_Origin then
2147 Get_Name_String (Attribute.Value.Value);
2149 if Name_Len = 0 then
2150 Error_Msg
2151 (Data.Flags,
2153 Attribute.Value.Location, Project);
2154 end if;
2156 Project.Config.Run_Path_Origin := Attribute.Value.Value;
2158 elsif Attribute.Name = Name_Library_Install_Name_Option then
2159 Project.Config.Library_Install_Name_Option :=
2160 Attribute.Value.Value;
2162 elsif Attribute.Name = Name_Separate_Run_Path_Options then
2163 declare
2164 pragma Unsuppress (All_Checks);
2165 begin
2166 Project.Config.Separate_Run_Path_Options :=
2167 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2168 exception
2169 when Constraint_Error =>
2170 Error_Msg
2171 (Data.Flags,
2173 Get_Name_String (Attribute.Value.Value) &
2175 Attribute.Value.Location, Project);
2176 end;
2178 elsif Attribute.Name = Name_Library_Support then
2179 declare
2180 pragma Unsuppress (All_Checks);
2181 begin
2182 Project.Config.Lib_Support :=
2183 Library_Support'Value (Get_Name_String
2184 (Attribute.Value.Value));
2185 exception
2186 when Constraint_Error =>
2187 Error_Msg
2188 (Data.Flags,
2190 Get_Name_String (Attribute.Value.Value) &
2192 Attribute.Value.Location, Project);
2193 end;
2195 elsif
2196 Attribute.Name = Name_Library_Encapsulated_Supported
2197 then
2198 declare
2199 pragma Unsuppress (All_Checks);
2200 begin
2201 Project.Config.Lib_Encapsulated_Supported :=
2202 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2203 exception
2204 when Constraint_Error =>
2205 Error_Msg
2206 (Data.Flags,
2208 & Get_Name_String (Attribute.Value.Value)
2210 Attribute.Value.Location, Project);
2211 end;
2213 elsif Attribute.Name = Name_Shared_Library_Prefix then
2214 Project.Config.Shared_Lib_Prefix :=
2215 File_Name_Type (Attribute.Value.Value);
2217 elsif Attribute.Name = Name_Shared_Library_Suffix then
2218 Project.Config.Shared_Lib_Suffix :=
2219 File_Name_Type (Attribute.Value.Value);
2221 elsif Attribute.Name = Name_Symbolic_Link_Supported then
2222 declare
2223 pragma Unsuppress (All_Checks);
2224 begin
2225 Project.Config.Symbolic_Link_Supported :=
2226 Boolean'Value (Get_Name_String
2227 (Attribute.Value.Value));
2228 exception
2229 when Constraint_Error =>
2230 Error_Msg
2231 (Data.Flags,
2233 & Get_Name_String (Attribute.Value.Value)
2235 Attribute.Value.Location, Project);
2236 end;
2238 elsif
2239 Attribute.Name = Name_Library_Major_Minor_Id_Supported
2240 then
2241 declare
2242 pragma Unsuppress (All_Checks);
2243 begin
2244 Project.Config.Lib_Maj_Min_Id_Supported :=
2245 Boolean'Value (Get_Name_String
2246 (Attribute.Value.Value));
2247 exception
2248 when Constraint_Error =>
2249 Error_Msg
2250 (Data.Flags,
2252 Get_Name_String (Attribute.Value.Value) &
2254 Attribute.Value.Location, Project);
2255 end;
2257 elsif Attribute.Name = Name_Library_Auto_Init_Supported then
2258 declare
2259 pragma Unsuppress (All_Checks);
2260 begin
2261 Project.Config.Auto_Init_Supported :=
2262 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2263 exception
2264 when Constraint_Error =>
2265 Error_Msg
2266 (Data.Flags,
2268 & Get_Name_String (Attribute.Value.Value)
2270 Attribute.Value.Location, Project);
2271 end;
2273 elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then
2274 List := Attribute.Value.Values;
2276 if List /= Nil_String then
2277 Put (Into_List => Project.Config.Shared_Lib_Min_Options,
2278 From_List => List,
2279 In_Tree => Data.Tree);
2280 end if;
2282 elsif Attribute.Name = Name_Library_Version_Switches then
2283 List := Attribute.Value.Values;
2285 if List /= Nil_String then
2286 Put (Into_List => Project.Config.Lib_Version_Options,
2287 From_List => List,
2288 In_Tree => Data.Tree);
2289 end if;
2290 end if;
2291 end if;
2293 Attribute_Id := Attribute.Next;
2294 end loop;
2295 end Process_Project_Level_Simple_Attributes;
2297 --------------------------------------------
2298 -- Process_Project_Level_Array_Attributes --
2299 --------------------------------------------
2301 procedure Process_Project_Level_Array_Attributes is
2302 Current_Array_Id : Array_Id;
2303 Current_Array : Array_Data;
2304 Element_Id : Array_Element_Id;
2305 Element : Array_Element;
2306 List : String_List_Id;
2308 begin
2309 -- Process the associative array attributes at project level
2311 Current_Array_Id := Project.Decl.Arrays;
2312 while Current_Array_Id /= No_Array loop
2313 Current_Array := Shared.Arrays.Table (Current_Array_Id);
2315 Element_Id := Current_Array.Value;
2316 while Element_Id /= No_Array_Element loop
2317 Element := Shared.Array_Elements.Table (Element_Id);
2319 -- Get the name of the language
2321 Lang_Index :=
2322 Get_Language_From_Name
2323 (Project, Get_Name_String (Element.Index));
2325 if Lang_Index /= No_Language_Index then
2326 case Current_Array.Name is
2327 when Name_Inherit_Source_Path =>
2328 List := Element.Value.Values;
2330 if List /= Nil_String then
2331 Put
2332 (Into_List =>
2333 Lang_Index.Config.Include_Compatible_Languages,
2334 From_List => List,
2335 In_Tree => Data.Tree,
2336 Lower_Case => True);
2337 end if;
2339 when Name_Toolchain_Description =>
2341 -- Attribute Toolchain_Description (<language>)
2343 Lang_Index.Config.Toolchain_Description :=
2344 Element.Value.Value;
2346 when Name_Toolchain_Version =>
2348 -- Attribute Toolchain_Version (<language>)
2350 Lang_Index.Config.Toolchain_Version :=
2351 Element.Value.Value;
2353 -- For Ada, set proper checksum computation mode
2355 if Lang_Index.Name = Name_Ada then
2356 declare
2357 Vers : constant String :=
2358 Get_Name_String (Element.Value.Value);
2359 pragma Assert (Vers'First = 1);
2361 begin
2362 -- Version 6.3 or earlier
2364 if Vers'Length >= 8
2366 and then Vers (7) = '.'
2367 and then
2368 (Vers (6) < '6'
2369 or else
2370 (Vers (6) = '6' and then Vers (8) < '4'))
2371 then
2372 Checksum_GNAT_6_3 := True;
2374 -- Version 5.03 or earlier
2376 if Vers (6) < '5'
2377 or else (Vers (6) = '5'
2378 and then Vers (Vers'Last) < '4')
2379 then
2380 Checksum_GNAT_5_03 := True;
2382 -- Version 5.02 or earlier
2384 if Vers (6) /= '5'
2385 or else Vers (Vers'Last) < '3'
2386 then
2387 Checksum_Accumulate_Token_Checksum :=
2388 False;
2389 end if;
2390 end if;
2391 end if;
2392 end;
2393 end if;
2395 when Name_Runtime_Library_Dir =>
2397 -- Attribute Runtime_Library_Dir (<language>)
2399 Lang_Index.Config.Runtime_Library_Dir :=
2400 Element.Value.Value;
2402 when Name_Runtime_Source_Dir =>
2404 -- Attribute Runtime_Source_Dir (<language>)
2406 Lang_Index.Config.Runtime_Source_Dir :=
2407 Element.Value.Value;
2409 when Name_Object_Generated =>
2410 declare
2411 pragma Unsuppress (All_Checks);
2412 Value : Boolean;
2414 begin
2415 Value :=
2416 Boolean'Value
2417 (Get_Name_String (Element.Value.Value));
2419 Lang_Index.Config.Object_Generated := Value;
2421 -- If no object is generated, no object may be
2422 -- linked.
2424 if not Value then
2425 Lang_Index.Config.Objects_Linked := False;
2426 end if;
2428 exception
2429 when Constraint_Error =>
2430 Error_Msg
2431 (Data.Flags,
2433 & Get_Name_String (Element.Value.Value)
2435 Element.Value.Location, Project);
2436 end;
2438 when Name_Objects_Linked =>
2439 declare
2440 pragma Unsuppress (All_Checks);
2441 Value : Boolean;
2443 begin
2444 Value :=
2445 Boolean'Value
2446 (Get_Name_String (Element.Value.Value));
2448 -- No change if Object_Generated is False, as this
2449 -- forces Objects_Linked to be False too.
2451 if Lang_Index.Config.Object_Generated then
2452 Lang_Index.Config.Objects_Linked := Value;
2453 end if;
2455 exception
2456 when Constraint_Error =>
2457 Error_Msg
2458 (Data.Flags,
2460 & Get_Name_String (Element.Value.Value)
2462 Element.Value.Location, Project);
2463 end;
2464 when others =>
2465 null;
2466 end case;
2467 end if;
2469 Element_Id := Element.Next;
2470 end loop;
2472 Current_Array_Id := Current_Array.Next;
2473 end loop;
2474 end Process_Project_Level_Array_Attributes;
2476 -- Start of processing for Check_Configuration
2478 begin
2479 Process_Project_Level_Simple_Attributes;
2480 Process_Project_Level_Array_Attributes;
2481 Process_Packages;
2483 -- For unit based languages, set Casing, Dot_Replacement and
2484 -- Separate_Suffix in Naming_Data.
2486 Lang_Index := Project.Languages;
2487 while Lang_Index /= No_Language_Index loop
2488 if Lang_Index.Config.Kind = Unit_Based then
2489 Lang_Index.Config.Naming_Data.Casing := Casing;
2490 Lang_Index.Config.Naming_Data.Dot_Replacement := Dot_Replacement;
2492 if Separate_Suffix /= No_File then
2493 Lang_Index.Config.Naming_Data.Separate_Suffix :=
2494 Separate_Suffix;
2495 end if;
2497 exit;
2498 end if;
2500 Lang_Index := Lang_Index.Next;
2501 end loop;
2503 -- Give empty names to various prefixes/suffixes, if they have not
2504 -- been specified in the configuration.
2506 if Project.Config.Archive_Suffix = No_File then
2507 Project.Config.Archive_Suffix := Empty_File;
2508 end if;
2510 if Project.Config.Shared_Lib_Prefix = No_File then
2511 Project.Config.Shared_Lib_Prefix := Empty_File;
2512 end if;
2514 if Project.Config.Shared_Lib_Suffix = No_File then
2515 Project.Config.Shared_Lib_Suffix := Empty_File;
2516 end if;
2518 Lang_Index := Project.Languages;
2519 while Lang_Index /= No_Language_Index loop
2521 -- For all languages, Compiler_Driver needs to be specified. This is
2522 -- only needed if we do intend to compile (not in GPS for instance).
2524 if Data.Flags.Compiler_Driver_Mandatory
2525 and then Lang_Index.Config.Compiler_Driver = No_File
2526 then
2527 Error_Msg_Name_1 := Lang_Index.Display_Name;
2528 Error_Msg
2529 (Data.Flags,
2532 No_Location, Project);
2534 if Lang_Index = Project.Languages then
2535 Project.Languages := Lang_Index.Next;
2536 else
2537 Prev_Index.Next := Lang_Index.Next;
2538 end if;
2540 elsif Lang_Index.Config.Kind = Unit_Based then
2541 Prev_Index := Lang_Index;
2543 -- For unit based languages, Dot_Replacement, Spec_Suffix and
2544 -- Body_Suffix need to be specified.
2546 if Lang_Index.Config.Naming_Data.Dot_Replacement = No_File then
2547 Error_Msg
2548 (Data.Flags,
2550 Get_Name_String (Lang_Index.Name),
2551 No_Location, Project);
2552 end if;
2554 if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then
2555 Error_Msg
2556 (Data.Flags,
2558 Get_Name_String (Lang_Index.Name),
2559 No_Location, Project);
2560 end if;
2562 if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then
2563 Error_Msg
2564 (Data.Flags,
2566 Get_Name_String (Lang_Index.Name),
2567 No_Location, Project);
2568 end if;
2570 else
2571 Prev_Index := Lang_Index;
2573 -- For file based languages, either Spec_Suffix or Body_Suffix
2574 -- need to be specified.
2576 if Data.Flags.Require_Sources_Other_Lang
2577 and then Lang_Index.Config.Naming_Data.Spec_Suffix = No_File
2578 and then Lang_Index.Config.Naming_Data.Body_Suffix = No_File
2579 then
2580 Error_Msg_Name_1 := Lang_Index.Display_Name;
2581 Error_Msg
2582 (Data.Flags,
2584 No_Location, Project);
2585 end if;
2586 end if;
2588 Lang_Index := Lang_Index.Next;
2589 end loop;
2590 end Check_Configuration;
2592 -------------------------------
2593 -- Check_If_Externally_Built --
2594 -------------------------------
2596 procedure Check_If_Externally_Built
2597 (Project : Project_Id;
2598 Data : in out Tree_Processing_Data)
2599 is
2600 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
2601 Externally_Built : constant Variable_Value :=
2602 Util.Value_Of
2603 (Name_Externally_Built,
2604 Project.Decl.Attributes, Shared);
2606 begin
2607 if not Externally_Built.Default then
2608 Get_Name_String (Externally_Built.Value);
2609 To_Lower (Name_Buffer (1 .. Name_Len));
2612 Project.Externally_Built := True;
2615 Error_Msg (Data.Flags,
2617 Externally_Built.Location, Project);
2618 end if;
2619 end if;
2621 -- A virtual project extending an externally built project is itself
2622 -- externally built.
2624 if Project.Virtual and then Project.Extends /= No_Project then
2625 Project.Externally_Built := Project.Extends.Externally_Built;
2626 end if;
2628 if Project.Externally_Built then
2630 else
2632 end if;
2633 end Check_If_Externally_Built;
2635 ----------------------
2636 -- Check_Interfaces --
2637 ----------------------
2639 procedure Check_Interfaces
2640 (Project : Project_Id;
2641 Data : in out Tree_Processing_Data)
2642 is
2643 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
2645 Interfaces : constant Prj.Variable_Value :=
2646 Prj.Util.Value_Of
2647 (Snames.Name_Interfaces,
2648 Project.Decl.Attributes,
2649 Shared);
2651 Library_Interface : constant Prj.Variable_Value :=
2652 Prj.Util.Value_Of
2653 (Snames.Name_Library_Interface,
2654 Project.Decl.Attributes,
2655 Shared);
2657 List : String_List_Id;
2658 Element : String_Element;
2659 Name : File_Name_Type;
2660 Iter : Source_Iterator;
2661 Source : Source_Id;
2662 Project_2 : Project_Id;
2663 Other : Source_Id;
2664 Unit_Found : Boolean;
2666 Interface_ALIs : String_List_Id := Nil_String;
2668 begin
2669 if not Interfaces.Default then
2671 -- Set In_Interfaces to False for all sources. It will be set to True
2672 -- later for the sources in the Interfaces list.
2674 Project_2 := Project;
2675 while Project_2 /= No_Project loop
2676 Iter := For_Each_Source (Data.Tree, Project_2);
2677 loop
2678 Source := Prj.Element (Iter);
2679 exit when Source = No_Source;
2680 Source.In_Interfaces := False;
2681 Next (Iter);
2682 end loop;
2684 Project_2 := Project_2.Extends;
2685 end loop;
2687 List := Interfaces.Values;
2688 while List /= Nil_String loop
2689 Element := Shared.String_Elements.Table (List);
2690 Name := Canonical_Case_File_Name (Element.Value);
2692 Project_2 := Project;
2693 Big_Loop : while Project_2 /= No_Project loop
2694 if Project.Qualifier = Aggregate_Library then
2696 -- For an aggregate library we want to consider sources of
2697 -- all aggregated projects.
2699 Iter := For_Each_Source (Data.Tree);
2701 else
2702 Iter := For_Each_Source (Data.Tree, Project_2);
2703 end if;
2705 loop
2706 Source := Prj.Element (Iter);
2707 exit when Source = No_Source;
2709 if Source.File = Name then
2710 if not Source.Locally_Removed then
2711 Source.In_Interfaces := True;
2712 Source.Declared_In_Interfaces := True;
2714 Other := Other_Part (Source);
2716 if Other /= No_Source then
2717 Other.In_Interfaces := True;
2718 Other.Declared_In_Interfaces := True;
2719 end if;
2721 if Source.Language.Config.Kind = Unit_Based then
2722 if Source.Kind = Spec
2723 and then Other_Part (Source) /= No_Source
2724 then
2725 Source := Other_Part (Source);
2726 end if;
2728 String_Element_Table.Increment_Last
2729 (Shared.String_Elements);
2731 Shared.String_Elements.Table
2732 (String_Element_Table.Last
2733 (Shared.String_Elements)) :=
2734 (Value => Name_Id (Source.Dep_Name),
2735 Index => 0,
2736 Display_Value => Name_Id (Source.Dep_Name),
2737 Location => No_Location,
2738 Flag => False,
2739 Next => Interface_ALIs);
2741 Interface_ALIs :=
2742 String_Element_Table.Last
2743 (Shared.String_Elements);
2744 end if;
2746 Debug_Output
2748 end if;
2750 exit Big_Loop;
2751 end if;
2753 Next (Iter);
2754 end loop;
2756 Project_2 := Project_2.Extends;
2757 end loop Big_Loop;
2759 if Source = No_Source then
2760 Error_Msg_File_1 := File_Name_Type (Element.Value);
2761 Error_Msg_Name_1 := Project.Name;
2763 Error_Msg
2764 (Data.Flags,
2767 Element.Location, Project);
2768 end if;
2770 List := Element.Next;
2771 end loop;
2773 Project.Interfaces_Defined := True;
2774 Project.Lib_Interface_ALIs := Interface_ALIs;
2776 elsif Project.Library and then not Library_Interface.Default then
2778 -- Set In_Interfaces to False for all sources. It will be set to True
2779 -- later for the sources in the Library_Interface list.
2781 Project_2 := Project;
2782 while Project_2 /= No_Project loop
2783 Iter := For_Each_Source (Data.Tree, Project_2);
2784 loop
2785 Source := Prj.Element (Iter);
2786 exit when Source = No_Source;
2787 Source.In_Interfaces := False;
2788 Next (Iter);
2789 end loop;
2791 Project_2 := Project_2.Extends;
2792 end loop;
2794 List := Library_Interface.Values;
2795 while List /= Nil_String loop
2796 Element := Shared.String_Elements.Table (List);
2797 Get_Name_String (Element.Value);
2798 To_Lower (Name_Buffer (1 .. Name_Len));
2799 Name := Name_Find;
2800 Unit_Found := False;
2802 Project_2 := Project;
2803 Big_Loop_2 : while Project_2 /= No_Project loop
2804 if Project.Qualifier = Aggregate_Library then
2806 -- For an aggregate library we want to consider sources of
2807 -- all aggregated projects.
2809 Iter := For_Each_Source (Data.Tree);
2811 else
2812 Iter := For_Each_Source (Data.Tree, Project_2);
2813 end if;
2815 loop
2816 Source := Prj.Element (Iter);
2817 exit when Source = No_Source;
2819 if Source.Unit /= No_Unit_Index
2820 and then Source.Unit.Name = Name_Id (Name)
2821 then
2822 if not Source.Locally_Removed then
2823 Source.In_Interfaces := True;
2824 Source.Declared_In_Interfaces := True;
2825 Project.Interfaces_Defined := True;
2827 Other := Other_Part (Source);
2829 if Other /= No_Source then
2830 Other.In_Interfaces := True;
2831 Other.Declared_In_Interfaces := True;
2832 end if;
2834 Debug_Output
2837 if Source.Kind = Spec
2838 and then Other_Part (Source) /= No_Source
2839 then
2840 Source := Other_Part (Source);
2841 end if;
2843 String_Element_Table.Increment_Last
2844 (Shared.String_Elements);
2846 Shared.String_Elements.Table
2847 (String_Element_Table.Last
2848 (Shared.String_Elements)) :=
2849 (Value => Name_Id (Source.Dep_Name),
2850 Index => 0,
2851 Display_Value => Name_Id (Source.Dep_Name),
2852 Location => No_Location,
2853 Flag => False,
2854 Next => Interface_ALIs);
2856 Interface_ALIs :=
2857 String_Element_Table.Last (Shared.String_Elements);
2858 end if;
2860 Unit_Found := True;
2861 exit Big_Loop_2;
2862 end if;
2864 Next (Iter);
2865 end loop;
2867 Project_2 := Project_2.Extends;
2868 end loop Big_Loop_2;
2870 if not Unit_Found then
2871 Error_Msg_Name_1 := Name_Id (Name);
2873 Error_Msg
2874 (Data.Flags,
2876 Element.Location, Project);
2877 end if;
2879 List := Element.Next;
2880 end loop;
2882 Project.Lib_Interface_ALIs := Interface_ALIs;
2884 elsif Project.Extends /= No_Project
2885 and then Project.Extends.Interfaces_Defined
2886 then
2887 Project.Interfaces_Defined := True;
2889 Iter := For_Each_Source (Data.Tree, Project);
2890 loop
2891 Source := Prj.Element (Iter);
2892 exit when Source = No_Source;
2894 if not Source.Declared_In_Interfaces then
2895 Source.In_Interfaces := False;
2896 end if;
2898 Next (Iter);
2899 end loop;
2901 Project.Lib_Interface_ALIs := Project.Extends.Lib_Interface_ALIs;
2902 end if;
2903 end Check_Interfaces;
2905 ------------------------------
2906 -- Check_Library_Attributes --
2907 ------------------------------
2909 -- This procedure is awfully long (over 700 lines) should be broken up???
2911 procedure Check_Library_Attributes
2912 (Project : Project_Id;
2913 Data : in out Tree_Processing_Data)
2914 is
2915 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
2917 Attributes : constant Prj.Variable_Id := Project.Decl.Attributes;
2919 Lib_Dir : constant Prj.Variable_Value :=
2920 Prj.Util.Value_Of
2921 (Snames.Name_Library_Dir, Attributes, Shared);
2923 Lib_Name : constant Prj.Variable_Value :=
2924 Prj.Util.Value_Of
2925 (Snames.Name_Library_Name, Attributes, Shared);
2927 Lib_Standalone : constant Prj.Variable_Value :=
2928 Prj.Util.Value_Of
2929 (Snames.Name_Library_Standalone,
2930 Attributes, Shared);
2932 Lib_Version : constant Prj.Variable_Value :=
2933 Prj.Util.Value_Of
2934 (Snames.Name_Library_Version, Attributes, Shared);
2936 Lib_ALI_Dir : constant Prj.Variable_Value :=
2937 Prj.Util.Value_Of
2938 (Snames.Name_Library_Ali_Dir, Attributes, Shared);
2940 Lib_GCC : constant Prj.Variable_Value :=
2941 Prj.Util.Value_Of
2942 (Snames.Name_Library_GCC, Attributes, Shared);
2944 The_Lib_Kind : constant Prj.Variable_Value :=
2945 Prj.Util.Value_Of
2946 (Snames.Name_Library_Kind, Attributes, Shared);
2948 Imported_Project_List : Project_List;
2949 Continuation : String_Access := No_Continuation_String'Access;
2950 Support_For_Libraries : Library_Support;
2952 Library_Directory_Present : Boolean;
2954 procedure Check_Library (Proj : Project_Id; Extends : Boolean);
2955 -- Check if an imported or extended project if also a library project
2957 -------------------
2958 -- Check_Library --
2959 -------------------
2961 procedure Check_Library (Proj : Project_Id; Extends : Boolean) is
2962 Src_Id : Source_Id;
2963 Iter : Source_Iterator;
2965 begin
2966 if Proj /= No_Project then
2967 if not Proj.Library then
2969 -- The only not library projects that are OK are those that
2970 -- have no sources. However, header files from non-Ada
2971 -- languages are OK, as there is nothing to compile.
2973 Iter := For_Each_Source (Data.Tree, Proj);
2974 loop
2975 Src_Id := Prj.Element (Iter);
2976 exit when Src_Id = No_Source
2977 or else Src_Id.Language.Config.Kind /= File_Based
2978 or else Src_Id.Kind /= Spec;
2979 Next (Iter);
2980 end loop;
2982 if Src_Id /= No_Source then
2983 Error_Msg_Name_1 := Project.Name;
2984 Error_Msg_Name_2 := Proj.Name;
2986 if Extends then
2987 if Project.Library_Kind /= Static then
2988 Error_Msg
2989 (Data.Flags,
2990 Continuation.all &
2993 Project.Location, Project);
2994 Continuation := Continuation_String'Access;
2995 end if;
2997 elsif not Unchecked_Shared_Lib_Imports
2998 and then Project.Library_Kind /= Static
2999 then
3000 Error_Msg
3001 (Data.Flags,
3002 Continuation.all &
3005 Project.Location, Project);
3006 Continuation := Continuation_String'Access;
3007 end if;
3008 end if;
3010 elsif Project.Library_Kind /= Static
3011 and then not Lib_Standalone.Default
3013 and then Proj.Library_Kind /= Static
3014 then
3015 -- An encapsulated library must depend only on static libraries
3017 Error_Msg_Name_1 := Project.Name;
3018 Error_Msg_Name_2 := Proj.Name;
3020 Error_Msg
3021 (Data.Flags,
3022 Continuation.all &
3025 Project.Location, Project);
3026 Continuation := Continuation_String'Access;
3028 elsif Project.Library_Kind /= Static
3029 and then Proj.Library_Kind = Static
3030 and then
3031 (Lib_Standalone.Default
3032 or else
3034 then
3035 Error_Msg_Name_1 := Project.Name;
3036 Error_Msg_Name_2 := Proj.Name;
3038 if Extends then
3039 Error_Msg
3040 (Data.Flags,
3041 Continuation.all &
3044 Project.Location, Project);
3045 Continuation := Continuation_String'Access;
3047 elsif not Unchecked_Shared_Lib_Imports then
3048 Error_Msg
3049 (Data.Flags,
3050 Continuation.all &
3053 Project.Location, Project);
3054 Continuation := Continuation_String'Access;
3055 end if;
3057 end if;
3058 end if;
3059 end Check_Library;
3061 Dir_Exists : Boolean;
3063 -- Start of processing for Check_Library_Attributes
3065 begin
3066 Library_Directory_Present := Lib_Dir.Value /= Empty_String;
3068 -- Special case of extending project
3070 if Project.Extends /= No_Project then
3072 -- If the project extended is a library project, we inherit the
3073 -- library name, if it is not redefined; we check that the library
3074 -- directory is specified.
3076 if Project.Extends.Library then
3077 if Project.Qualifier = Standard then
3078 Error_Msg
3079 (Data.Flags,
3081 Project.Location, Project);
3083 else
3084 if Lib_Name.Default then
3085 Project.Library_Name := Project.Extends.Library_Name;
3086 end if;
3088 if Lib_Dir.Default then
3089 if not Project.Virtual then
3090 Error_Msg
3091 (Data.Flags,
3094 Project.Location, Project);
3096 else
3097 -- For a virtual project extending a library project,
3098 -- inherit library directory and library kind.
3100 Project.Library_Dir := Project.Extends.Library_Dir;
3101 Library_Directory_Present := True;
3102 Project.Library_Kind := Project.Extends.Library_Kind;
3103 end if;
3104 end if;
3105 end if;
3106 end if;
3107 end if;
3109 pragma Assert (Lib_Name.Kind = Single);
3111 if Lib_Name.Value = Empty_String then
3112 if Current_Verbosity = High
3113 and then Project.Library_Name = No_Name
3114 then
3115 Debug_Indent;
3117 end if;
3119 else
3120 -- There is no restriction on the syntax of library names
3122 Project.Library_Name := Lib_Name.Value;
3123 end if;
3125 if Project.Library_Name /= No_Name then
3126 if Current_Verbosity = High then
3127 Write_Attr
3129 end if;
3131 pragma Assert (Lib_Dir.Kind = Single);
3133 if not Library_Directory_Present then
3136 else
3137 -- Find path name (unless inherited), check that it is a directory
3139 if Project.Library_Dir = No_Path_Information then
3140 Locate_Directory
3141 (Project,
3142 File_Name_Type (Lib_Dir.Value),
3143 Path => Project.Library_Dir,
3144 Dir_Exists => Dir_Exists,
3145 Data => Data,
3147 Must_Exist => False,
3148 Location => Lib_Dir.Location,
3149 Externally_Built => Project.Externally_Built);
3151 else
3152 Dir_Exists :=
3153 Is_Directory
3154 (Get_Name_String (Project.Library_Dir.Display_Name));
3155 end if;
3157 if not Dir_Exists then
3158 if Directories_Must_Exist_In_Projects then
3160 -- Get the absolute name of the library directory that does
3161 -- not exist, to report an error.
3163 Err_Vars.Error_Msg_File_1 :=
3164 File_Name_Type (Project.Library_Dir.Display_Name);
3165 Error_Msg
3166 (Data.Flags,
3168 Lib_Dir.Location, Project);
3170 else
3171 Project.Library_Dir := No_Path_Information;
3172 end if;
3174 -- Checks for object/source directories
3176 elsif not Project.Externally_Built
3178 -- An aggregate library does not have sources or objects, so
3179 -- these tests are not required in this case.
3181 and then Project.Qualifier /= Aggregate_Library
3182 then
3183 -- Library directory cannot be the same as Object directory
3185 if Project.Library_Dir.Name = Project.Object_Directory.Name then
3186 Error_Msg
3187 (Data.Flags,
3190 Lib_Dir.Location, Project);
3191 Project.Library_Dir := No_Path_Information;
3193 else
3194 declare
3195 OK : Boolean := True;
3196 Dirs_Id : String_List_Id;
3197 Dir_Elem : String_Element;
3198 Pid : Project_List;
3200 begin
3201 -- The library directory cannot be the same as a source
3202 -- directory of the current project.
3204 Dirs_Id := Project.Source_Dirs;
3205 while Dirs_Id /= Nil_String loop
3206 Dir_Elem := Shared.String_Elements.Table (Dirs_Id);
3207 Dirs_Id := Dir_Elem.Next;
3209 if Project.Library_Dir.Name =
3210 Path_Name_Type (Dir_Elem.Value)
3211 then
3212 Err_Vars.Error_Msg_File_1 :=
3213 File_Name_Type (Dir_Elem.Value);
3214 Error_Msg
3215 (Data.Flags,
3218 Lib_Dir.Location, Project);
3219 OK := False;
3220 exit;
3221 end if;
3222 end loop;
3224 if OK then
3226 -- The library directory cannot be the same as a
3227 -- source directory of another project either.
3229 Pid := Data.Tree.Projects;
3230 Project_Loop : loop
3231 exit Project_Loop when Pid = null;
3233 if Pid.Project /= Project then
3234 Dirs_Id := Pid.Project.Source_Dirs;
3236 Dir_Loop : while Dirs_Id /= Nil_String loop
3237 Dir_Elem :=
3238 Shared.String_Elements.Table (Dirs_Id);
3239 Dirs_Id := Dir_Elem.Next;
3241 if Project.Library_Dir.Name =
3242 Path_Name_Type (Dir_Elem.Value)
3243 then
3244 Err_Vars.Error_Msg_File_1 :=
3245 File_Name_Type (Dir_Elem.Value);
3246 Err_Vars.Error_Msg_Name_1 :=
3247 Pid.Project.Name;
3249 Error_Msg
3250 (Data.Flags,
3253 Lib_Dir.Location, Project);
3254 OK := False;
3255 exit Project_Loop;
3256 end if;
3257 end loop Dir_Loop;
3258 end if;
3260 Pid := Pid.Next;
3261 end loop Project_Loop;
3262 end if;
3264 if not OK then
3265 Project.Library_Dir := No_Path_Information;
3267 elsif Current_Verbosity = High then
3269 -- Display the Library directory in high verbosity
3271 Write_Attr
3273 Get_Name_String (Project.Library_Dir.Display_Name));
3274 end if;
3275 end;
3276 end if;
3277 end if;
3278 end if;
3280 end if;
3282 Project.Library :=
3283 Project.Library_Dir /= No_Path_Information
3284 and then Project.Library_Name /= No_Name;
3286 if Project.Extends = No_Project then
3287 case Project.Qualifier is
3288 when Standard =>
3289 if Project.Library then
3290 Error_Msg
3291 (Data.Flags,
3293 Lib_Name.Location, Project);
3294 end if;
3296 when Library | Aggregate_Library =>
3297 if not Project.Library then
3298 if Project.Library_Name = No_Name then
3299 Error_Msg
3300 (Data.Flags,
3302 Project.Location, Project);
3304 if not Library_Directory_Present then
3305 Error_Msg
3306 (Data.Flags,
3308 Project.Location, Project);
3309 end if;
3311 elsif Project.Library_Dir = No_Path_Information then
3312 Error_Msg
3313 (Data.Flags,
3315 Project.Location, Project);
3316 end if;
3317 end if;
3319 when others =>
3320 null;
3321 end case;
3322 end if;
3324 if Project.Library then
3325 Support_For_Libraries := Project.Config.Lib_Support;
3327 if not Project.Externally_Built
3328 and then Support_For_Libraries = Prj.None
3329 then
3330 Error_Msg
3331 (Data.Flags,
3333 Lib_Name.Location, Project);
3334 Project.Library := False;
3336 else
3337 if Lib_ALI_Dir.Value = Empty_String then
3339 Project.Library_ALI_Dir := Project.Library_Dir;
3341 else
3342 -- Find path name, check that it is a directory
3344 Locate_Directory
3345 (Project,
3346 File_Name_Type (Lib_ALI_Dir.Value),
3347 Path => Project.Library_ALI_Dir,
3349 Dir_Exists => Dir_Exists,
3350 Data => Data,
3351 Must_Exist => False,
3352 Location => Lib_ALI_Dir.Location,
3353 Externally_Built => Project.Externally_Built);
3355 if not Dir_Exists then
3357 -- Get the absolute name of the library ALI directory that
3358 -- does not exist, to report an error.
3360 Err_Vars.Error_Msg_File_1 :=
3361 File_Name_Type (Project.Library_ALI_Dir.Display_Name);
3362 Error_Msg
3363 (Data.Flags,
3365 Lib_ALI_Dir.Location, Project);
3366 end if;
3368 if not Project.Externally_Built
3369 and then Project.Library_ALI_Dir /= Project.Library_Dir
3370 then
3371 -- The library ALI directory cannot be the same as the
3372 -- Object directory.
3374 if Project.Library_ALI_Dir = Project.Object_Directory then
3375 Error_Msg
3376 (Data.Flags,
3379 Lib_ALI_Dir.Location, Project);
3380 Project.Library_ALI_Dir := No_Path_Information;
3382 else
3383 declare
3384 OK : Boolean := True;
3385 Dirs_Id : String_List_Id;
3386 Dir_Elem : String_Element;
3387 Pid : Project_List;
3389 begin
3390 -- The library ALI directory cannot be the same as
3391 -- a source directory of the current project.
3393 Dirs_Id := Project.Source_Dirs;
3394 while Dirs_Id /= Nil_String loop
3395 Dir_Elem := Shared.String_Elements.Table (Dirs_Id);
3396 Dirs_Id := Dir_Elem.Next;
3398 if Project.Library_ALI_Dir.Name =
3399 Path_Name_Type (Dir_Elem.Value)
3400 then
3401 Err_Vars.Error_Msg_File_1 :=
3402 File_Name_Type (Dir_Elem.Value);
3403 Error_Msg
3404 (Data.Flags,
3407 Lib_ALI_Dir.Location, Project);
3408 OK := False;
3409 exit;
3410 end if;
3411 end loop;
3413 if OK then
3415 -- The library ALI directory cannot be the same as
3416 -- a source directory of another project either.
3418 Pid := Data.Tree.Projects;
3419 ALI_Project_Loop : loop
3420 exit ALI_Project_Loop when Pid = null;
3422 if Pid.Project /= Project then
3423 Dirs_Id := Pid.Project.Source_Dirs;
3425 ALI_Dir_Loop :
3426 while Dirs_Id /= Nil_String loop
3427 Dir_Elem :=
3428 Shared.String_Elements.Table (Dirs_Id);
3429 Dirs_Id := Dir_Elem.Next;
3431 if Project.Library_ALI_Dir.Name =
3432 Path_Name_Type (Dir_Elem.Value)
3433 then
3434 Err_Vars.Error_Msg_File_1 :=
3435 File_Name_Type (Dir_Elem.Value);
3436 Err_Vars.Error_Msg_Name_1 :=
3437 Pid.Project.Name;
3439 Error_Msg
3440 (Data.Flags,
3444 Lib_ALI_Dir.Location, Project);
3445 OK := False;
3446 exit ALI_Project_Loop;
3447 end if;
3448 end loop ALI_Dir_Loop;
3449 end if;
3450 Pid := Pid.Next;
3451 end loop ALI_Project_Loop;
3452 end if;
3454 if not OK then
3455 Project.Library_ALI_Dir := No_Path_Information;
3457 elsif Current_Verbosity = High then
3459 -- Display Library ALI directory in high verbosity
3461 Write_Attr
3463 Get_Name_String
3464 (Project.Library_ALI_Dir.Display_Name));
3465 end if;
3466 end;
3467 end if;
3468 end if;
3469 end if;
3471 pragma Assert (Lib_Version.Kind = Single);
3473 if Lib_Version.Value = Empty_String then
3476 else
3477 Project.Lib_Internal_Name := Lib_Version.Value;
3478 end if;
3480 pragma Assert (The_Lib_Kind.Kind = Single);
3482 if The_Lib_Kind.Value = Empty_String then
3485 else
3486 Get_Name_String (The_Lib_Kind.Value);
3488 declare
3489 Kind_Name : constant String :=
3490 To_Lower (Name_Buffer (1 .. Name_Len));
3492 OK : Boolean := True;
3494 begin
3496 Project.Library_Kind := Static;
3499 Project.Library_Kind := Dynamic;
3502 Project.Library_Kind := Relocatable;
3504 else
3505 Error_Msg
3506 (Data.Flags,
3508 The_Lib_Kind.Location, Project);
3509 OK := False;
3510 end if;
3512 if Current_Verbosity = High and then OK then
3514 end if;
3516 if Project.Library_Kind /= Static then
3517 if not Project.Externally_Built
3518 and then Support_For_Libraries = Prj.Static_Only
3519 then
3520 Error_Msg
3521 (Data.Flags,
3524 The_Lib_Kind.Location, Project);
3525 Project.Library := False;
3527 else
3528 -- Check if (obsolescent) attribute Library_GCC or
3529 -- Linker'Driver is declared.
3531 if Lib_GCC.Value /= Empty_String then
3532 Error_Msg
3533 (Data.Flags,
3536 Lib_GCC.Location, Project);
3537 Project.Config.Shared_Lib_Driver :=
3538 File_Name_Type (Lib_GCC.Value);
3540 else
3541 declare
3542 Linker : constant Package_Id :=
3543 Value_Of
3544 (Name_Linker,
3545 Project.Decl.Packages,
3546 Shared);
3547 Driver : constant Variable_Value :=
3548 Value_Of
3549 (Name => No_Name,
3550 Attribute_Or_Array_Name =>
3551 Name_Driver,
3552 In_Package => Linker,
3553 Shared => Shared);
3555 begin
3556 if Driver /= Nil_Variable_Value
3557 and then Driver.Value /= Empty_String
3558 then
3559 Project.Config.Shared_Lib_Driver :=
3560 File_Name_Type (Driver.Value);
3561 end if;
3562 end;
3563 end if;
3564 end if;
3565 end if;
3566 end;
3567 end if;
3569 if Project.Library
3570 and then Project.Qualifier /= Aggregate_Library
3571 then
3572 Debug_Output ("this is a library project file");
3574 Check_Library (Project.Extends, Extends => True);
3576 Imported_Project_List := Project.Imported_Projects;
3577 while Imported_Project_List /= null loop
3578 Check_Library
3579 (Imported_Project_List.Project,
3580 Extends => False);
3581 Imported_Project_List := Imported_Project_List.Next;
3582 end loop;
3583 end if;
3584 end if;
3585 end if;
3587 -- Check if Linker'Switches or Linker'Default_Switches are declared.
3588 -- Warn if they are declared, as it is a common error to think that
3589 -- library are "linked" with Linker switches.
3591 if Project.Library then
3592 declare
3593 Linker_Package_Id : constant Package_Id :=
3594 Util.Value_Of
3595 (Name_Linker,
3596 Project.Decl.Packages, Shared);
3597 Linker_Package : Package_Element;
3598 Switches : Array_Element_Id := No_Array_Element;
3600 begin
3601 if Linker_Package_Id /= No_Package then
3602 Linker_Package := Shared.Packages.Table (Linker_Package_Id);
3604 Switches :=
3605 Value_Of
3606 (Name => Name_Switches,
3607 In_Arrays => Linker_Package.Decl.Arrays,
3608 Shared => Shared);
3610 if Switches = No_Array_Element then
3611 Switches :=
3612 Value_Of
3613 (Name => Name_Default_Switches,
3614 In_Arrays => Linker_Package.Decl.Arrays,
3615 Shared => Shared);
3616 end if;
3618 if Switches /= No_Array_Element then
3619 Error_Msg
3620 (Data.Flags,
3621 "?Linker switches not taken into account in library " &
3622 "projects",
3623 No_Location, Project);
3624 end if;
3625 end if;
3626 end;
3627 end if;
3629 if Project.Extends /= No_Project and then Project.Extends.Library then
3631 -- Remove the library name from Lib_Data_Table
3633 for J in 1 .. Lib_Data_Table.Last loop
3634 if Lib_Data_Table.Table (J).Proj = Project.Extends then
3635 Lib_Data_Table.Table (J) :=
3636 Lib_Data_Table.Table (Lib_Data_Table.Last);
3637 Lib_Data_Table.Set_Last (Lib_Data_Table.Last - 1);
3638 exit;
3639 end if;
3640 end loop;
3641 end if;
3643 if Project.Library and then not Lib_Name.Default then
3645 -- Check if the same library name is used in an other library project
3647 for J in 1 .. Lib_Data_Table.Last loop
3648 if Lib_Data_Table.Table (J).Name = Project.Library_Name
3649 and then Lib_Data_Table.Table (J).Tree = Data.Tree
3650 then
3651 Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name;
3652 Error_Msg
3653 (Data.Flags,
3654 "Library name cannot be the same as in project %%",
3655 Lib_Name.Location, Project);
3656 Project.Library := False;
3657 exit;
3658 end if;
3659 end loop;
3660 end if;
3662 if not Lib_Standalone.Default
3663 and then Project.Library_Kind = Static
3664 then
3665 -- An standalone library must be a shared library
3667 Error_Msg_Name_1 := Project.Name;
3669 Error_Msg
3670 (Data.Flags,
3671 Continuation.all &
3672 "standalone library project %% must be a shared library",
3673 Project.Location, Project);
3674 Continuation := Continuation_String'Access;
3675 end if;
3677 if Project.Library and not Data.In_Aggregate_Lib then
3679 -- Record the library name
3681 Lib_Data_Table.Append
3682 ((Name => Project.Library_Name,
3683 Proj => Project,
3684 Tree => Data.Tree));
3685 end if;
3686 end Check_Library_Attributes;
3688 --------------------------
3689 -- Check_Package_Naming --
3690 --------------------------
3692 procedure Check_Package_Naming
3693 (Project : Project_Id;
3694 Data : in out Tree_Processing_Data)
3695 is
3696 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
3697 Naming_Id : constant Package_Id :=
3698 Util.Value_Of
3699 (Name_Naming, Project.Decl.Packages, Shared);
3700 Naming : Package_Element;
3702 Ada_Body_Suffix_Loc : Source_Ptr := No_Location;
3704 procedure Check_Naming;
3705 -- Check the validity of the Naming package (suffixes valid, ...)
3707 procedure Check_Common
3708 (Dot_Replacement : in out File_Name_Type;
3709 Casing : in out Casing_Type;
3710 Casing_Defined : out Boolean;
3711 Separate_Suffix : in out File_Name_Type;
3712 Sep_Suffix_Loc : out Source_Ptr);
3713 -- Check attributes common
3715 procedure Process_Exceptions_File_Based
3716 (Lang_Id : Language_Ptr;
3717 Kind : Source_Kind);
3718 procedure Process_Exceptions_Unit_Based
3719 (Lang_Id : Language_Ptr;
3720 Kind : Source_Kind);
3721 -- Process the naming exceptions for the two types of languages
3723 procedure Initialize_Naming_Data;
3724 -- Initialize internal naming data for the various languages
3726 ------------------
3727 -- Check_Common --
3728 ------------------
3730 procedure Check_Common
3731 (Dot_Replacement : in out File_Name_Type;
3732 Casing : in out Casing_Type;
3733 Casing_Defined : out Boolean;
3734 Separate_Suffix : in out File_Name_Type;
3735 Sep_Suffix_Loc : out Source_Ptr)
3736 is
3737 Dot_Repl : constant Variable_Value :=
3738 Util.Value_Of
3739 (Name_Dot_Replacement,
3740 Naming.Decl.Attributes,
3741 Shared);
3742 Casing_String : constant Variable_Value :=
3743 Util.Value_Of
3744 (Name_Casing,
3745 Naming.Decl.Attributes,
3746 Shared);
3747 Sep_Suffix : constant Variable_Value :=
3748 Util.Value_Of
3749 (Name_Separate_Suffix,
3750 Naming.Decl.Attributes,
3751 Shared);
3752 Dot_Repl_Loc : Source_Ptr;
3754 begin
3755 Sep_Suffix_Loc := No_Location;
3757 if not Dot_Repl.Default then
3758 pragma Assert
3759 (Dot_Repl.Kind = Single, "Dot_Replacement is not a string");
3761 if Length_Of_Name (Dot_Repl.Value) = 0 then
3762 Error_Msg
3763 (Data.Flags, "Dot_Replacement cannot be empty",
3764 Dot_Repl.Location, Project);
3765 end if;
3767 Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value);
3768 Dot_Repl_Loc := Dot_Repl.Location;
3770 declare
3771 Repl : constant String := Get_Name_String (Dot_Replacement);
3773 begin
3774 -- Dot_Replacement cannot
3775 -- - be empty
3776 -- - start or end with an alphanumeric
3781 if Repl'Length = 0
3782 or else Is_Alphanumeric (Repl (Repl'First))
3783 or else Is_Alphanumeric (Repl (Repl'Last))
3785 and then
3786 (Repl'Length = 1
3787 or else
3788 Is_Alphanumeric (Repl (Repl'First + 1))))
3789 or else (Repl'Length > 1
3790 and then
3791 Index (Source => Repl, Pattern => ".") /= 0)
3792 then
3793 Error_Msg
3794 (Data.Flags,
3797 Dot_Repl_Loc, Project);
3798 end if;
3799 end;
3800 end if;
3802 if Dot_Replacement /= No_File then
3803 Write_Attr
3805 end if;
3807 Casing_Defined := False;
3809 if not Casing_String.Default then
3810 pragma Assert
3813 declare
3814 Casing_Image : constant String :=
3815 Get_Name_String (Casing_String.Value);
3817 begin
3818 if Casing_Image'Length = 0 then
3819 Error_Msg
3820 (Data.Flags,
3822 Casing_String.Location, Project);
3823 end if;
3825 Casing := Value (Casing_Image);
3826 Casing_Defined := True;
3828 exception
3829 when Constraint_Error =>
3830 Name_Len := Casing_Image'Length;
3831 Name_Buffer (1 .. Name_Len) := Casing_Image;
3832 Err_Vars.Error_Msg_Name_1 := Name_Find;
3833 Error_Msg
3834 (Data.Flags,
3836 Casing_String.Location, Project);
3837 end;
3838 end if;
3842 if not Sep_Suffix.Default then
3843 if Length_Of_Name (Sep_Suffix.Value) = 0 then
3844 Error_Msg
3845 (Data.Flags,
3847 Sep_Suffix.Location, Project);
3849 else
3850 Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value);
3851 Sep_Suffix_Loc := Sep_Suffix.Location;
3853 Check_Illegal_Suffix
3854 (Project, Separate_Suffix,
3856 Data);
3857 end if;
3858 end if;
3860 if Separate_Suffix /= No_File then
3861 Write_Attr
3863 end if;
3864 end Check_Common;
3866 -----------------------------------
3867 -- Process_Exceptions_File_Based --
3868 -----------------------------------
3870 procedure Process_Exceptions_File_Based
3871 (Lang_Id : Language_Ptr;
3872 Kind : Source_Kind)
3873 is
3874 Lang : constant Name_Id := Lang_Id.Name;
3875 Exceptions : Array_Element_Id;
3876 Exception_List : Variable_Value;
3877 Element_Id : String_List_Id;
3878 Element : String_Element;
3879 File_Name : File_Name_Type;
3880 Source : Source_Id;
3882 begin
3883 case Kind is
3884 when Impl | Sep =>
3885 Exceptions :=
3886 Value_Of
3887 (Name_Implementation_Exceptions,
3888 In_Arrays => Naming.Decl.Arrays,
3889 Shared => Shared);
3891 when Spec =>
3892 Exceptions :=
3893 Value_Of
3894 (Name_Specification_Exceptions,
3895 In_Arrays => Naming.Decl.Arrays,
3896 Shared => Shared);
3897 end case;
3899 Exception_List :=
3900 Value_Of
3901 (Index => Lang,
3902 In_Array => Exceptions,
3903 Shared => Shared);
3905 if Exception_List /= Nil_Variable_Value then
3906 Element_Id := Exception_List.Values;
3907 while Element_Id /= Nil_String loop
3908 Element := Shared.String_Elements.Table (Element_Id);
3909 File_Name := Canonical_Case_File_Name (Element.Value);
3911 Source :=
3912 Source_Files_Htable.Get
3913 (Data.Tree.Source_Files_HT, File_Name);
3914 while Source /= No_Source
3915 and then Source.Project /= Project
3916 loop
3917 Source := Source.Next_With_File_Name;
3918 end loop;
3920 if Source = No_Source then
3921 Add_Source
3922 (Id => Source,
3923 Data => Data,
3924 Project => Project,
3925 Source_Dir_Rank => 0,
3926 Lang_Id => Lang_Id,
3927 Kind => Kind,
3928 File_Name => File_Name,
3929 Display_File => File_Name_Type (Element.Value),
3930 Naming_Exception => Yes,
3931 Location => Element.Location);
3933 else
3934 -- Check if the file name is already recorded for another
3935 -- language or another kind.
3937 if Source.Language /= Lang_Id then
3938 Error_Msg
3939 (Data.Flags,
3941 Element.Location, Project);
3943 elsif Source.Kind /= Kind then
3944 Error_Msg
3945 (Data.Flags,
3947 Element.Location, Project);
3948 end if;
3950 -- If the file is already recorded for the same
3951 -- language and the same kind, it means that the file
3952 -- name appears several times in the *_Exceptions
3953 -- attribute; so there is nothing to do.
3954 end if;
3956 Element_Id := Element.Next;
3957 end loop;
3958 end if;
3959 end Process_Exceptions_File_Based;
3961 -----------------------------------
3962 -- Process_Exceptions_Unit_Based --
3963 -----------------------------------
3965 procedure Process_Exceptions_Unit_Based
3966 (Lang_Id : Language_Ptr;
3967 Kind : Source_Kind)
3968 is
3969 Exceptions : Array_Element_Id;
3970 Element : Array_Element;
3971 Unit : Name_Id;
3972 Index : Int;
3973 File_Name : File_Name_Type;
3974 Source : Source_Id;
3976 Naming_Exception : Naming_Exception_Type;
3978 begin
3979 case Kind is
3980 when Impl | Sep =>
3981 Exceptions :=
3982 Value_Of
3983 (Name_Body,
3984 In_Arrays => Naming.Decl.Arrays,
3985 Shared => Shared);
3987 if Exceptions = No_Array_Element then
3988 Exceptions :=
3989 Value_Of
3990 (Name_Implementation,
3991 In_Arrays => Naming.Decl.Arrays,
3992 Shared => Shared);
3993 end if;
3995 when Spec =>
3996 Exceptions :=
3997 Value_Of
3998 (Name_Spec,
3999 In_Arrays => Naming.Decl.Arrays,
4000 Shared => Shared);
4002 if Exceptions = No_Array_Element then
4003 Exceptions :=
4004 Value_Of
4005 (Name_Specification,
4006 In_Arrays => Naming.Decl.Arrays,
4007 Shared => Shared);
4008 end if;
4009 end case;
4011 while Exceptions /= No_Array_Element loop
4012 Element := Shared.Array_Elements.Table (Exceptions);
4014 if Element.Restricted then
4015 Naming_Exception := Inherited;
4016 else
4017 Naming_Exception := Yes;
4018 end if;
4020 File_Name := Canonical_Case_File_Name (Element.Value.Value);
4022 Get_Name_String (Element.Index);
4023 To_Lower (Name_Buffer (1 .. Name_Len));
4024 Index := Element.Value.Index;
4026 -- Check if it is a valid unit name
4028 Get_Name_String (Element.Index);
4029 Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit);
4031 if Unit = No_Name then
4032 Err_Vars.Error_Msg_Name_1 := Element.Index;
4033 Error_Msg
4034 (Data.Flags,
4036 Element.Value.Location, Project);
4037 end if;
4039 if Unit /= No_Name then
4040 Add_Source
4041 (Id => Source,
4042 Data => Data,
4043 Project => Project,
4044 Source_Dir_Rank => 0,
4045 Lang_Id => Lang_Id,
4046 Kind => Kind,
4047 File_Name => File_Name,
4048 Display_File => File_Name_Type (Element.Value.Value),
4049 Unit => Unit,
4050 Index => Index,
4051 Location => Element.Value.Location,
4052 Naming_Exception => Naming_Exception);
4053 end if;
4055 Exceptions := Element.Next;
4056 end loop;
4057 end Process_Exceptions_Unit_Based;
4059 ------------------
4060 -- Check_Naming --
4061 ------------------
4063 procedure Check_Naming is
4064 Dot_Replacement : File_Name_Type :=
4065 File_Name_Type
4066 (First_Name_Id + Character'Pos ('-'));
4067 Separate_Suffix : File_Name_Type := No_File;
4068 Casing : Casing_Type := All_Lower_Case;
4069 Casing_Defined : Boolean;
4070 Lang_Id : Language_Ptr;
4071 Sep_Suffix_Loc : Source_Ptr;
4072 Suffix : Variable_Value;
4073 Lang : Name_Id;
4075 begin
4076 Check_Common
4077 (Dot_Replacement => Dot_Replacement,
4078 Casing => Casing,
4079 Casing_Defined => Casing_Defined,
4080 Separate_Suffix => Separate_Suffix,
4081 Sep_Suffix_Loc => Sep_Suffix_Loc);
4083 -- For all unit based languages, if any, set the specified value
4084 -- of Dot_Replacement, Casing and/or Separate_Suffix. Do not
4085 -- systematically overwrite, since the defaults come from the
4086 -- configuration file.
4088 if Dot_Replacement /= No_File
4089 or else Casing_Defined
4090 or else Separate_Suffix /= No_File
4091 then
4092 Lang_Id := Project.Languages;
4093 while Lang_Id /= No_Language_Index loop
4094 if Lang_Id.Config.Kind = Unit_Based then
4095 if Dot_Replacement /= No_File then
4096 Lang_Id.Config.Naming_Data.Dot_Replacement :=
4097 Dot_Replacement;
4098 end if;
4100 if Casing_Defined then
4101 Lang_Id.Config.Naming_Data.Casing := Casing;
4102 end if;
4103 end if;
4105 Lang_Id := Lang_Id.Next;
4106 end loop;
4107 end if;
4109 -- Next, get the spec and body suffixes
4111 Lang_Id := Project.Languages;
4112 while Lang_Id /= No_Language_Index loop
4113 Lang := Lang_Id.Name;
4115 -- Spec_Suffix
4117 Suffix := Value_Of
4118 (Name => Lang,
4119 Attribute_Or_Array_Name => Name_Spec_Suffix,
4120 In_Package => Naming_Id,
4121 Shared => Shared);
4123 if Suffix = Nil_Variable_Value then
4124 Suffix := Value_Of
4125 (Name => Lang,
4126 Attribute_Or_Array_Name => Name_Specification_Suffix,
4127 In_Package => Naming_Id,
4128 Shared => Shared);
4129 end if;
4131 if Suffix /= Nil_Variable_Value then
4132 Lang_Id.Config.Naming_Data.Spec_Suffix :=
4133 File_Name_Type (Suffix.Value);
4135 Check_Illegal_Suffix
4136 (Project,
4137 Lang_Id.Config.Naming_Data.Spec_Suffix,
4138 Lang_Id.Config.Naming_Data.Dot_Replacement,
4141 Write_Attr
4143 Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix));
4144 end if;
4146 -- Body_Suffix
4148 Suffix :=
4149 Value_Of
4150 (Name => Lang,
4151 Attribute_Or_Array_Name => Name_Body_Suffix,
4152 In_Package => Naming_Id,
4153 Shared => Shared);
4155 if Suffix = Nil_Variable_Value then
4156 Suffix :=
4157 Value_Of
4158 (Name => Lang,
4159 Attribute_Or_Array_Name => Name_Implementation_Suffix,
4160 In_Package => Naming_Id,
4161 Shared => Shared);
4162 end if;
4164 if Suffix /= Nil_Variable_Value then
4165 Lang_Id.Config.Naming_Data.Body_Suffix :=
4166 File_Name_Type (Suffix.Value);
4168 -- The default value of separate suffix should be the same as
4169 -- the body suffix, so we need to compute that first.
4171 if Separate_Suffix = No_File then
4172 Lang_Id.Config.Naming_Data.Separate_Suffix :=
4173 Lang_Id.Config.Naming_Data.Body_Suffix;
4174 Write_Attr
4176 Get_Name_String
4177 (Lang_Id.Config.Naming_Data.Separate_Suffix));
4178 else
4179 Lang_Id.Config.Naming_Data.Separate_Suffix :=
4180 Separate_Suffix;
4181 end if;
4183 Check_Illegal_Suffix
4184 (Project,
4185 Lang_Id.Config.Naming_Data.Body_Suffix,
4186 Lang_Id.Config.Naming_Data.Dot_Replacement,
4189 Write_Attr
4191 Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix));
4193 elsif Separate_Suffix /= No_File then
4194 Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix;
4195 end if;
4197 -- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix,
4198 -- since that would cause a clear ambiguity. Note that we do allow
4199 -- a Spec_Suffix to have the same termination as one of these,
4200 -- which causes a potential ambiguity, but we resolve that by
4201 -- matching the longest possible suffix.
4203 if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File
4204 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
4205 Lang_Id.Config.Naming_Data.Body_Suffix
4206 then
4207 Error_Msg
4208 (Data.Flags,
4210 & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)
4212 Ada_Body_Suffix_Loc, Project);
4213 end if;
4215 if Lang_Id.Config.Naming_Data.Body_Suffix /=
4216 Lang_Id.Config.Naming_Data.Separate_Suffix
4217 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
4218 Lang_Id.Config.Naming_Data.Separate_Suffix
4219 then
4220 Error_Msg
4221 (Data.Flags,
4223 & Get_Name_String
4224 (Lang_Id.Config.Naming_Data.Separate_Suffix)
4226 Sep_Suffix_Loc, Project);
4227 end if;
4229 Lang_Id := Lang_Id.Next;
4230 end loop;
4232 -- Get the naming exceptions for all languages, but not for virtual
4233 -- projects.
4235 if not Project.Virtual then
4236 for Kind in Spec_Or_Body loop
4237 Lang_Id := Project.Languages;
4238 while Lang_Id /= No_Language_Index loop
4239 case Lang_Id.Config.Kind is
4240 when File_Based =>
4241 Process_Exceptions_File_Based (Lang_Id, Kind);
4243 when Unit_Based =>
4244 Process_Exceptions_Unit_Based (Lang_Id, Kind);
4245 end case;
4247 Lang_Id := Lang_Id.Next;
4248 end loop;
4249 end loop;
4250 end if;
4251 end Check_Naming;
4253 ----------------------------
4254 -- Initialize_Naming_Data --
4255 ----------------------------
4257 procedure Initialize_Naming_Data is
4258 Specs : Array_Element_Id :=
4259 Util.Value_Of
4260 (Name_Spec_Suffix,
4261 Naming.Decl.Arrays,
4262 Shared);
4264 Impls : Array_Element_Id :=
4265 Util.Value_Of
4266 (Name_Body_Suffix,
4267 Naming.Decl.Arrays,
4268 Shared);
4270 Lang : Language_Ptr;
4271 Lang_Name : Name_Id;
4272 Value : Variable_Value;
4273 Extended : Project_Id;
4275 begin
4276 -- At this stage, the project already contains the default extensions
4277 -- for the various languages. We now merge those suffixes read in the
4278 -- user project, and they override the default.
4280 while Specs /= No_Array_Element loop
4281 Lang_Name := Shared.Array_Elements.Table (Specs).Index;
4282 Lang :=
4283 Get_Language_From_Name
4284 (Project, Name => Get_Name_String (Lang_Name));
4286 -- An extending project inherits its parent projects' languages
4287 -- so if needed we should create entries for those languages
4289 if Lang = null then
4290 Extended := Project.Extends;
4291 while Extended /= null loop
4292 Lang := Get_Language_From_Name
4293 (Extended, Name => Get_Name_String (Lang_Name));
4294 exit when Lang /= null;
4296 Extended := Extended.Extends;
4297 end loop;
4299 if Lang /= null then
4300 Lang := new Language_Data'(Lang.all);
4301 Lang.First_Source := null;
4302 Lang.Next := Project.Languages;
4303 Project.Languages := Lang;
4304 end if;
4305 end if;
4307 -- If language was not found in project or the projects it extends
4309 if Lang = null then
4310 Debug_Output
4312 Lang_Name);
4314 else
4315 Value := Shared.Array_Elements.Table (Specs).Value;
4317 if Value.Kind = Single then
4318 Lang.Config.Naming_Data.Spec_Suffix :=
4319 Canonical_Case_File_Name (Value.Value);
4320 end if;
4321 end if;
4323 Specs := Shared.Array_Elements.Table (Specs).Next;
4324 end loop;
4326 while Impls /= No_Array_Element loop
4327 Lang_Name := Shared.Array_Elements.Table (Impls).Index;
4328 Lang :=
4329 Get_Language_From_Name
4330 (Project, Name => Get_Name_String (Lang_Name));
4332 if Lang = null then
4333 Debug_Output
4335 Lang_Name);
4336 else
4337 Value := Shared.Array_Elements.Table (Impls).Value;
4339 if Lang.Name = Name_Ada then
4340 Ada_Body_Suffix_Loc := Value.Location;
4341 end if;
4343 if Value.Kind = Single then
4344 Lang.Config.Naming_Data.Body_Suffix :=
4345 Canonical_Case_File_Name (Value.Value);
4346 end if;
4347 end if;
4349 Impls := Shared.Array_Elements.Table (Impls).Next;
4350 end loop;
4351 end Initialize_Naming_Data;
4353 -- Start of processing for Check_Naming_Schemes
4355 begin
4356 -- No Naming package or parsing a configuration file? nothing to do
4358 if Naming_Id /= No_Package
4359 and then Project.Qualifier /= Configuration
4360 then
4361 Naming := Shared.Packages.Table (Naming_Id);
4363 Initialize_Naming_Data;
4364 Check_Naming;
4366 end if;
4367 end Check_Package_Naming;
4369 ---------------------------------
4370 -- Check_Programming_Languages --
4371 ---------------------------------
4373 procedure Check_Programming_Languages
4374 (Project : Project_Id;
4375 Data : in out Tree_Processing_Data)
4376 is
4377 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
4379 Languages : Variable_Value := Nil_Variable_Value;
4380 Def_Lang : Variable_Value := Nil_Variable_Value;
4381 Def_Lang_Id : Name_Id;
4383 procedure Add_Language (Name, Display_Name : Name_Id);
4384 -- Add a new language to the list of languages for the project.
4385 -- Nothing is done if the language has already been defined
4387 ------------------
4388 -- Add_Language --
4389 ------------------
4391 procedure Add_Language (Name, Display_Name : Name_Id) is
4392 Lang : Language_Ptr;
4394 begin
4395 Lang := Project.Languages;
4396 while Lang /= No_Language_Index loop
4397 if Name = Lang.Name then
4398 return;
4399 end if;
4401 Lang := Lang.Next;
4402 end loop;
4404 Lang := new Language_Data'(No_Language_Data);
4405 Lang.Next := Project.Languages;
4406 Project.Languages := Lang;
4407 Lang.Name := Name;
4408 Lang.Display_Name := Display_Name;
4409 end Add_Language;
4411 -- Start of processing for Check_Programming_Languages
4413 begin
4414 Project.Languages := null;
4415 Languages :=
4416 Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, Shared);
4417 Def_Lang :=
4418 Prj.Util.Value_Of
4419 (Name_Default_Language, Project.Decl.Attributes, Shared);
4421 if Project.Source_Dirs /= Nil_String then
4423 -- Check if languages are specified in this project
4425 if Languages.Default then
4427 -- Fail if there is no default language defined
4429 if Def_Lang.Default then
4430 Error_Msg
4431 (Data.Flags,
4433 Project.Location, Project);
4434 Def_Lang_Id := No_Name;
4436 else
4437 Get_Name_String (Def_Lang.Value);
4438 To_Lower (Name_Buffer (1 .. Name_Len));
4439 Def_Lang_Id := Name_Find;
4440 end if;
4442 if Def_Lang_Id /= No_Name then
4443 Get_Name_String (Def_Lang_Id);
4444 Name_Buffer (1) := GNAT.Case_Util.To_Upper (Name_Buffer (1));
4445 Add_Language
4446 (Name => Def_Lang_Id,
4447 Display_Name => Name_Find);
4448 end if;
4450 else
4451 declare
4452 Current : String_List_Id := Languages.Values;
4453 Element : String_Element;
4455 begin
4456 -- If there are no languages declared, there are no sources
4458 if Current = Nil_String then
4459 Project.Source_Dirs := Nil_String;
4461 if Project.Qualifier = Standard then
4462 Error_Msg
4463 (Data.Flags,
4465 Languages.Location, Project);
4466 end if;
4468 else
4469 -- Look through all the languages specified in attribute
4470 -- Languages.
4472 while Current /= Nil_String loop
4473 Element := Shared.String_Elements.Table (Current);
4474 Get_Name_String (Element.Value);
4475 To_Lower (Name_Buffer (1 .. Name_Len));
4477 Add_Language
4478 (Name => Name_Find,
4479 Display_Name => Element.Value);
4481 Current := Element.Next;
4482 end loop;
4483 end if;
4484 end;
4485 end if;
4486 end if;
4487 end Check_Programming_Languages;
4489 -------------------------------
4490 -- Check_Stand_Alone_Library --
4491 -------------------------------
4493 procedure Check_Stand_Alone_Library
4494 (Project : Project_Id;
4495 Data : in out Tree_Processing_Data)
4496 is
4497 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
4499 Lib_Name : constant Prj.Variable_Value :=
4500 Prj.Util.Value_Of
4501 (Snames.Name_Library_Name,
4502 Project.Decl.Attributes,
4503 Shared);
4505 Lib_Standalone : constant Prj.Variable_Value :=
4506 Prj.Util.Value_Of
4507 (Snames.Name_Library_Standalone,
4508 Project.Decl.Attributes,
4509 Shared);
4511 Lib_Auto_Init : constant Prj.Variable_Value :=
4512 Prj.Util.Value_Of
4513 (Snames.Name_Library_Auto_Init,
4514 Project.Decl.Attributes,
4515 Shared);
4517 Lib_Src_Dir : constant Prj.Variable_Value :=
4518 Prj.Util.Value_Of
4519 (Snames.Name_Library_Src_Dir,
4520 Project.Decl.Attributes,
4521 Shared);
4523 Lib_Symbol_File : constant Prj.Variable_Value :=
4524 Prj.Util.Value_Of
4525 (Snames.Name_Library_Symbol_File,
4526 Project.Decl.Attributes,
4527 Shared);
4529 Lib_Symbol_Policy : constant Prj.Variable_Value :=
4530 Prj.Util.Value_Of
4531 (Snames.Name_Library_Symbol_Policy,
4532 Project.Decl.Attributes,
4533 Shared);
4535 Lib_Ref_Symbol_File : constant Prj.Variable_Value :=
4536 Prj.Util.Value_Of
4537 (Snames.Name_Library_Reference_Symbol_File,
4538 Project.Decl.Attributes,
4539 Shared);
4541 Auto_Init_Supported : Boolean;
4542 OK : Boolean := True;
4544 begin
4545 Auto_Init_Supported := Project.Config.Auto_Init_Supported;
4547 -- It is a stand-alone library project file if there is at least one
4548 -- unit in the declared or inherited interface.
4550 if Project.Lib_Interface_ALIs = Nil_String then
4551 if not Lib_Standalone.Default
4553 then
4554 Error_Msg
4555 (Data.Flags,
4557 Lib_Standalone.Location, Project);
4558 end if;
4560 else
4561 if Project.Standalone_Library = No then
4562 Project.Standalone_Library := Standard;
4563 end if;
4565 -- The name of a stand-alone library needs to have the syntax of an
4566 -- Ada identifier.
4568 declare
4569 Name : constant String := Get_Name_String (Project.Library_Name);
4570 OK : Boolean := Is_Letter (Name (Name'First));
4572 Underline : Boolean := False;
4574 begin
4575 for J in Name'First + 1 .. Name'Last loop
4576 exit when not OK;
4578 if Is_Alphanumeric (Name (J)) then
4579 Underline := False;
4581 elsif Name (J) = '_' then
4582 if Underline then
4583 OK := False;
4584 else
4585 Underline := True;
4586 end if;
4588 else
4589 OK := False;
4590 end if;
4591 end loop;
4593 OK := OK and not Underline;
4595 if not OK then
4596 Error_Msg
4597 (Data.Flags,
4599 Lib_Name.Location, Project);
4600 return;
4601 end if;
4602 end;
4604 if Lib_Standalone.Default then
4605 Project.Standalone_Library := Standard;
4607 else
4608 Get_Name_String (Lib_Standalone.Value);
4609 To_Lower (Name_Buffer (1 .. Name_Len));
4612 Project.Standalone_Library := Standard;
4615 Project.Standalone_Library := Encapsulated;
4618 Project.Standalone_Library := No;
4619 Error_Msg
4620 (Data.Flags,
4623 Lib_Standalone.Location, Project);
4625 else
4626 Error_Msg
4627 (Data.Flags,
4629 Lib_Standalone.Location, Project);
4630 end if;
4631 end if;
4633 -- Check value of attribute Library_Auto_Init and set Lib_Auto_Init
4634 -- accordingly.
4636 if Lib_Auto_Init.Default then
4638 -- If no attribute Library_Auto_Init is declared, then set auto
4639 -- init only if it is supported.
4641 Project.Lib_Auto_Init := Auto_Init_Supported;
4643 else
4644 Get_Name_String (Lib_Auto_Init.Value);
4645 To_Lower (Name_Buffer (1 .. Name_Len));
4648 Project.Lib_Auto_Init := False;
4651 if Auto_Init_Supported then
4652 Project.Lib_Auto_Init := True;
4654 else
4656 -- supported.
4658 Error_Msg
4659 (Data.Flags,
4662 Lib_Auto_Init.Location, Project);
4663 end if;
4665 else
4666 Error_Msg
4667 (Data.Flags,
4669 Lib_Auto_Init.Location, Project);
4670 end if;
4671 end if;
4673 -- If attribute Library_Src_Dir is defined and not the empty string,
4674 -- check if the directory exist and is not the object directory or
4675 -- one of the source directories. This is the directory where copies
4676 -- of the interface sources will be copied. Note that this directory
4677 -- may be the library directory.
4679 if Lib_Src_Dir.Value /= Empty_String then
4680 declare
4681 Dir_Id : constant File_Name_Type :=
4682 File_Name_Type (Lib_Src_Dir.Value);
4683 Dir_Exists : Boolean;
4685 begin
4686 Locate_Directory
4687 (Project,
4688 Dir_Id,
4689 Path => Project.Library_Src_Dir,
4690 Dir_Exists => Dir_Exists,
4691 Data => Data,
4692 Must_Exist => False,
4694 Location => Lib_Src_Dir.Location,
4695 Externally_Built => Project.Externally_Built);
4697 -- If directory does not exist, report an error
4699 if not Dir_Exists then
4701 -- Get the absolute name of the library directory that does
4702 -- not exist, to report an error.
4704 Err_Vars.Error_Msg_File_1 :=
4705 File_Name_Type (Project.Library_Src_Dir.Display_Name);
4706 Error_Msg
4707 (Data.Flags,
4709 Lib_Src_Dir.Location, Project);
4711 -- Report error if it is the same as the object directory
4713 elsif Project.Library_Src_Dir = Project.Object_Directory then
4714 Error_Msg
4715 (Data.Flags,
4718 Lib_Src_Dir.Location, Project);
4719 Project.Library_Src_Dir := No_Path_Information;
4721 else
4722 declare
4723 Src_Dirs : String_List_Id;
4724 Src_Dir : String_Element;
4725 Pid : Project_List;
4727 begin
4728 -- Interface copy directory cannot be one of the source
4729 -- directory of the current project.
4731 Src_Dirs := Project.Source_Dirs;
4732 while Src_Dirs /= Nil_String loop
4733 Src_Dir := Shared.String_Elements.Table (Src_Dirs);
4735 -- Report error if it is one of the source directories
4737 if Project.Library_Src_Dir.Name =
4738 Path_Name_Type (Src_Dir.Value)
4739 then
4740 Error_Msg
4741 (Data.Flags,
4744 Lib_Src_Dir.Location, Project);
4745 Project.Library_Src_Dir := No_Path_Information;
4746 exit;
4747 end if;
4749 Src_Dirs := Src_Dir.Next;
4750 end loop;
4752 if Project.Library_Src_Dir /= No_Path_Information then
4754 -- It cannot be a source directory of any other
4755 -- project either.
4757 Pid := Data.Tree.Projects;
4758 Project_Loop : loop
4759 exit Project_Loop when Pid = null;
4761 Src_Dirs := Pid.Project.Source_Dirs;
4762 Dir_Loop : while Src_Dirs /= Nil_String loop
4763 Src_Dir :=
4764 Shared.String_Elements.Table (Src_Dirs);
4766 -- Report error if it is one of the source
4767 -- directories.
4769 if Project.Library_Src_Dir.Name =
4770 Path_Name_Type (Src_Dir.Value)
4771 then
4772 Error_Msg_File_1 :=
4773 File_Name_Type (Src_Dir.Value);
4774 Error_Msg_Name_1 := Pid.Project.Name;
4775 Error_Msg
4776 (Data.Flags,
4780 Lib_Src_Dir.Location, Project);
4781 Project.Library_Src_Dir :=
4782 No_Path_Information;
4783 exit Project_Loop;
4784 end if;
4786 Src_Dirs := Src_Dir.Next;
4787 end loop Dir_Loop;
4789 Pid := Pid.Next;
4790 end loop Project_Loop;
4791 end if;
4792 end;
4794 -- In high verbosity, if there is a valid Library_Src_Dir,
4795 -- display its path name.
4797 if Project.Library_Src_Dir /= No_Path_Information
4798 and then Current_Verbosity = High
4799 then
4800 Write_Attr
4802 Get_Name_String (Project.Library_Src_Dir.Name));
4803 end if;
4804 end if;
4805 end;
4806 end if;
4808 -- Check the symbol related attributes
4810 -- First, the symbol policy
4812 if not Lib_Symbol_Policy.Default then
4813 declare
4814 Value : constant String :=
4815 To_Lower
4816 (Get_Name_String (Lib_Symbol_Policy.Value));
4818 begin
4819 -- Symbol policy must have one of a limited number of values
4822 Project.Symbol_Data.Symbol_Policy := Autonomous;
4825 Project.Symbol_Data.Symbol_Policy := Compliant;
4828 Project.Symbol_Data.Symbol_Policy := Controlled;
4831 Project.Symbol_Data.Symbol_Policy := Restricted;
4834 Project.Symbol_Data.Symbol_Policy := Direct;
4836 else
4837 Error_Msg
4838 (Data.Flags,
4840 Lib_Symbol_Policy.Location, Project);
4841 end if;
4842 end;
4843 end if;
4845 -- If attribute Library_Symbol_File is not specified, symbol policy
4846 -- cannot be Restricted.
4848 if Lib_Symbol_File.Default then
4849 if Project.Symbol_Data.Symbol_Policy = Restricted then
4850 Error_Msg
4851 (Data.Flags,
4854 Lib_Symbol_Policy.Location, Project);
4855 end if;
4857 else
4858 -- Library_Symbol_File is defined
4860 Project.Symbol_Data.Symbol_File :=
4861 Path_Name_Type (Lib_Symbol_File.Value);
4863 Get_Name_String (Lib_Symbol_File.Value);
4865 if Name_Len = 0 then
4866 Error_Msg
4867 (Data.Flags,
4869 Lib_Symbol_File.Location, Project);
4871 else
4872 OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
4874 if OK then
4875 for J in 1 .. Name_Len loop
4876 if Name_Buffer (J) = '/'
4877 or else Name_Buffer (J) = Directory_Separator
4878 then
4879 OK := False;
4880 exit;
4881 end if;
4882 end loop;
4883 end if;
4885 if not OK then
4886 Error_Msg_File_1 := File_Name_Type (Lib_Symbol_File.Value);
4887 Error_Msg
4888 (Data.Flags,
4891 Lib_Symbol_File.Location, Project);
4892 end if;
4893 end if;
4894 end if;
4896 -- If attribute Library_Reference_Symbol_File is not defined,
4897 -- symbol policy cannot be Compliant or Controlled.
4899 if Lib_Ref_Symbol_File.Default then
4900 if Project.Symbol_Data.Symbol_Policy = Compliant
4901 or else Project.Symbol_Data.Symbol_Policy = Controlled
4902 then
4903 Error_Msg
4904 (Data.Flags,
4906 Lib_Symbol_Policy.Location, Project);
4907 end if;
4909 else
4910 -- Library_Reference_Symbol_File is defined, check file exists
4912 Project.Symbol_Data.Reference :=
4913 Path_Name_Type (Lib_Ref_Symbol_File.Value);
4915 Get_Name_String (Lib_Ref_Symbol_File.Value);
4917 if Name_Len = 0 then
4918 Error_Msg
4919 (Data.Flags,
4921 Lib_Symbol_File.Location, Project);
4923 else
4924 if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then
4925 Name_Len := 0;
4926 Add_Str_To_Name_Buffer
4927 (Get_Name_String (Project.Directory.Name));
4928 Add_Str_To_Name_Buffer
4929 (Get_Name_String (Lib_Ref_Symbol_File.Value));
4930 Project.Symbol_Data.Reference := Name_Find;
4931 end if;
4933 if not Is_Regular_File
4934 (Get_Name_String (Project.Symbol_Data.Reference))
4935 then
4936 Error_Msg_File_1 :=
4937 File_Name_Type (Lib_Ref_Symbol_File.Value);
4939 -- For controlled and direct symbol policies, it is an error
4940 -- if the reference symbol file does not exist. For other
4941 -- symbol policies, this is just a warning
4943 Error_Msg_Warn :=
4944 Project.Symbol_Data.Symbol_Policy /= Controlled
4945 and then Project.Symbol_Data.Symbol_Policy /= Direct;
4947 Error_Msg
4948 (Data.Flags,
4950 Lib_Ref_Symbol_File.Location, Project);
4952 -- In addition in the non-controlled case, if symbol policy
4953 -- is Compliant, it is changed to Autonomous, because there
4954 -- is no reference to check against, and we don't want to
4955 -- fail in this case.
4957 if Project.Symbol_Data.Symbol_Policy /= Controlled then
4958 if Project.Symbol_Data.Symbol_Policy = Compliant then
4959 Project.Symbol_Data.Symbol_Policy := Autonomous;
4960 end if;
4961 end if;
4962 end if;
4964 -- If both the reference symbol file and the symbol file are
4965 -- defined, then check that they are not the same file.
4967 if Project.Symbol_Data.Symbol_File /= No_Path then
4968 Get_Name_String (Project.Symbol_Data.Symbol_File);
4970 if Name_Len > 0 then
4971 declare
4972 -- We do not need to pass a Directory to
4973 -- Normalize_Pathname, since the path_information
4974 -- already contains absolute information.
4976 Symb_Path : constant String :=
4977 Normalize_Pathname
4978 (Get_Name_String
4979 (Project.Object_Directory.Name) &
4980 Name_Buffer (1 .. Name_Len),
4982 Resolve_Links =>
4983 Opt.Follow_Links_For_Files);
4984 Ref_Path : constant String :=
4985 Normalize_Pathname
4986 (Get_Name_String
4987 (Project.Symbol_Data.Reference),
4989 Resolve_Links =>
4990 Opt.Follow_Links_For_Files);
4991 begin
4992 if Symb_Path = Ref_Path then
4993 Error_Msg
4994 (Data.Flags,
4997 Lib_Ref_Symbol_File.Location, Project);
4998 end if;
4999 end;
5000 end if;
5001 end if;
5002 end if;
5003 end if;
5004 end if;
5005 end Check_Stand_Alone_Library;
5007 ---------------------
5008 -- Check_Unit_Name --
5009 ---------------------
5011 procedure Check_Unit_Name (Name : String; Unit : out Name_Id) is
5012 The_Name : String := Name;
5013 Real_Name : Name_Id;
5014 Need_Letter : Boolean := True;
5015 Last_Underscore : Boolean := False;
5016 OK : Boolean := The_Name'Length > 0;
5017 First : Positive;
5019 function Is_Reserved (Name : Name_Id) return Boolean;
5020 function Is_Reserved (S : String) return Boolean;
5021 -- Check that the given name is not an Ada 95 reserved word. The reason
5022 -- for the Ada 95 here is that we do not want to exclude the case of an
5023 -- Ada 95 unit called Interface (for example). In Ada 2005, such a unit
5024 -- name would be rejected anyway by the compiler. That means there is no
5025 -- requirement that the project file parser reject this.
5027 -----------------
5028 -- Is_Reserved --
5029 -----------------
5031 function Is_Reserved (S : String) return Boolean is
5032 begin
5033 Name_Len := 0;
5034 Add_Str_To_Name_Buffer (S);
5035 return Is_Reserved (Name_Find);
5036 end Is_Reserved;
5038 -----------------
5039 -- Is_Reserved --
5040 -----------------
5042 function Is_Reserved (Name : Name_Id) return Boolean is
5043 begin
5044 if Get_Name_Table_Byte (Name) /= 0
5045 and then
5046 not Nam_In (Name, Name_Project, Name_Extends, Name_External)
5047 and then Name not in Ada_2005_Reserved_Words
5048 then
5049 Unit := No_Name;
5051 return True;
5053 else
5054 return False;
5055 end if;
5056 end Is_Reserved;
5058 -- Start of processing for Check_Unit_Name
5060 begin
5061 To_Lower (The_Name);
5063 Name_Len := The_Name'Length;
5064 Name_Buffer (1 .. Name_Len) := The_Name;
5066 -- Special cases of children of packages A, G, I and S on VMS
5068 if OpenVMS_On_Target
5069 and then Name_Len > 3
5071 and then
5072 (Name_Buffer (1) = 'a' or else
5073 Name_Buffer (1) = 'g' or else
5074 Name_Buffer (1) = 'i' or else
5075 Name_Buffer (1) = 's')
5076 then
5077 Name_Buffer (2) := '.';
5078 Name_Buffer (3 .. Name_Len - 1) := Name_Buffer (4 .. Name_Len);
5079 Name_Len := Name_Len - 1;
5080 end if;
5082 Real_Name := Name_Find;
5084 if Is_Reserved (Real_Name) then
5085 return;
5086 end if;
5088 First := The_Name'First;
5090 for Index in The_Name'Range loop
5091 if Need_Letter then
5093 -- We need a letter (at the beginning, and following a dot),
5094 -- but we don't have one.
5096 if Is_Letter (The_Name (Index)) then
5097 Need_Letter := False;
5099 else
5100 OK := False;
5102 if Current_Verbosity = High then
5103 Debug_Indent;
5104 Write_Int (Types.Int (Index));
5106 Write_Char (The_Name (Index));
5108 end if;
5110 exit;
5111 end if;
5113 elsif Last_Underscore
5114 and then (The_Name (Index) = '_' or else The_Name (Index) = '.')
5115 then
5116 -- Two underscores are illegal, and a dot cannot follow
5117 -- an underscore.
5119 OK := False;
5121 if Current_Verbosity = High then
5122 Debug_Indent;
5123 Write_Int (Types.Int (Index));
5125 Write_Char (The_Name (Index));
5127 end if;
5129 exit;
5131 elsif The_Name (Index) = '.' then
5133 -- First, check if the name before the dot is not a reserved word
5135 if Is_Reserved (The_Name (First .. Index - 1)) then
5136 return;
5137 end if;
5139 First := Index + 1;
5141 -- We need a letter after a dot
5143 Need_Letter := True;
5145 elsif The_Name (Index) = '_' then
5146 Last_Underscore := True;
5148 else
5149 -- We need an letter or a digit
5151 Last_Underscore := False;
5153 if not Is_Alphanumeric (The_Name (Index)) then
5154 OK := False;
5156 if Current_Verbosity = High then
5157 Debug_Indent;
5158 Write_Int (Types.Int (Index));
5160 Write_Char (The_Name (Index));
5162 end if;
5164 exit;
5165 end if;
5166 end if;
5167 end loop;
5169 -- Cannot end with an underscore or a dot
5171 OK := OK and then not Need_Letter and then not Last_Underscore;
5173 if OK then
5174 if First /= Name'First
5175 and then Is_Reserved (The_Name (First .. The_Name'Last))
5176 then
5177 return;
5178 end if;
5180 Unit := Real_Name;
5182 else
5183 -- Signal a problem with No_Name
5185 Unit := No_Name;
5186 end if;
5187 end Check_Unit_Name;
5189 ----------------------------
5190 -- Compute_Directory_Last --
5191 ----------------------------
5193 function Compute_Directory_Last (Dir : String) return Natural is
5194 begin
5195 if Dir'Length > 1
5196 and then (Dir (Dir'Last - 1) = Directory_Separator
5197 or else
5198 Dir (Dir'Last - 1) = '/')
5199 then
5200 return Dir'Last - 1;
5201 else
5202 return Dir'Last;
5203 end if;
5204 end Compute_Directory_Last;
5206 ---------------------
5207 -- Get_Directories --
5208 ---------------------
5210 procedure Get_Directories
5211 (Project : Project_Id;
5212 Data : in out Tree_Processing_Data)
5213 is
5214 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
5216 Object_Dir : constant Variable_Value :=
5217 Util.Value_Of
5218 (Name_Object_Dir, Project.Decl.Attributes, Shared);
5220 Exec_Dir : constant Variable_Value :=
5221 Util.Value_Of
5222 (Name_Exec_Dir, Project.Decl.Attributes, Shared);
5224 Source_Dirs : constant Variable_Value :=
5225 Util.Value_Of
5226 (Name_Source_Dirs, Project.Decl.Attributes, Shared);
5228 Ignore_Source_Sub_Dirs : constant Variable_Value :=
5229 Util.Value_Of
5230 (Name_Ignore_Source_Sub_Dirs,
5231 Project.Decl.Attributes,
5232 Shared);
5234 Excluded_Source_Dirs : constant Variable_Value :=
5235 Util.Value_Of
5236 (Name_Excluded_Source_Dirs,
5237 Project.Decl.Attributes,
5238 Shared);
5240 Source_Files : constant Variable_Value :=
5241 Util.Value_Of
5242 (Name_Source_Files,
5243 Project.Decl.Attributes, Shared);
5245 Last_Source_Dir : String_List_Id := Nil_String;
5246 Last_Src_Dir_Rank : Number_List_Index := No_Number_List;
5248 Languages : constant Variable_Value :=
5249 Prj.Util.Value_Of
5250 (Name_Languages, Project.Decl.Attributes, Shared);
5252 Remove_Source_Dirs : Boolean := False;
5254 procedure Add_To_Or_Remove_From_Source_Dirs
5255 (Path : Path_Information;
5256 Rank : Natural);
5257 -- When Removed = False, the directory Path_Id to the list of
5258 -- source_dirs if not already in the list. When Removed = True,
5259 -- removed directory Path_Id if in the list.
5261 procedure Find_Source_Dirs is new Expand_Subdirectory_Pattern
5262 (Add_To_Or_Remove_From_Source_Dirs);
5264 ---------------------------------------
5265 -- Add_To_Or_Remove_From_Source_Dirs --
5266 ---------------------------------------
5268 procedure Add_To_Or_Remove_From_Source_Dirs
5269 (Path : Path_Information;
5270 Rank : Natural)
5271 is
5272 List : String_List_Id;
5273 Prev : String_List_Id;
5274 Rank_List : Number_List_Index;
5275 Prev_Rank : Number_List_Index;
5276 Element : String_Element;
5278 begin
5279 Prev := Nil_String;
5280 Prev_Rank := No_Number_List;
5281 List := Project.Source_Dirs;
5282 Rank_List := Project.Source_Dir_Ranks;
5283 while List /= Nil_String loop
5284 Element := Shared.String_Elements.Table (List);
5285 exit when Element.Value = Name_Id (Path.Name);
5286 Prev := List;
5287 List := Element.Next;
5288 Prev_Rank := Rank_List;
5289 Rank_List := Shared.Number_Lists.Table (Prev_Rank).Next;
5290 end loop;
5292 -- The directory is in the list if List is not Nil_String
5294 if not Remove_Source_Dirs and then List = Nil_String then
5297 String_Element_Table.Increment_Last (Shared.String_Elements);
5298 Element :=
5299 (Value => Name_Id (Path.Name),
5300 Index => 0,
5301 Display_Value => Name_Id (Path.Display_Name),
5302 Location => No_Location,
5303 Flag => False,
5304 Next => Nil_String);
5306 Number_List_Table.Increment_Last (Shared.Number_Lists);
5308 if Last_Source_Dir = Nil_String then
5310 -- This is the first source directory
5312 Project.Source_Dirs :=
5313 String_Element_Table.Last (Shared.String_Elements);
5314 Project.Source_Dir_Ranks :=
5315 Number_List_Table.Last (Shared.Number_Lists);
5317 else
5318 -- We already have source directories, link the previous
5319 -- last to the new one.
5321 Shared.String_Elements.Table (Last_Source_Dir).Next :=
5322 String_Element_Table.Last (Shared.String_Elements);
5323 Shared.Number_Lists.Table (Last_Src_Dir_Rank).Next :=
5324 Number_List_Table.Last (Shared.Number_Lists);
5325 end if;
5327 -- And register this source directory as the new last
5329 Last_Source_Dir :=
5330 String_Element_Table.Last (Shared.String_Elements);
5331 Shared.String_Elements.Table (Last_Source_Dir) := Element;
5332 Last_Src_Dir_Rank := Number_List_Table.Last (Shared.Number_Lists);
5333 Shared.Number_Lists.Table (Last_Src_Dir_Rank) :=
5334 (Number => Rank, Next => No_Number_List);
5336 elsif Remove_Source_Dirs and then List /= Nil_String then
5338 -- Remove source dir if present
5340 if Prev = Nil_String then
5341 Project.Source_Dirs := Shared.String_Elements.Table (List).Next;
5342 Project.Source_Dir_Ranks :=
5343 Shared.Number_Lists.Table (Rank_List).Next;
5345 else
5346 Shared.String_Elements.Table (Prev).Next :=
5347 Shared.String_Elements.Table (List).Next;
5348 Shared.Number_Lists.Table (Prev_Rank).Next :=
5349 Shared.Number_Lists.Table (Rank_List).Next;
5350 end if;
5351 end if;
5352 end Add_To_Or_Remove_From_Source_Dirs;
5354 -- Local declarations
5356 Dir_Exists : Boolean;
5358 No_Sources : constant Boolean :=
5359 ((not Source_Files.Default
5360 and then Source_Files.Values = Nil_String)
5361 or else
5362 (not Source_Dirs.Default
5363 and then Source_Dirs.Values = Nil_String)
5364 or else
5365 (not Languages.Default
5366 and then Languages.Values = Nil_String))
5367 and then Project.Extends = No_Project;
5369 -- Start of processing for Get_Directories
5371 begin
5374 -- Set the object directory to its default which may be nil, if there
5375 -- is no sources in the project.
5377 if No_Sources then
5378 Project.Object_Directory := No_Path_Information;
5379 else
5380 Project.Object_Directory := Project.Directory;
5381 end if;
5383 -- Check the object directory
5385 if Object_Dir.Value /= Empty_String then
5386 Get_Name_String (Object_Dir.Value);
5388 if Name_Len = 0 then
5389 Error_Msg
5390 (Data.Flags,
5392 Object_Dir.Location, Project);
5394 elsif Setup_Projects
5395 and then No_Sources
5396 and then Project.Extends = No_Project
5397 then
5398 -- Do not create an object directory for a non extending project
5399 -- with no sources.
5401 Locate_Directory
5402 (Project,
5403 File_Name_Type (Object_Dir.Value),
5404 Path => Project.Object_Directory,
5405 Dir_Exists => Dir_Exists,
5406 Data => Data,
5407 Location => Object_Dir.Location,
5408 Must_Exist => False,
5409 Externally_Built => Project.Externally_Built);
5411 else
5412 -- We check that the specified object directory does exist.
5413 -- However, even when it doesn't exist, we set it to a default
5414 -- value. This is for the benefit of tools that recover from
5415 -- errors; for example, these tools could create the non existent
5416 -- directory. We always return an absolute directory name though.
5418 Locate_Directory
5419 (Project,
5420 File_Name_Type (Object_Dir.Value),
5421 Path => Project.Object_Directory,
5423 Dir_Exists => Dir_Exists,
5424 Data => Data,
5425 Location => Object_Dir.Location,
5426 Must_Exist => False,
5427 Externally_Built => Project.Externally_Built);
5429 if not Dir_Exists and then not Project.Externally_Built then
5430 if Opt.Directories_Must_Exist_In_Projects then
5431 -- The object directory does not exist, report an error if
5432 -- the project is not externally built.
5434 Err_Vars.Error_Msg_File_1 :=
5435 File_Name_Type (Object_Dir.Value);
5436 Error_Or_Warning
5437 (Data.Flags, Data.Flags.Require_Obj_Dirs,
5439 Project.Location, Project);
5441 else
5442 Project.Object_Directory := No_Path_Information;
5443 end if;
5444 end if;
5445 end if;
5447 elsif not No_Sources and then Subdirs /= null then
5448 Name_Len := 1;
5449 Name_Buffer (1) := '.';
5450 Locate_Directory
5451 (Project,
5452 Name_Find,
5453 Path => Project.Object_Directory,
5455 Dir_Exists => Dir_Exists,
5456 Data => Data,
5457 Location => Object_Dir.Location,
5458 Externally_Built => Project.Externally_Built);
5459 end if;
5461 if Current_Verbosity = High then
5462 if Project.Object_Directory = No_Path_Information then
5464 else
5465 Write_Attr
5467 Get_Name_String (Project.Object_Directory.Display_Name));
5468 end if;
5469 end if;
5471 -- Check the exec directory
5473 -- We set the object directory to its default
5475 Project.Exec_Directory := Project.Object_Directory;
5477 if Exec_Dir.Value /= Empty_String then
5478 Get_Name_String (Exec_Dir.Value);
5480 if Name_Len = 0 then
5481 Error_Msg
5482 (Data.Flags,
5484 Exec_Dir.Location, Project);
5486 elsif Setup_Projects
5487 and then No_Sources
5488 and then Project.Extends = No_Project
5489 then
5490 -- Do not create an exec directory for a non extending project
5491 -- with no sources.
5493 Locate_Directory
5494 (Project,
5495 File_Name_Type (Exec_Dir.Value),
5496 Path => Project.Exec_Directory,
5497 Dir_Exists => Dir_Exists,
5498 Data => Data,
5499 Location => Exec_Dir.Location,
5500 Externally_Built => Project.Externally_Built);
5502 else
5503 -- We check that the specified exec directory does exist
5505 Locate_Directory
5506 (Project,
5507 File_Name_Type (Exec_Dir.Value),
5508 Path => Project.Exec_Directory,
5509 Dir_Exists => Dir_Exists,
5510 Data => Data,
5512 Location => Exec_Dir.Location,
5513 Externally_Built => Project.Externally_Built);
5515 if not Dir_Exists then
5516 if Opt.Directories_Must_Exist_In_Projects then
5517 Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value);
5518 Error_Or_Warning
5519 (Data.Flags, Data.Flags.Missing_Source_Files,
5522 else
5523 Project.Exec_Directory := No_Path_Information;
5524 end if;
5525 end if;
5526 end if;
5527 end if;
5529 if Current_Verbosity = High then
5530 if Project.Exec_Directory = No_Path_Information then
5532 else
5533 Debug_Output
5535 Name_Id (Project.Exec_Directory.Display_Name));
5536 end if;
5537 end if;
5539 -- Look for the source directories
5545 if not Source_Files.Default
5546 and then Source_Files.Values = Nil_String
5547 then
5548 Project.Source_Dirs := Nil_String;
5550 if Project.Qualifier = Standard then
5551 Error_Msg
5552 (Data.Flags,
5554 Source_Files.Location, Project);
5555 end if;
5557 elsif Source_Dirs.Default then
5559 -- No Source_Dirs specified: the single source directory is the one
5560 -- containing the project file.
5562 Remove_Source_Dirs := False;
5563 Add_To_Or_Remove_From_Source_Dirs
5564 (Path => (Name => Project.Directory.Name,
5565 Display_Name => Project.Directory.Display_Name),
5566 Rank => 1);
5568 else
5569 Remove_Source_Dirs := False;
5570 Find_Source_Dirs
5571 (Project => Project,
5572 Data => Data,
5573 Patterns => Source_Dirs.Values,
5574 Ignore => Ignore_Source_Sub_Dirs.Values,
5575 Search_For => Search_Directories,
5576 Resolve_Links => Opt.Follow_Links_For_Dirs);
5578 if Project.Source_Dirs = Nil_String
5579 and then Project.Qualifier = Standard
5580 then
5581 Error_Msg
5582 (Data.Flags,
5584 Source_Dirs.Location, Project);
5585 end if;
5586 end if;
5588 if not Excluded_Source_Dirs.Default
5589 and then Excluded_Source_Dirs.Values /= Nil_String
5590 then
5591 Remove_Source_Dirs := True;
5592 Find_Source_Dirs
5593 (Project => Project,
5594 Data => Data,
5595 Patterns => Excluded_Source_Dirs.Values,
5596 Ignore => Nil_String,
5597 Search_For => Search_Directories,
5598 Resolve_Links => Opt.Follow_Links_For_Dirs);
5599 end if;
5603 declare
5604 Current : String_List_Id := Project.Source_Dirs;
5605 Element : String_Element;
5607 begin
5608 while Current /= Nil_String loop
5609 Element := Shared.String_Elements.Table (Current);
5610 if Element.Value /= No_Name then
5611 Element.Value :=
5612 Name_Id (Canonical_Case_File_Name (Element.Value));
5613 Shared.String_Elements.Table (Current) := Element;
5614 end if;
5616 Current := Element.Next;
5617 end loop;
5618 end;
5619 end Get_Directories;
5621 ---------------
5622 -- Get_Mains --
5623 ---------------
5625 procedure Get_Mains
5626 (Project : Project_Id;
5627 Data : in out Tree_Processing_Data)
5628 is
5629 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
5631 Mains : constant Variable_Value :=
5632 Prj.Util.Value_Of
5633 (Name_Main, Project.Decl.Attributes, Shared);
5634 List : String_List_Id;
5635 Elem : String_Element;
5637 begin
5638 Project.Mains := Mains.Values;
5640 -- If no Mains were specified, and if we are an extending project,
5641 -- inherit the Mains from the project we are extending.
5643 if Mains.Default then
5644 if not Project.Library and then Project.Extends /= No_Project then
5645 Project.Mains := Project.Extends.Mains;
5646 end if;
5648 -- In a library project file, Main cannot be specified
5650 elsif Project.Library then
5651 Error_Msg
5652 (Data.Flags,
5654 Mains.Location, Project);
5656 else
5657 List := Mains.Values;
5658 while List /= Nil_String loop
5659 Elem := Shared.String_Elements.Table (List);
5661 if Length_Of_Name (Elem.Value) = 0 then
5662 Error_Msg
5663 (Data.Flags,
5665 Elem.Location, Project);
5666 exit;
5667 end if;
5669 List := Elem.Next;
5670 end loop;
5671 end if;
5672 end Get_Mains;
5674 ---------------------------
5675 -- Get_Sources_From_File --
5676 ---------------------------
5678 procedure Get_Sources_From_File
5679 (Path : String;
5680 Location : Source_Ptr;
5681 Project : in out Project_Processing_Data;
5682 Data : in out Tree_Processing_Data)
5683 is
5684 File : Prj.Util.Text_File;
5685 Line : String (1 .. 250);
5686 Last : Natural;
5687 Source_Name : File_Name_Type;
5688 Name_Loc : Name_Location;
5690 begin
5691 if Current_Verbosity = High then
5693 end if;
5695 -- Open the file
5697 Prj.Util.Open (File, Path);
5699 if not Prj.Util.Is_Valid (File) then
5700 Error_Msg
5701 (Data.Flags, "file does not exist", Location, Project.Project);
5703 else
5704 -- Read the lines one by one
5706 while not Prj.Util.End_Of_File (File) loop
5707 Prj.Util.Get_Line (File, Line, Last);
5709 -- A non empty, non comment line should contain a file name
5711 if Last /= 0
5712 and then (Last = 1 or else Line (1 .. 2) /= "--")
5713 then
5714 Name_Len := Last;
5715 Name_Buffer (1 .. Name_Len) := Line (1 .. Last);
5716 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
5717 Source_Name := Name_Find;
5719 -- Check that there is no directory information
5721 for J in 1 .. Last loop
5723 Error_Msg_File_1 := Source_Name;
5724 Error_Msg
5725 (Data.Flags,
5726 "file name cannot include directory information ({)",
5727 Location, Project.Project);
5728 exit;
5729 end if;
5730 end loop;
5732 Name_Loc := Source_Names_Htable.Get
5733 (Project.Source_Names, Source_Name);
5735 if Name_Loc = No_Name_Location then
5736 Name_Loc :=
5737 (Name => Source_Name,
5738 Location => Location,
5739 Source => No_Source,
5740 Listed => True,
5741 Found => False);
5743 else
5744 Name_Loc.Listed := True;
5745 end if;
5747 Source_Names_Htable.Set
5748 (Project.Source_Names, Source_Name, Name_Loc);
5749 end if;
5750 end loop;
5752 Prj.Util.Close (File);
5754 end if;
5755 end Get_Sources_From_File;
5757 ------------------
5758 -- No_Space_Img --
5759 ------------------
5761 function No_Space_Img (N : Natural) return String is
5762 Image : constant String := N'Img;
5763 begin
5764 return Image (2 .. Image'Last);
5765 end No_Space_Img;
5767 -----------------------
5768 -- Compute_Unit_Name --
5769 -----------------------
5771 procedure Compute_Unit_Name
5772 (File_Name : File_Name_Type;
5773 Naming : Lang_Naming_Data;
5774 Kind : out Source_Kind;
5775 Unit : out Name_Id;
5776 Project : Project_Processing_Data)
5777 is
5778 Filename : constant String := Get_Name_String (File_Name);
5779 Last : Integer := Filename'Last;
5780 Sep_Len : Integer;
5781 Body_Len : Integer;
5782 Spec_Len : Integer;
5784 Unit_Except : Unit_Exception;
5785 Masked : Boolean := False;
5787 begin
5788 Unit := No_Name;
5789 Kind := Spec;
5791 if Naming.Separate_Suffix = No_File
5792 or else Naming.Body_Suffix = No_File
5793 or else Naming.Spec_Suffix = No_File
5794 then
5795 return;
5796 end if;
5798 if Naming.Dot_Replacement = No_File then
5799 Debug_Output ("no dot_replacement specified");
5800 return;
5801 end if;
5803 Sep_Len := Integer (Length_Of_Name (Naming.Separate_Suffix));
5804 Spec_Len := Integer (Length_Of_Name (Naming.Spec_Suffix));
5805 Body_Len := Integer (Length_Of_Name (Naming.Body_Suffix));
5807 -- Choose the longest suffix that matches. If there are several matches,
5808 -- give priority to specs, then bodies, then separates.
5810 if Naming.Separate_Suffix /= Naming.Body_Suffix
5811 and then Suffix_Matches (Filename, Naming.Separate_Suffix)
5812 then
5813 Last := Filename'Last - Sep_Len;
5814 Kind := Sep;
5815 end if;
5817 if Filename'Last - Body_Len <= Last
5818 and then Suffix_Matches (Filename, Naming.Body_Suffix)
5819 then
5820 Last := Natural'Min (Last, Filename'Last - Body_Len);
5821 Kind := Impl;
5822 end if;
5824 if Filename'Last - Spec_Len <= Last
5825 and then Suffix_Matches (Filename, Naming.Spec_Suffix)
5826 then
5827 Last := Natural'Min (Last, Filename'Last - Spec_Len);
5828 Kind := Spec;
5829 end if;
5831 if Last = Filename'Last then
5832 Debug_Output ("no matching suffix");
5833 return;
5834 end if;
5836 -- Check that the casing matches
5838 if File_Names_Case_Sensitive then
5839 case Naming.Casing is
5840 when All_Lower_Case =>
5841 for J in Filename'First .. Last loop
5842 if Is_Letter (Filename (J))
5843 and then not Is_Lower (Filename (J))
5844 then
5845 Debug_Output ("invalid casing");
5846 return;
5847 end if;
5848 end loop;
5850 when All_Upper_Case =>
5851 for J in Filename'First .. Last loop
5852 if Is_Letter (Filename (J))
5853 and then not Is_Upper (Filename (J))
5854 then
5855 Debug_Output ("invalid casing");
5856 return;
5857 end if;
5858 end loop;
5860 when Mixed_Case | Unknown =>
5861 null;
5862 end case;
5863 end if;
5865 -- If Dot_Replacement is not a single dot, then there should not
5866 -- be any dot in the name.
5868 declare
5869 Dot_Repl : constant String :=
5870 Get_Name_String (Naming.Dot_Replacement);
5872 begin
5873 if Dot_Repl /= "." then
5874 for Index in Filename'First .. Last loop
5876 Debug_Output ("invalid name, contains dot");
5877 return;
5878 end if;
5879 end loop;
5881 Replace_Into_Name_Buffer
5884 else
5885 Name_Len := Last - Filename'First + 1;
5886 Name_Buffer (1 .. Name_Len) := Filename (Filename'First .. Last);
5887 Fixed.Translate
5888 (Source => Name_Buffer (1 .. Name_Len),
5889 Mapping => Lower_Case_Map);
5890 end if;
5891 end;
5893 -- In the standard GNAT naming scheme, check for special cases: children
5894 -- or separates of A, G, I or S, and run time sources.
5896 if Is_Standard_GNAT_Naming (Naming)
5897 and then Name_Len >= 3
5898 then
5899 declare
5900 S1 : constant Character := Name_Buffer (1);
5901 S2 : constant Character := Name_Buffer (2);
5902 S3 : constant Character := Name_Buffer (3);
5904 begin
5909 then
5910 -- Children or separates of packages A, G, I or S. These names
5911 -- are x__ ... or x~... (where x is a, g, i, or s). Both
5912 -- versions (x__... and x~...) are allowed in all platforms,
5913 -- because it is not possible to know the platform before
5914 -- processing of the project files.
5918 Name_Buffer (3 .. Name_Len - 1) :=
5919 Name_Buffer (4 .. Name_Len);
5920 Name_Len := Name_Len - 1;
5927 -- If it is potentially a run time source
5929 null;
5930 end if;
5931 end if;
5932 end;
5933 end if;
5935 -- Name_Buffer contains the name of the unit in lower-cases. Check
5936 -- that this is a valid unit name
5938 Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit);
5940 -- If there is a naming exception for the same unit, the file is not
5941 -- a source for the unit.
5943 if Unit /= No_Name then
5944 Unit_Except :=
5945 Unit_Exceptions_Htable.Get (Project.Unit_Exceptions, Unit);
5947 if Kind = Spec then
5948 Masked := Unit_Except.Spec /= No_File
5949 and then
5950 Unit_Except.Spec /= File_Name;
5951 else
5952 Masked := Unit_Except.Impl /= No_File
5953 and then
5954 Unit_Except.Impl /= File_Name;
5955 end if;
5957 if Masked then
5958 if Current_Verbosity = High then
5959 Debug_Indent;
5960 Write_Str (" """ & Filename & """ contains the ");
5962 if Kind = Spec then
5963 Write_Str ("spec of a unit found in """);
5964 Write_Str (Get_Name_String (Unit_Except.Spec));
5965 else
5966 Write_Str ("body of a unit found in """);
5967 Write_Str (Get_Name_String (Unit_Except.Impl));
5968 end if;
5970 Write_Line (""" (ignored)");
5971 end if;
5973 Unit := No_Name;
5974 end if;
5975 end if;
5977 if Unit /= No_Name
5978 and then Current_Verbosity = High
5979 then
5980 case Kind is
5981 when Spec => Debug_Output ("spec of", Unit);
5982 when Impl => Debug_Output ("body of", Unit);
5983 when Sep => Debug_Output ("sep of", Unit);
5984 end case;
5985 end if;
5986 end Compute_Unit_Name;
5988 --------------------------
5989 -- Check_Illegal_Suffix --
5990 --------------------------
5992 procedure Check_Illegal_Suffix
5993 (Project : Project_Id;
5994 Suffix : File_Name_Type;
5995 Dot_Replacement : File_Name_Type;
5996 Attribute_Name : String;
5997 Location : Source_Ptr;
5998 Data : in out Tree_Processing_Data)
5999 is
6000 Suffix_Str : constant String := Get_Name_String (Suffix);
6002 begin
6003 if Suffix_Str'Length = 0 then
6005 -- Always valid
6007 return;
6009 elsif Index (Suffix_Str, ".") = 0 then
6010 Err_Vars.Error_Msg_File_1 := Suffix;
6011 Error_Msg
6012 (Data.Flags,
6013 "{ is illegal for " & Attribute_Name & ": must have a dot",
6014 Location, Project);
6015 return;
6016 end if;
6018 -- Case of dot replacement is a single dot, and first character of
6019 -- suffix is also a dot.
6021 if Dot_Replacement /= No_File
6022 and then Get_Name_String (Dot_Replacement) = "."
6024 then
6025 for Index in Suffix_Str'First + 1 .. Suffix_Str'Last loop
6027 -- If there are multiple dots in the name
6031 -- It is illegal to have a letter following the initial dot
6033 if Is_Letter (Suffix_Str (Suffix_Str'First + 1)) then
6034 Err_Vars.Error_Msg_File_1 := Suffix;
6035 Error_Msg
6036 (Data.Flags,
6037 "{ is illegal for " & Attribute_Name
6038 & ": ambiguous prefix when Dot_Replacement is a dot",
6039 Location, Project);
6040 end if;
6041 return;
6042 end if;
6043 end loop;
6044 end if;
6045 end Check_Illegal_Suffix;
6047 ----------------------
6048 -- Locate_Directory --
6049 ----------------------
6051 procedure Locate_Directory
6052 (Project : Project_Id;
6053 Name : File_Name_Type;
6054 Path : out Path_Information;
6055 Dir_Exists : out Boolean;
6056 Data : in out Tree_Processing_Data;
6057 Create : String := "";
6058 Location : Source_Ptr := No_Location;
6059 Must_Exist : Boolean := True;
6060 Externally_Built : Boolean := False)
6061 is
6062 Parent : constant Path_Name_Type :=
6063 Project.Directory.Display_Name;
6064 The_Parent : constant String :=
6065 Get_Name_String (Parent);
6066 The_Parent_Last : constant Natural :=
6067 Compute_Directory_Last (The_Parent);
6068 Full_Name : File_Name_Type;
6069 The_Name : File_Name_Type;
6071 begin
6072 Get_Name_String (Name);
6074 -- Add Subdirs.all if it is a directory that may be created and
6075 -- Subdirs is not null;
6077 if Create /= "" and then Subdirs /= null then
6078 if Name_Buffer (Name_Len) /= Directory_Separator then
6079 Add_Char_To_Name_Buffer (Directory_Separator);
6080 end if;
6082 Add_Str_To_Name_Buffer (Subdirs.all);
6083 end if;
6087 for J in 1 .. Name_Len loop
6089 Name_Buffer (J) := Directory_Separator;
6090 end if;
6091 end loop;
6093 The_Name := Name_Find;
6095 if Current_Verbosity = High then
6096 Debug_Indent;
6097 Write_Str ("Locate_Directory (""");
6098 Write_Str (Get_Name_String (The_Name));
6099 Write_Str (""", in """);
6100 Write_Str (The_Parent);
6101 Write_Line (""")");
6102 end if;
6104 Path := No_Path_Information;
6105 Dir_Exists := False;
6107 if Is_Absolute_Path (Get_Name_String (The_Name)) then
6108 Full_Name := The_Name;
6110 else
6111 Name_Len := 0;
6112 Add_Str_To_Name_Buffer
6113 (The_Parent (The_Parent'First .. The_Parent_Last));
6114 Add_Str_To_Name_Buffer (Get_Name_String (The_Name));
6115 Full_Name := Name_Find;
6116 end if;
6118 declare
6119 Full_Path_Name : String_Access :=
6122 begin
6125 then
6128 -- If project is externally built, do not create a subdir,
6129 -- use the specified directory, without the subdir.
6135 else
6137 Add_Str_To_Name_Buffer
6144 else
6145 begin
6146 Create_Path (Full_Path_Name.all);
6148 if not Quiet_Output then
6149 Write_Str (Create);
6150 Write_Str (" directory """);
6151 Write_Str (Full_Path_Name.all);
6152 Write_Str (""" created for project ");
6153 Write_Line (Get_Name_String (Project.Name));
6154 end if;
6156 exception
6157 when Use_Error =>
6158 Error_Msg
6159 (Data.Flags,
6160 "could not create " & Create &
6161 " directory " & Full_Path_Name.all,
6162 Location, Project);
6163 end;
6164 end if;
6165 end if;
6166 end if;
6168 Dir_Exists := Is_Directory (Full_Path_Name.all);
6170 if not Must_Exist or else Dir_Exists then
6171 declare
6172 Normed : constant String :=
6173 Normalize_Pathname
6174 (Full_Path_Name.all,
6175 Directory =>
6176 The_Parent (The_Parent'First .. The_Parent_Last),
6177 Resolve_Links => False,
6178 Case_Sensitive => True);
6180 Canonical_Path : constant String :=
6181 Normalize_Pathname
6182 (Normed,
6183 Directory =>
6184 The_Parent
6185 (The_Parent'First .. The_Parent_Last),
6186 Resolve_Links =>
6187 Opt.Follow_Links_For_Dirs,
6188 Case_Sensitive => False);
6190 begin
6191 Name_Len := Normed'Length;
6192 Name_Buffer (1 .. Name_Len) := Normed;
6194 -- Directories should always end with a directory separator
6196 if Name_Buffer (Name_Len) /= Directory_Separator then
6197 Add_Char_To_Name_Buffer (Directory_Separator);
6198 end if;
6200 Path.Display_Name := Name_Find;
6202 Name_Len := Canonical_Path'Length;
6203 Name_Buffer (1 .. Name_Len) := Canonical_Path;
6205 if Name_Buffer (Name_Len) /= Directory_Separator then
6206 Add_Char_To_Name_Buffer (Directory_Separator);
6207 end if;
6209 Path.Name := Name_Find;
6210 end;
6211 end if;
6213 Free (Full_Path_Name);
6214 end;
6215 end Locate_Directory;
6217 ---------------------------
6218 -- Find_Excluded_Sources --
6219 ---------------------------
6221 procedure Find_Excluded_Sources
6222 (Project : in out Project_Processing_Data;
6223 Data : in out Tree_Processing_Data)
6224 is
6225 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
6227 Excluded_Source_List_File : constant Variable_Value :=
6228 Util.Value_Of
6229 (Name_Excluded_Source_List_File,
6230 Project.Project.Decl.Attributes,
6231 Shared);
6232 Excluded_Sources : Variable_Value := Util.Value_Of
6233 (Name_Excluded_Source_Files,
6234 Project.Project.Decl.Attributes,
6235 Shared);
6237 Current : String_List_Id;
6238 Element : String_Element;
6239 Location : Source_Ptr;
6240 Name : File_Name_Type;
6241 File : Prj.Util.Text_File;
6242 Line : String (1 .. 300);
6243 Last : Natural;
6244 Locally_Removed : Boolean := False;
6246 begin
6247 -- If Excluded_Source_Files is not declared, check Locally_Removed_Files
6249 if Excluded_Sources.Default then
6250 Locally_Removed := True;
6251 Excluded_Sources :=
6252 Util.Value_Of
6253 (Name_Locally_Removed_Files,
6254 Project.Project.Decl.Attributes, Shared);
6255 end if;
6257 -- If there are excluded sources, put them in the table
6259 if not Excluded_Sources.Default then
6260 if not Excluded_Source_List_File.Default then
6261 if Locally_Removed then
6262 Error_Msg
6263 (Data.Flags,
6264 "?both attributes Locally_Removed_Files and " &
6265 "Excluded_Source_List_File are present",
6266 Excluded_Source_List_File.Location, Project.Project);
6267 else
6268 Error_Msg
6269 (Data.Flags,
6270 "?both attributes Excluded_Source_Files and " &
6271 "Excluded_Source_List_File are present",
6272 Excluded_Source_List_File.Location, Project.Project);
6273 end if;
6274 end if;
6276 Current := Excluded_Sources.Values;
6277 while Current /= Nil_String loop
6278 Element := Shared.String_Elements.Table (Current);
6279 Name := Canonical_Case_File_Name (Element.Value);
6281 -- If the element has no location, then use the location of
6282 -- Excluded_Sources to report possible errors.
6284 if Element.Location = No_Location then
6285 Location := Excluded_Sources.Location;
6286 else
6287 Location := Element.Location;
6288 end if;
6290 Excluded_Sources_Htable.Set
6291 (Project.Excluded, Name,
6292 (Name, No_File, 0, False, Location));
6293 Current := Element.Next;
6294 end loop;
6296 elsif not Excluded_Source_List_File.Default then
6297 Location := Excluded_Source_List_File.Location;
6299 declare
6300 Source_File_Name : constant File_Name_Type :=
6301 File_Name_Type
6302 (Excluded_Source_List_File.Value);
6303 Source_File_Line : Natural := 0;
6305 Source_File_Path_Name : constant String :=
6306 Path_Name_Of
6307 (Source_File_Name,
6308 Project.Project.Directory.Name);
6310 begin
6311 if Source_File_Path_Name'Length = 0 then
6312 Err_Vars.Error_Msg_File_1 :=
6313 File_Name_Type (Excluded_Source_List_File.Value);
6314 Error_Msg
6315 (Data.Flags,
6316 "file with excluded sources { does not exist",
6317 Excluded_Source_List_File.Location, Project.Project);
6319 else
6320 -- Open the file
6322 Prj.Util.Open (File, Source_File_Path_Name);
6324 if not Prj.Util.Is_Valid (File) then
6325 Error_Msg
6326 (Data.Flags, "file does not exist",
6327 Location, Project.Project);
6328 else
6329 -- Read the lines one by one
6331 while not Prj.Util.End_Of_File (File) loop
6332 Prj.Util.Get_Line (File, Line, Last);
6333 Source_File_Line := Source_File_Line + 1;
6335 -- Non empty, non comment line should contain a file name
6337 if Last /= 0
6338 and then (Last = 1 or else Line (1 .. 2) /= "--")
6339 then
6340 Name_Len := Last;
6341 Name_Buffer (1 .. Name_Len) := Line (1 .. Last);
6342 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
6343 Name := Name_Find;
6345 -- Check that there is no directory information
6347 for J in 1 .. Last loop
6349 or else Line (J) = Directory_Separator
6350 then
6351 Error_Msg_File_1 := Name;
6352 Error_Msg
6353 (Data.Flags,
6354 "file name cannot include " &
6355 "directory information ({)",
6356 Location, Project.Project);
6357 exit;
6358 end if;
6359 end loop;
6361 Excluded_Sources_Htable.Set
6362 (Project.Excluded,
6363 Name,
6364 (Name, Source_File_Name, Source_File_Line,
6365 False, Location));
6366 end if;
6367 end loop;
6369 Prj.Util.Close (File);
6370 end if;
6371 end if;
6372 end;
6373 end if;
6374 end Find_Excluded_Sources;
6376 ------------------
6377 -- Find_Sources --
6378 ------------------
6380 procedure Find_Sources
6381 (Project : in out Project_Processing_Data;
6382 Data : in out Tree_Processing_Data)
6383 is
6384 Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
6386 Sources : constant Variable_Value :=
6387 Util.Value_Of
6388 (Name_Source_Files,
6389 Project.Project.Decl.Attributes,
6390 Shared);
6392 Source_List_File : constant Variable_Value :=
6393 Util.Value_Of
6394 (Name_Source_List_File,
6395 Project.Project.Decl.Attributes,
6396 Shared);
6398 Name_Loc : Name_Location;
6399 Has_Explicit_Sources : Boolean;
6401 begin
6402 pragma Assert (Sources.Kind = List, "Source_Files is not a list");
6403 pragma Assert
6404 (Source_List_File.Kind = Single,
6405 "Source_List_File is not a single string");
6407 Project.Source_List_File_Location := Source_List_File.Location;
6409 -- If the user has specified a Source_Files attribute
6411 if not Sources.Default then
6412 if not Source_List_File.Default then
6413 Error_Msg
6414 (Data.Flags,
6415 "?both attributes source_files and " &
6416 "source_list_file are present",
6417 Source_List_File.Location, Project.Project);
6418 end if;
6420 -- Sources is a list of file names
6422 declare
6423 Current : String_List_Id := Sources.Values;
6424 Element : String_Element;
6425 Location : Source_Ptr;
6426 Name : File_Name_Type;
6428 begin
6429 if Current = Nil_String then
6430 Project.Project.Languages := No_Language_Index;
6432 -- This project contains no source. For projects that don't
6433 -- extend other projects, this also means that there is no
6434 -- need for an object directory, if not specified.
6436 if Project.Project.Extends = No_Project
6437 and then
6438 Project.Project.Object_Directory = Project.Project.Directory
6439 and then
6440 not (Project.Project.Qualifier = Aggregate_Library)
6441 then
6442 Project.Project.Object_Directory := No_Path_Information;
6443 end if;
6444 end if;
6446 while Current /= Nil_String loop
6447 Element := Shared.String_Elements.Table (Current);
6448 Name := Canonical_Case_File_Name (Element.Value);
6449 Get_Name_String (Element.Value);
6451 -- If the element has no location, then use the location of
6452 -- Sources to report possible errors.
6454 if Element.Location = No_Location then
6455 Location := Sources.Location;
6456 else
6457 Location := Element.Location;
6458 end if;
6460 -- Check that there is no directory information
6462 for J in 1 .. Name_Len loop
6464 or else Name_Buffer (J) = Directory_Separator
6465 then
6466 Error_Msg_File_1 := Name;
6467 Error_Msg
6468 (Data.Flags,
6469 "file name cannot include directory " &
6470 "information ({)",
6471 Location, Project.Project);
6472 exit;
6473 end if;
6474 end loop;
6476 -- Check whether the file is already there: the same file name
6477 -- may be in the list. If the source is missing, the error will
6478 -- be on the first mention of the source file name.
6480 Name_Loc := Source_Names_Htable.Get
6481 (Project.Source_Names, Name);
6483 if Name_Loc = No_Name_Location then
6484 Name_Loc :=
6485 (Name => Name,
6486 Location => Location,
6487 Source => No_Source,
6488 Listed => True,
6489 Found => False);
6491 else
6492 Name_Loc.Listed := True;
6493 end if;
6495 Source_Names_Htable.Set
6496 (Project.Source_Names, Name, Name_Loc);
6498 Current := Element.Next;
6499 end loop;
6501 Has_Explicit_Sources := True;
6502 end;
6504 -- If we have no Source_Files attribute, check the Source_List_File
6505 -- attribute.
6507 elsif not Source_List_File.Default then
6509 -- Source_List_File is the name of the file that contains the source
6510 -- file names.
6512 declare
6513 Source_File_Path_Name : constant String :=
6514 Path_Name_Of
6515 (File_Name_Type
6516 (Source_List_File.Value),
6517 Project.Project.
6518 Directory.Display_Name);
6520 begin
6521 Has_Explicit_Sources := True;
6523 if Source_File_Path_Name'Length = 0 then
6524 Err_Vars.Error_Msg_File_1 :=
6525 File_Name_Type (Source_List_File.Value);
6526 Error_Msg
6527 (Data.Flags,
6528 "file with sources { does not exist",
6529 Source_List_File.Location, Project.Project);
6531 else
6532 Get_Sources_From_File
6533 (Source_File_Path_Name, Source_List_File.Location,
6534 Project, Data);
6535 end if;
6536 end;
6538 else
6539 -- Neither Source_Files nor Source_List_File has been specified. Find
6540 -- all the files that satisfy the naming scheme in all the source
6541 -- directories.
6543 Has_Explicit_Sources := False;
6544 end if;
6546 -- Remove any exception that is not in the specified list of sources
6548 if Has_Explicit_Sources then
6549 declare
6550 Source : Source_Id;
6551 Iter : Source_Iterator;
6552 NL : Name_Location;
6553 Again : Boolean;
6554 begin
6555 Iter_Loop :
6556 loop
6557 Again := False;
6558 Iter := For_Each_Source (Data.Tree, Project.Project);
6560 Source_Loop :
6561 loop
6562 Source := Prj.Element (Iter);
6563 exit Source_Loop when Source = No_Source;
6565 if Source.Naming_Exception /= No then
6566 NL := Source_Names_Htable.Get
6567 (Project.Source_Names, Source.File);
6569 if NL /= No_Name_Location and then not NL.Listed then
6570 -- Remove the exception
6571 Source_Names_Htable.Set
6572 (Project.Source_Names,
6573 Source.File,
6574 No_Name_Location);
6575 Remove_Source (Data.Tree, Source, No_Source);
6577 if Source.Naming_Exception = Yes then
6578 Error_Msg_Name_1 := Name_Id (Source.File);
6579 Error_Msg
6580 (Data.Flags,
6581 "? unknown source file %%",
6582 NL.Location,
6583 Project.Project);
6584 end if;
6586 Again := True;
6587 exit Source_Loop;
6588 end if;
6589 end if;
6591 Next (Iter);
6592 end loop Source_Loop;
6594 exit Iter_Loop when not Again;
6595 end loop Iter_Loop;
6596 end;
6597 end if;
6599 Search_Directories
6600 (Project,
6601 Data => Data,
6602 For_All_Sources => Sources.Default and then Source_List_File.Default);
6604 -- Check if all exceptions have been found
6606 declare
6607 Source : Source_Id;
6608 Iter : Source_Iterator;
6609 Found : Boolean := False;
6611 begin
6612 Iter := For_Each_Source (Data.Tree, Project.Project);
6613 loop
6614 Source := Prj.Element (Iter);
6615 exit when Source = No_Source;
6617 -- If the full source path is unknown for this source_id, there
6618 -- could be several reasons:
6619 -- * we simply did not find the file itself, this is an error
6620 -- * we have a multi-unit source file. Another Source_Id from
6621 -- the same file has received the full path, so we need to
6622 -- propagate it.
6624 if Source.Path = No_Path_Information then
6625 if Source.Naming_Exception = Yes then
6626 if Source.Unit /= No_Unit_Index then
6627 Found := False;
6629 if Source.Index /= 0 then -- Only multi-unit files
6630 declare
6631 S : Source_Id :=
6632 Source_Files_Htable.Get
6633 (Data.Tree.Source_Files_HT, Source.File);
6635 begin
6636 while S /= null loop
6637 if S.Path /= No_Path_Information then
6638 Source.Path := S.Path;
6639 Found := True;
6641 if Current_Verbosity = High then
6642 Debug_Output
6643 ("setting full path for "
6644 & Get_Name_String (Source.File)
6645 & " at" & Source.Index'Img
6646 & " to "
6647 & Get_Name_String (Source.Path.Name));
6648 end if;
6650 exit;
6651 end if;
6653 S := S.Next_With_File_Name;
6654 end loop;
6655 end;
6656 end if;
6658 if not Found then
6659 Error_Msg_Name_1 := Name_Id (Source.Display_File);
6660 Error_Msg_Name_2 := Source.Unit.Name;
6661 Error_Or_Warning
6662 (Data.Flags, Data.Flags.Missing_Source_Files,
6663 "source file %% for unit %% not found",
6664 No_Location, Project.Project);
6665 end if;
6666 end if;
6668 if Source.Path = No_Path_Information then
6669 Remove_Source (Data.Tree, Source, No_Source);
6670 end if;
6672 elsif Source.Naming_Exception = Inherited then
6673 Remove_Source (Data.Tree, Source, No_Source);
6674 end if;
6675 end if;
6677 Next (Iter);
6678 end loop;
6679 end;
6681 -- It is an error if a source file name in a source list or in a source
6682 -- list file is not found.
6684 if Has_Explicit_Sources then
6685 declare
6686 NL : Name_Location;
6687 First_Error : Boolean;
6689 begin
6690 NL := Source_Names_Htable.Get_First (Project.Source_Names);
6691 First_Error := True;
6692 while NL /= No_Name_Location loop
6693 if not NL.Found then
6694 Err_Vars.Error_Msg_File_1 := NL.Name;
6695 if First_Error then
6696 Error_Or_Warning
6697 (Data.Flags, Data.Flags.Missing_Source_Files,
6698 "source file { not found",
6699 NL.Location, Project.Project);
6700 First_Error := False;
6701 else
6702 Error_Or_Warning
6703 (Data.Flags, Data.Flags.Missing_Source_Files,
6705 NL.Location, Project.Project);
6706 end if;
6707 end if;
6709 NL := Source_Names_Htable.Get_Next (Project.Source_Names);
6710 end loop;
6711 end;
6712 end if;
6713 end Find_Sources;
6715 ----------------
6716 -- Initialize --
6717 ----------------
6719 procedure Initialize
6720 (Data : out Tree_Processing_Data;
6721 Tree : Project_Tree_Ref;
6722 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
6723 Flags : Prj.Processing_Flags)
6724 is
6725 begin
6726 Data.Tree := Tree;
6727 Data.Node_Tree := Node_Tree;
6728 Data.Flags := Flags;
6729 end Initialize;
6731 ----------
6732 -- Free --
6733 ----------
6735 procedure Free (Data : in out Tree_Processing_Data) is
6736 pragma Unreferenced (Data);
6737 begin
6738 null;
6739 end Free;
6741 ----------------
6742 -- Initialize --
6743 ----------------
6745 procedure Initialize
6746 (Data : in out Project_Processing_Data;
6747 Project : Project_Id)
6748 is
6749 begin
6750 Data.Project := Project;
6751 end Initialize;
6753 ----------
6754 -- Free --
6755 ----------
6757 procedure Free (Data : in out Project_Processing_Data) is
6758 begin
6759 Source_Names_Htable.Reset (Data.Source_Names);
6760 Unit_Exceptions_Htable.Reset (Data.Unit_Exceptions);
6761 Excluded_Sources_Htable.Reset (Data.Excluded);
6762 end Free;
6764 -------------------------------
6765 -- Check_File_Naming_Schemes --
6766 -------------------------------
6768 procedure Check_File_Naming_Schemes
6769 (Project : Project_Processing_Data;
6770 File_Name : File_Name_Type;
6771 Alternate_Languages : out Language_List;
6772 Language : out Language_Ptr;
6773 Display_Language_Name : out Name_Id;
6774 Unit : out Name_Id;
6775 Lang_Kind : out Language_Kind;
6776 Kind : out Source_Kind)
6777 is
6778 Filename : constant String := Get_Name_String (File_Name);
6779 Config : Language_Config;
6780 Tmp_Lang : Language_Ptr;
6782 Header_File : Boolean := False;
6783 -- True if we found at least one language for which the file is a header
6784 -- In such a case, we search for all possible languages where this is
6785 -- also a header (C and C++ for instance), since the file might be used
6786 -- for several such languages.
6788 procedure Check_File_Based_Lang;
6789 -- Does the naming scheme test for file-based languages. For those,
6790 -- there is no Unit. Just check if the file name has the implementation
6791 -- or, if it is specified, the template suffix of the language.
6792 --
6793 -- Returns True if the file belongs to the current language and we
6794 -- should stop searching for matching languages. Not that a given header
6795 -- file could belong to several languages (C and C++ for instance). Thus
6796 -- if we found a header we'll check whether it matches other languages.
6798 ---------------------------
6799 -- Check_File_Based_Lang --
6800 ---------------------------
6802 procedure Check_File_Based_Lang is
6803 begin
6804 if not Header_File
6805 and then Suffix_Matches (Filename, Config.Naming_Data.Body_Suffix)
6806 then
6807 Unit := No_Name;
6808 Kind := Impl;
6809 Language := Tmp_Lang;
6811 Debug_Output
6812 ("implementation of language ", Display_Language_Name);
6814 elsif Suffix_Matches (Filename, Config.Naming_Data.Spec_Suffix) then
6815 Debug_Output
6816 ("header of language ", Display_Language_Name);
6818 if Header_File then
6819 Alternate_Languages := new Language_List_Element'
6823 else
6832 -- Start of processing for Check_File_Naming_Schemes
6834 begin
6845 Debug_Output
6857 Check_File_Based_Lang;
6862 -- We know it belongs to a least a file_based language, no
6863 -- need to check unit-based ones.
6866 Compute_Unit_Name
6888 -------------------
6889 -- Override_Kind --
6890 -------------------
6893 begin
6894 -- If the file was previously already associated with a unit, change it
6899 then
6900 -- If we had another file referencing the same unit (for instance it
6901 -- was in an extended project), that source file is in fact invisible
6902 -- from now on, and in particular doesn't belong to the same unit.
6903 -- If the source is an inherited naming exception, then it may not
6904 -- really exist: the source potentially replaced is left untouched.
6917 then
6927 else
6933 ----------------
6934 -- Check_File --
6935 ----------------
6937 procedure Check_File
6947 is
6949 Source_Names_Htable.Get
6961 begin
6963 Debug_Increase_Indent
6971 else
6974 -- Check if it is OK to have the same file name in several
6975 -- source directories.
6979 Error_Msg
6985 else
6988 Source_Names_Htable.Set
6994 else
6995 -- Set the full path for the source_id (which might have been
6996 -- created when parsing the naming exceptions, and therefore
6997 -- might not have the full path).
6998 -- We only set this for this source_id, but not for other
6999 -- source_id in the same file (case of multi-unit source files)
7000 -- For the latter, they will be set in Find_Sources when we
7001 -- check that all source_id have known full paths.
7002 -- Doing this later saves one htable lookup per file in the
7003 -- common case where the user is not using multi-unit files.
7007 Source_Paths_Htable.Set
7010 -- Check if this is a subunit
7014 then
7023 -- If this is an inherited naming exception, make sure that
7024 -- the naming exception it replaces is no longer a source.
7027 declare
7031 begin
7059 Units_Htable.Set
7070 Check_File_Naming_Schemes
7082 -- A file name in a list must be a source of a language
7086 then
7088 Error_Msg
7094 else
7095 Add_Source
7109 -- If it is a source specified in a list, update the entry in
7110 -- the Source_Names table.
7114 Source_Names_Htable.Set
7120 Debug_Decrease_Indent;
7123 ---------------------------------
7124 -- Expand_Subdirectory_Pattern --
7125 ---------------------------------
7127 procedure Expand_Subdirectory_Pattern
7134 is
7144 -- Hash table stores recursive source directories, to avoid looking
7145 -- several times, and to avoid cycles that may be introduced by symbolic
7146 -- links.
7149 -- Pattern to use when matching file names
7153 procedure Find_Pattern
7157 -- Find a specific pattern
7159 function Recursive_Find_Dirs
7162 -- Search all the subdirectories (recursively) of Path.
7163 -- Return True if at least one file or directory was processed
7165 function Subdirectory_Matches
7168 -- Called when a matching directory was found. If the user is in fact
7169 -- searching for files, we then search for those files matching the
7170 -- pattern within the directory.
7171 -- Return True if at least one file or directory was processed
7173 --------------------------
7174 -- Subdirectory_Matches --
7175 --------------------------
7177 function Subdirectory_Matches
7180 is
7187 begin
7195 loop
7202 then
7221 -------------------------
7222 -- Recursive_Find_Dirs --
7223 -------------------------
7225 function Recursive_Find_Dirs
7228 is
7235 begin
7248 loop
7253 and then
7255 then
7256 declare
7258 Normalize_Pathname
7266 begin
7269 declare
7273 begin
7277 Get_Name_String
7279 Canonical_Case_File_Name
7296 Success :=
7308 exception
7313 ------------------
7314 -- Find_Pattern --
7315 ------------------
7317 procedure Find_Pattern
7321 is
7331 begin
7334 -- If we are looking for files, find the pattern for the files
7340 loop
7346 Error_Or_Warning
7353 Debug_Indent;
7360 File_Pattern := Compile
7365 -- If we had just "*.gpr", this is equivalent to "./*.gpr"
7372 Recursive :=
7390 Locate_Directory
7400 Error_Or_Warning
7408 -- Links have been resolved if necessary, and Path_Name
7409 -- always ends with a directory separator.
7413 else
7424 Error_Or_Warning
7434 -- Local variables
7440 -- Start of processing for Expand_Subdirectory_Pattern
7442 begin
7453 ------------------------
7454 -- Search_Directories --
7455 ------------------------
7457 procedure Search_Directories
7461 is
7474 begin
7477 -- Loop through subdirectories
7483 begin
7487 -- Use Element.Value in this test, not Display_Value, because we
7488 -- want the symbolic links to be resolved when appropriate.
7491 declare
7500 Get_Name_String
7503 -- Display_Source_Directory is to allow us to open a UTF-8
7504 -- encoded directory on Windows.
7506 begin
7508 Debug_Increase_Indent
7514 -- We look to every entry in the source directory
7518 loop
7522 -- In fast project loading mode (without -eL), the user
7523 -- guarantees that no directory has a name which is a
7524 -- valid source name, so we can avoid doing a system call
7525 -- here. This provides a very significant speed up on
7526 -- slow file systems (remote files for instance).
7529 or else Is_Regular_File
7531 then
7538 else
7539 Canonical_Case_File_Name
7544 declare
7546 Normalize_Pathname
7548 Directory =>
7549 Source_Directory
7551 Dir_Last),
7552 Resolve_Links =>
7558 Excluded_Sources_Htable.Get
7562 begin
7568 else
7569 Canonical_Case_File_Name
7577 Excluded_Sources_Htable.Set
7580 Debug_Output
7584 -- Will mark the file as removed, but we
7585 -- still need to add it to the list: if we
7586 -- don't, the file will not appear in the
7587 -- mapping file and will cause the compiler
7588 -- to fail.
7594 -- Preserve the user's original casing and use of
7595 -- links. The display_value (a directory) already
7596 -- ends with a directory separator by construction,
7597 -- so no need to add one.
7602 Check_File
7614 else
7621 Debug_Decrease_Indent;
7626 exception
7638 ----------------------------
7639 -- Load_Naming_Exceptions --
7640 ----------------------------
7642 procedure Load_Naming_Exceptions
7645 is
7649 begin
7651 loop
7655 -- An excluded file cannot also be an exception file name
7658 No_File_Found
7659 then
7661 Error_Msg
7667 Debug_Output
7671 Source_Names_Htable.Set
7675 (Name => Source.File,
7676 Location => Source.Location,
7677 Source => Source,
7678 Listed => False,
7679 Found => False));
7681 -- If this is an Ada exception, record in table Unit_Exceptions
7683 if Source.Unit /= No_Unit_Index then
7684 declare
7685 Unit_Except : Unit_Exception :=
7686 Unit_Exceptions_Htable.Get
7687 (Project.Unit_Exceptions, Source.Unit.Name);
7689 begin
7690 Unit_Except.Name := Source.Unit.Name;
7692 if Source.Kind = Spec then
7693 Unit_Except.Spec := Source.File;
7694 else
7695 Unit_Except.Impl := Source.File;
7696 end if;
7698 Unit_Exceptions_Htable.Set
7699 (Project.Unit_Exceptions, Source.Unit.Name, Unit_Except);
7700 end;
7701 end if;
7703 Next (Iter);
7704 end loop;
7705 end Load_Naming_Exceptions;
7707 ----------------------
7708 -- Look_For_Sources --
7709 ----------------------
7711 procedure Look_For_Sources
7712 (Project : in out Project_Processing_Data;
7713 Data : in out Tree_Processing_Data)
7714 is
7715 Object_Files : Object_File_Names_Htable.Instance;
7716 Iter : Source_Iterator;
7717 Src : Source_Id;
7719 procedure Check_Object (Src : Source_Id);
7720 -- Check if object file name of Src is already used in the project tree,
7721 -- and report an error if so.
7723 procedure Check_Object_Files;
7724 -- Check that no two sources of this project have the same object file
7726 procedure Mark_Excluded_Sources;
7727 -- Mark as such the sources that are declared as excluded
7729 procedure Check_Missing_Sources;
7730 -- Check whether one of the languages has no sources, and report an
7731 -- error when appropriate
7733 procedure Get_Sources_From_Source_Info;
7734 -- Get the source information from the tables that were created when a
7735 -- source info file was read.
7737 ---------------------------
7738 -- Check_Missing_Sources --
7739 ---------------------------
7741 procedure Check_Missing_Sources is
7742 Extending : constant Boolean :=
7743 Project.Project.Extends /= No_Project;
7744 Language : Language_Ptr;
7745 Source : Source_Id;
7746 Alt_Lang : Language_List;
7747 Continuation : Boolean := False;
7748 Iter : Source_Iterator;
7749 begin
7750 if not Project.Project.Externally_Built
7751 and then not Extending
7752 then
7753 Language := Project.Project.Languages;
7754 while Language /= No_Language_Index loop
7756 -- If there are no sources for this language, check if there
7757 -- are sources for which this is an alternate language.
7759 if Language.First_Source = No_Source
7760 and then (Data.Flags.Require_Sources_Other_Lang
7761 or else Language.Name = Name_Ada)
7762 then
7763 Iter := For_Each_Source (In_Tree => Data.Tree,
7764 Project => Project.Project);
7765 Source_Loop : loop
7766 Source := Element (Iter);
7767 exit Source_Loop when Source = No_Source
7768 or else Source.Language = Language;
7770 Alt_Lang := Source.Alternate_Languages;
7771 while Alt_Lang /= null loop
7772 exit Source_Loop when Alt_Lang.Language = Language;
7773 Alt_Lang := Alt_Lang.Next;
7774 end loop;
7776 Next (Iter);
7777 end loop Source_Loop;
7779 if Source = No_Source then
7780 Report_No_Sources
7781 (Project.Project,
7782 Get_Name_String (Language.Display_Name),
7783 Data,
7784 Project.Source_List_File_Location,
7785 Continuation);
7786 Continuation := True;
7787 end if;
7788 end if;
7790 Language := Language.Next;
7791 end loop;
7792 end if;
7793 end Check_Missing_Sources;
7795 ------------------
7796 -- Check_Object --
7797 ------------------
7799 procedure Check_Object (Src : Source_Id) is
7800 Source : Source_Id;
7802 begin
7803 Source := Object_File_Names_Htable.Get (Object_Files, Src.Object);
7805 -- We cannot just check on "Source /= Src", since we might have
7806 -- two different entries for the same file (and since that's
7807 -- the same file it is expected that it has the same object)
7809 if Source /= No_Source
7810 and then Source.Replaced_By = No_Source
7811 and then Source.Path /= Src.Path
7812 and then Is_Extending (Src.Project, Source.Project)
7813 then
7814 Error_Msg_File_1 := Src.File;
7815 Error_Msg_File_2 := Source.File;
7816 Error_Msg
7817 (Data.Flags,
7818 "{ and { have the same object file name",
7819 No_Location, Project.Project);
7821 else
7822 Object_File_Names_Htable.Set (Object_Files, Src.Object, Src);
7823 end if;
7824 end Check_Object;
7826 ---------------------------
7827 -- Mark_Excluded_Sources --
7828 ---------------------------
7830 procedure Mark_Excluded_Sources is
7831 Source : Source_Id := No_Source;
7832 Excluded : File_Found;
7833 Proj : Project_Id;
7835 begin
7836 -- Minor optimization: if there are no excluded files, no need to
7837 -- traverse the list of sources. We cannot however also check whether
7838 -- the existing exceptions have ".Found" set to True (indicating we
7839 -- found them before) because we need to do some final processing on
7840 -- them in any case.
7842 if Excluded_Sources_Htable.Get_First (Project.Excluded) /=
7843 No_File_Found
7844 then
7845 Proj := Project.Project;
7846 while Proj /= No_Project loop
7847 Iter := For_Each_Source (Data.Tree, Proj);
7848 while Prj.Element (Iter) /= No_Source loop
7849 Source := Prj.Element (Iter);
7850 Excluded := Excluded_Sources_Htable.Get
7851 (Project.Excluded, Source.File);
7853 if Excluded /= No_File_Found then
7854 Source.In_Interfaces := False;
7855 Source.Locally_Removed := True;
7857 if Proj = Project.Project then
7858 Source.Suppressed := True;
7859 end if;
7861 if Current_Verbosity = High then
7862 Debug_Indent;
7863 Write_Str ("removing file ");
7864 Write_Line
7865 (Get_Name_String (Excluded.File)
7866 & " " & Get_Name_String (Source.Project.Name));
7867 end if;
7869 Excluded_Sources_Htable.Remove
7870 (Project.Excluded, Source.File);
7871 end if;
7873 Next (Iter);
7874 end loop;
7876 Proj := Proj.Extends;
7877 end loop;
7878 end if;
7880 -- If we have any excluded element left, that means we did not find
7881 -- the source file
7883 Excluded := Excluded_Sources_Htable.Get_First (Project.Excluded);
7884 while Excluded /= No_File_Found loop
7885 if not Excluded.Found then
7887 -- Check if the file belongs to another imported project to
7888 -- provide a better error message.
7890 Src := Find_Source
7891 (In_Tree => Data.Tree,
7892 Project => Project.Project,
7893 In_Imported_Only => True,
7894 Base_Name => Excluded.File);
7896 Err_Vars.Error_Msg_File_1 := Excluded.File;
7898 if Src = No_Source then
7899 if Excluded.Excl_File = No_File then
7900 Error_Msg
7901 (Data.Flags,
7902 "unknown file {", Excluded.Location, Project.Project);
7904 else
7905 Error_Msg
7906 (Data.Flags,
7907 "in " &
7908 Get_Name_String (Excluded.Excl_File) & ":" &
7909 No_Space_Img (Excluded.Excl_Line) &
7910 ": unknown file {", Excluded.Location, Project.Project);
7911 end if;
7913 else
7914 if Excluded.Excl_File = No_File then
7915 Error_Msg
7916 (Data.Flags,
7917 "cannot remove a source from an imported project: {",
7918 Excluded.Location, Project.Project);
7920 else
7921 Error_Msg
7922 (Data.Flags,
7923 "in " &
7924 Get_Name_String (Excluded.Excl_File) & ":" &
7925 No_Space_Img (Excluded.Excl_Line) &
7926 ": cannot remove a source from an imported project: {",
7927 Excluded.Location, Project.Project);
7928 end if;
7929 end if;
7930 end if;
7932 Excluded := Excluded_Sources_Htable.Get_Next (Project.Excluded);
7933 end loop;
7934 end Mark_Excluded_Sources;
7936 ------------------------
7937 -- Check_Object_Files --
7938 ------------------------
7940 procedure Check_Object_Files is
7941 Iter : Source_Iterator;
7942 Src_Id : Source_Id;
7943 Src_Ind : Source_File_Index;
7945 begin
7946 Iter := For_Each_Source (Data.Tree);
7947 loop
7948 Src_Id := Prj.Element (Iter);
7949 exit when Src_Id = No_Source;
7951 if Is_Compilable (Src_Id)
7952 and then Src_Id.Language.Config.Object_Generated
7953 and then Is_Extending (Project.Project, Src_Id.Project)
7954 then
7955 if Src_Id.Unit = No_Unit_Index then
7956 if Src_Id.Kind = Impl then
7957 Check_Object (Src_Id);
7958 end if;
7960 else
7961 case Src_Id.Kind is
7962 when Spec =>
7963 if Other_Part (Src_Id) = No_Source then
7964 Check_Object (Src_Id);
7965 end if;
7967 when Sep =>
7968 null;
7970 when Impl =>
7971 if Other_Part (Src_Id) /= No_Source then
7972 Check_Object (Src_Id);
7974 else
7975 -- Check if it is a subunit
7977 Src_Ind :=
7978 Sinput.P.Load_Project_File
7979 (Get_Name_String (Src_Id.Path.Display_Name));
7981 if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
7982 Override_Kind (Src_Id, Sep);
7983 else
7984 Check_Object (Src_Id);
7985 end if;
7986 end if;
7987 end case;
7988 end if;
7989 end if;
7991 Next (Iter);
7992 end loop;
7993 end Check_Object_Files;
7995 ----------------------------------
7996 -- Get_Sources_From_Source_Info --
7997 ----------------------------------
7999 procedure Get_Sources_From_Source_Info is
8000 Iter : Source_Info_Iterator;
8001 Src : Source_Info;
8002 Id : Source_Id;
8003 Lang_Id : Language_Ptr;
8005 begin
8006 Initialize (Iter, Project.Project.Name);
8008 loop
8009 Src := Source_Info_Of (Iter);
8011 exit when Src = No_Source_Info;
8013 Id := new Source_Data;
8015 Id.Project := Project.Project;
8017 Lang_Id := Project.Project.Languages;
8018 while Lang_Id /= No_Language_Index
8019 and then Lang_Id.Name /= Src.Language
8020 loop
8021 Lang_Id := Lang_Id.Next;
8022 end loop;
8024 if Lang_Id = No_Language_Index then
8025 Prj.Com.Fail
8026 ("unknown language " &
8027 Get_Name_String (Src.Language) &
8028 " for project " &
8029 Get_Name_String (Src.Project) &
8030 " in source info file");
8031 end if;
8033 Id.Language := Lang_Id;
8034 Id.Kind := Src.Kind;
8035 Id.Index := Src.Index;
8037 Id.Path :=
8038 (Path_Name_Type (Src.Display_Path_Name),
8039 Path_Name_Type (Src.Path_Name));
8041 Name_Len := 0;
8042 Add_Str_To_Name_Buffer
8043 (Directories.Simple_Name (Get_Name_String (Src.Path_Name)));
8044 Id.File := Name_Find;
8046 Id.Next_With_File_Name :=
8047 Source_Files_Htable.Get (Data.Tree.Source_Files_HT, Id.File);
8048 Source_Files_Htable.Set (Data.Tree.Source_Files_HT, Id.File, Id);
8050 Name_Len := 0;
8051 Add_Str_To_Name_Buffer
8052 (Directories.Simple_Name
8053 (Get_Name_String (Src.Display_Path_Name)));
8054 Id.Display_File := Name_Find;
8056 Id.Dep_Name :=
8057 Dependency_Name (Id.File, Id.Language.Config.Dependency_Kind);
8058 Id.Naming_Exception := Src.Naming_Exception;
8059 Id.Object :=
8060 Object_Name (Id.File, Id.Language.Config.Object_File_Suffix);
8061 Id.Switches := Switches_Name (Id.File);
8063 -- Add the source id to the Unit_Sources_HT hash table, if the
8064 -- unit name is not null.
8066 if Src.Kind /= Sep and then Src.Unit_Name /= No_Name then
8068 declare
8069 UData : Unit_Index :=
8070 Units_Htable.Get
8071 (Data.Tree.Units_HT, Src.Unit_Name);
8072 begin
8073 if UData = No_Unit_Index then
8074 UData := new Unit_Data;
8075 UData.Name := Src.Unit_Name;
8076 Units_Htable.Set
8077 (Data.Tree.Units_HT, Src.Unit_Name, UData);
8078 end if;
8080 Id.Unit := UData;
8081 end;
8083 -- Note that this updates Unit information as well
8085 Override_Kind (Id, Id.Kind);
8086 end if;
8088 if Src.Index /= 0 then
8089 Project.Project.Has_Multi_Unit_Sources := True;
8090 end if;
8092 -- Add the source to the language list
8094 Id.Next_In_Lang := Id.Language.First_Source;
8095 Id.Language.First_Source := Id;
8097 Next (Iter);
8098 end loop;
8099 end Get_Sources_From_Source_Info;
8101 -- Start of processing for Look_For_Sources
8103 begin
8104 if Data.Tree.Source_Info_File_Exists then
8105 Get_Sources_From_Source_Info;
8107 else
8108 if Project.Project.Source_Dirs /= Nil_String then
8109 Find_Excluded_Sources (Project, Data);
8111 if Project.Project.Languages /= No_Language_Index then
8112 Load_Naming_Exceptions (Project, Data);
8113 Find_Sources (Project, Data);
8114 Mark_Excluded_Sources;
8115 Check_Object_Files;
8116 Check_Missing_Sources;
8117 end if;
8118 end if;
8120 Object_File_Names_Htable.Reset (Object_Files);
8121 end if;
8122 end Look_For_Sources;
8124 ------------------
8125 -- Path_Name_Of --
8126 ------------------
8128 function Path_Name_Of
8129 (File_Name : File_Name_Type;
8130 Directory : Path_Name_Type) return String
8131 is
8132 Result : String_Access;
8133 The_Directory : constant String := Get_Name_String (Directory);
8135 begin
8136 Debug_Output ("Path_Name_Of file name=", Name_Id (File_Name));
8137 Debug_Output ("Path_Name_Of directory=", Name_Id (Directory));
8138 Get_Name_String (File_Name);
8139 Result :=
8140 Locate_Regular_File
8141 (File_Name => Name_Buffer (1 .. Name_Len),
8142 Path => The_Directory);
8144 if Result = null then
8145 return "";
8146 else
8147 declare
8148 R : constant String := Result.all;
8149 begin
8150 Free (Result);
8151 return R;
8152 end;
8153 end if;
8154 end Path_Name_Of;
8156 -------------------
8157 -- Remove_Source --
8158 -------------------
8160 procedure Remove_Source
8161 (Tree : Project_Tree_Ref;
8162 Id : Source_Id;
8163 Replaced_By : Source_Id)
8164 is
8165 Source : Source_Id;
8167 begin
8168 if Current_Verbosity = High then
8169 Debug_Indent;
8170 Write_Str ("removing source ");
8171 Write_Str (Get_Name_String (Id.File));
8173 if Id.Index /= 0 then
8174 Write_Str (" at" & Id.Index'Img);
8175 end if;
8177 Write_Eol;
8178 end if;
8180 if Replaced_By /= No_Source then
8181 Id.Replaced_By := Replaced_By;
8182 Replaced_By.Declared_In_Interfaces := Id.Declared_In_Interfaces;
8184 if Id.File /= Replaced_By.File then
8185 declare
8186 Replacement : constant File_Name_Type :=
8187 Replaced_Source_HTable.Get
8188 (Tree.Replaced_Sources, Id.File);
8190 begin
8191 Replaced_Source_HTable.Set
8192 (Tree.Replaced_Sources, Id.File, Replaced_By.File);
8194 if Replacement = No_File then
8195 Tree.Replaced_Source_Number :=
8196 Tree.Replaced_Source_Number + 1;
8197 end if;
8198 end;
8199 end if;
8200 end if;
8202 Id.In_Interfaces := False;
8203 Id.Locally_Removed := True;
8205 -- ??? Should we remove the source from the unit ? The file is not used,
8206 -- so probably should not be referenced from the unit. On the other hand
8207 -- it might give useful additional info
8208 -- if Id.Unit /= null then
8209 -- Id.Unit.File_Names (Id.Kind) := null;
8210 -- end if;
8212 Source := Id.Language.First_Source;
8214 if Source = Id then
8215 Id.Language.First_Source := Id.Next_In_Lang;
8217 else
8218 while Source.Next_In_Lang /= Id loop
8219 Source := Source.Next_In_Lang;
8220 end loop;
8222 Source.Next_In_Lang := Id.Next_In_Lang;
8223 end if;
8224 end Remove_Source;
8226 -----------------------
8227 -- Report_No_Sources --
8228 -----------------------
8230 procedure Report_No_Sources
8231 (Project : Project_Id;
8232 Lang_Name : String;
8233 Data : Tree_Processing_Data;
8234 Location : Source_Ptr;
8235 Continuation : Boolean := False)
8236 is
8237 begin
8238 case Data.Flags.When_No_Sources is
8239 when Silent =>
8240 null;
8242 when Warning | Error =>
8243 declare
8244 Msg : constant String :=
8245 "<there are no "
8246 & Lang_Name & " sources in this project";
8248 begin
8249 Error_Msg_Warn := Data.Flags.When_No_Sources = Warning;
8251 if Continuation then
8253 else
8254 Error_Msg (Data.Flags, Msg, Location, Project);
8255 end if;
8256 end;
8257 end case;
8258 end Report_No_Sources;
8260 ----------------------
8261 -- Show_Source_Dirs --
8262 ----------------------
8264 procedure Show_Source_Dirs
8265 (Project : Project_Id;
8266 Shared : Shared_Project_Tree_Data_Access)
8267 is
8268 Current : String_List_Id;
8269 Element : String_Element;
8271 begin
8272 if Project.Source_Dirs = Nil_String then
8273 Debug_Output ("no Source_Dirs");
8274 else
8275 Debug_Increase_Indent ("Source_Dirs:");
8277 Current := Project.Source_Dirs;
8278 while Current /= Nil_String loop
8279 Element := Shared.String_Elements.Table (Current);
8280 Debug_Output (Get_Name_String (Element.Display_Value));
8281 Current := Element.Next;
8282 end loop;
8284 Debug_Decrease_Indent ("end Source_Dirs.");
8285 end if;
8286 end Show_Source_Dirs;
8288 ---------------------------
8289 -- Process_Naming_Scheme --
8290 ---------------------------
8292 procedure Process_Naming_Scheme
8293 (Tree : Project_Tree_Ref;
8294 Root_Project : Project_Id;
8295 Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
8296 Flags : Processing_Flags)
8297 is
8299 procedure Check
8300 (Project : Project_Id;
8301 In_Aggregate_Lib : Boolean;
8302 Data : in out Tree_Processing_Data);
8303 -- Process the naming scheme for a single project
8305 procedure Recursive_Check
8306 (Project : Project_Id;
8307 Prj_Tree : Project_Tree_Ref;
8308 Context : Project_Context;
8309 Data : in out Tree_Processing_Data);
8310 -- Check_Naming_Scheme for the project
8312 -----------
8313 -- Check --
8314 -----------
8316 procedure Check
8317 (Project : Project_Id;
8318 In_Aggregate_Lib : Boolean;
8319 Data : in out Tree_Processing_Data)
8320 is
8321 procedure Check_Aggregate
8322 (Project : Project_Id;
8323 Data : in out Tree_Processing_Data);
8324 -- Check the aggregate project attributes, reject any not supported
8325 -- attributes.
8327 procedure Check_Aggregated
8328 (Project : Project_Id;
8329 Data : in out Tree_Processing_Data);
8330 -- Check aggregated projects which should not be externally built.
8331 -- What is Data??? if same as outer Data, why passed???
8332 -- What exact check is performed here??? Seems a bad idea to have
8333 -- two procedures with such close names ???
8335 ---------------------
8336 -- Check_Aggregate --
8337 ---------------------
8339 procedure Check_Aggregate
8340 (Project : Project_Id;
8341 Data : in out Tree_Processing_Data)
8342 is
8343 procedure Check_Not_Defined (Name : Name_Id);
8344 -- Report an error if Var is defined
8346 -----------------------
8347 -- Check_Not_Defined --
8348 -----------------------
8350 procedure Check_Not_Defined (Name : Name_Id) is
8351 Var : constant Prj.Variable_Value :=
8352 Prj.Util.Value_Of
8353 (Name, Project.Decl.Attributes, Data.Tree.Shared);
8354 begin
8355 if not Var.Default then
8356 Error_Msg_Name_1 := Name;
8357 Error_Msg
8358 (Data.Flags, "wrong attribute %% in aggregate library",
8359 Var.Location, Project);
8360 end if;
8361 end Check_Not_Defined;
8363 -- Start of processing for Check_Aggregate
8365 begin
8366 Check_Not_Defined (Snames.Name_Library_Dir);
8367 Check_Not_Defined (Snames.Name_Library_Interface);
8368 Check_Not_Defined (Snames.Name_Library_Name);
8369 Check_Not_Defined (Snames.Name_Library_Ali_Dir);
8370 Check_Not_Defined (Snames.Name_Library_Src_Dir);
8371 Check_Not_Defined (Snames.Name_Library_Options);
8372 Check_Not_Defined (Snames.Name_Library_Standalone);
8373 Check_Not_Defined (Snames.Name_Library_Kind);
8374 Check_Not_Defined (Snames.Name_Leading_Library_Options);
8375 Check_Not_Defined (Snames.Name_Library_Version);
8376 end Check_Aggregate;
8378 ----------------------
8379 -- Check_Aggregated --
8380 ----------------------
8382 procedure Check_Aggregated
8383 (Project : Project_Id;
8384 Data : in out Tree_Processing_Data)
8385 is
8386 L : Aggregated_Project_List;
8388 begin
8389 -- Check that aggregated projects are not externally built
8391 L := Project.Aggregated_Projects;
8392 while L /= null loop
8393 declare
8394 Var : constant Prj.Variable_Value :=
8395 Prj.Util.Value_Of
8396 (Snames.Name_Externally_Built,
8397 L.Project.Decl.Attributes,
8398 Data.Tree.Shared);
8399 begin
8400 if not Var.Default then
8401 Error_Msg_Name_1 := L.Project.Display_Name;
8402 Error_Msg
8403 (Data.Flags,
8404 "cannot aggregate externally build library %%",
8405 Var.Location, Project);
8406 end if;
8407 end;
8409 L := L.Next;
8410 end loop;
8411 end Check_Aggregated;
8413 -- Local Variables
8415 Shared : constant Shared_Project_Tree_Data_Access :=
8416 Data.Tree.Shared;
8417 Prj_Data : Project_Processing_Data;
8419 -- Start of processing for Check
8421 begin
8422 Debug_Increase_Indent ("check", Project.Name);
8424 Initialize (Prj_Data, Project);
8426 Check_If_Externally_Built (Project, Data);
8428 case Project.Qualifier is
8429 when Aggregate =>
8430 Check_Aggregated (Project, Data);
8432 when Aggregate_Library =>
8433 Check_Aggregated (Project, Data);
8435 if Project.Object_Directory = No_Path_Information then
8436 Project.Object_Directory := Project.Directory;
8437 end if;
8439 when others =>
8440 Get_Directories (Project, Data);
8441 Check_Programming_Languages (Project, Data);
8443 if Current_Verbosity = High then
8444 Show_Source_Dirs (Project, Shared);
8445 end if;
8447 if Project.Qualifier = Dry then
8448 Check_Abstract_Project (Project, Data);
8449 end if;
8450 end case;
8452 -- Check configuration. Must be done for gnatmake (even though no
8453 -- user configuration file was provided) since the default config we
8454 -- generate indicates whether libraries are supported for instance.
8456 Check_Configuration (Project, Data);
8458 -- For aggregate project check no library attributes are defined
8460 if Project.Qualifier = Aggregate then
8461 Check_Aggregate (Project, Data);
8463 else
8464 Check_Library_Attributes (Project, Data);
8465 Check_Package_Naming (Project, Data);
8467 -- An aggregate library has no source, no need to look for them
8469 if Project.Qualifier /= Aggregate_Library then
8470 Look_For_Sources (Prj_Data, Data);
8471 end if;
8473 Check_Interfaces (Project, Data);
8475 -- If this library is part of an aggregated library don't check it
8476 -- as it has no sources by itself and so interface won't be found.
8478 if Project.Library and not In_Aggregate_Lib then
8479 Check_Stand_Alone_Library (Project, Data);
8480 end if;
8482 Get_Mains (Project, Data);
8483 end if;
8485 Free (Prj_Data);
8487 Debug_Decrease_Indent ("done check");
8488 end Check;
8490 ---------------------
8491 -- Recursive_Check --
8492 ---------------------
8494 procedure Recursive_Check
8495 (Project : Project_Id;
8496 Prj_Tree : Project_Tree_Ref;
8497 Context : Project_Context;
8498 Data : in out Tree_Processing_Data)
8499 is
8500 begin
8501 if Current_Verbosity = High then
8502 Debug_Increase_Indent
8503 ("Processing_Naming_Scheme for project", Project.Name);
8504 end if;
8506 Data.Tree := Prj_Tree;
8507 Data.In_Aggregate_Lib := Context.In_Aggregate_Lib;
8509 Check (Project, Context.In_Aggregate_Lib, Data);
8511 if Current_Verbosity = High then
8512 Debug_Decrease_Indent ("done Processing_Naming_Scheme");
8513 end if;
8514 end Recursive_Check;
8516 procedure Check_All_Projects is new For_Every_Project_Imported_Context
8517 (Tree_Processing_Data, Recursive_Check);
8518 -- Comment required???
8520 -- Local Variables
8522 Data : Tree_Processing_Data;
8524 -- Start of processing for Process_Naming_Scheme
8526 begin
8527 Lib_Data_Table.Init;
8528 Initialize (Data, Tree => Tree, Node_Tree => Node_Tree, Flags => Flags);
8529 Check_All_Projects (Root_Project, Tree, Data, Imported_First => True);
8530 Free (Data);
8532 -- Adjust language configs for projects that are extended
8534 declare
8535 List : Project_List;
8536 Proj : Project_Id;
8537 Exte : Project_Id;
8538 Lang : Language_Ptr;
8539 Elng : Language_Ptr;
8541 begin
8542 List := Tree.Projects;
8543 while List /= null loop
8544 Proj := List.Project;
8546 Exte := Proj;
8547 while Exte.Extended_By /= No_Project loop
8548 Exte := Exte.Extended_By;
8549 end loop;
8551 if Exte /= Proj then
8552 Lang := Proj.Languages;
8554 if Lang /= No_Language_Index then
8555 loop
8556 Elng := Get_Language_From_Name
8557 (Exte, Get_Name_String (Lang.Name));
8558 exit when Elng /= No_Language_Index;
8559 Exte := Exte.Extends;
8560 end loop;
8562 if Elng /= Lang then
8563 Lang.Config := Elng.Config;
8564 end if;
8565 end if;
8566 end if;
8568 List := List.Next;
8569 end loop;
8570 end;
8571 end Process_Naming_Scheme;
8573 end Prj.Nmsc;