| blob | 35d7e041bb641410c5aff10d38d95458a82e8c43 |
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-2009, 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 ------------------------------------------------------------------------------
50 -- Used in Check_Library for continuation error messages at the same
51 -- location.
53 type Name_Location is record
54 Name : File_Name_Type; -- ??? duplicates the key
55 Location : Source_Ptr;
56 Source : Source_Id := No_Source;
57 Found : Boolean := False;
58 end record;
59 No_Name_Location : constant Name_Location :=
60 (No_File, No_Location, No_Source, False);
61 package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
62 (Header_Num => Header_Num,
63 Element => Name_Location,
64 No_Element => No_Name_Location,
65 Key => File_Name_Type,
66 Hash => Hash,
68 -- Information about file names found in string list attribute
69 -- (Source_Files or Source_List_File).
70 -- Except is set to True if source is a naming exception in the project.
71 -- This is used to check that all referenced files were indeed found on the
72 -- disk.
74 type Unit_Exception is record
75 Name : Name_Id; -- ??? duplicates the key
76 Spec : File_Name_Type;
77 Impl : File_Name_Type;
78 end record;
80 No_Unit_Exception : constant Unit_Exception := (No_Name, No_File, No_File);
82 package Unit_Exceptions_Htable is new GNAT.Dynamic_HTables.Simple_HTable
83 (Header_Num => Header_Num,
84 Element => Unit_Exception,
85 No_Element => No_Unit_Exception,
86 Key => Name_Id,
87 Hash => Hash,
89 -- Record special naming schemes for Ada units (name of spec file and name
90 -- of implementation file). The elements in this list come from the naming
91 -- exceptions specified in the project files.
93 type File_Found is record
94 File : File_Name_Type := No_File;
95 Found : Boolean := False;
96 Location : Source_Ptr := No_Location;
97 end record;
99 No_File_Found : constant File_Found := (No_File, False, No_Location);
101 package Excluded_Sources_Htable is new GNAT.Dynamic_HTables.Simple_HTable
102 (Header_Num => Header_Num,
103 Element => File_Found,
104 No_Element => No_File_Found,
105 Key => File_Name_Type,
106 Hash => Hash,
108 -- A hash table to store the base names of excluded files, if any
110 package Object_File_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
111 (Header_Num => Header_Num,
112 Element => Source_Id,
113 No_Element => No_Source,
114 Key => File_Name_Type,
115 Hash => Hash,
117 -- A hash table to store the object file names for a project, to check that
118 -- two different sources have different object file names.
120 type Project_Processing_Data is record
121 Project : Project_Id;
122 Source_Names : Source_Names_Htable.Instance;
123 Unit_Exceptions : Unit_Exceptions_Htable.Instance;
124 Excluded : Excluded_Sources_Htable.Instance;
126 Source_List_File_Location : Source_Ptr;
127 -- Location of the Source_List_File attribute, for error messages
128 end record;
129 -- This is similar to Tree_Processing_Data, but contains project-specific
130 -- information which is only useful while processing the project, and can
131 -- be discarded as soon as we have finished processing the project
133 package Files_Htable is new GNAT.Dynamic_HTables.Simple_HTable
134 (Header_Num => Header_Num,
135 Element => Source_Id,
136 No_Element => No_Source,
137 Key => File_Name_Type,
138 Hash => Hash,
140 -- Mapping from base file names to Source_Id (containing full info about
141 -- the source).
143 type Tree_Processing_Data is record
144 Tree : Project_Tree_Ref;
145 File_To_Source : Files_Htable.Instance;
146 Flags : Prj.Processing_Flags;
147 end record;
148 -- Temporary data which is needed while parsing a project. It does not need
149 -- to be kept in memory once a project has been fully loaded, but is
150 -- necessary while performing consistency checks (duplicate sources,...)
151 -- This data must be initialized before processing any project, and the
152 -- same data is used for processing all projects in the tree.
154 procedure Initialize
155 (Data : out Tree_Processing_Data;
156 Tree : Project_Tree_Ref;
157 Flags : Prj.Processing_Flags);
158 -- Initialize Data
160 procedure Free (Data : in out Tree_Processing_Data);
161 -- Free the memory occupied by Data
163 procedure Check
164 (Project : Project_Id;
165 Data : in out Tree_Processing_Data);
166 -- Process the naming scheme for a single project
168 procedure Initialize
169 (Data : in out Project_Processing_Data;
170 Project : Project_Id);
171 procedure Free (Data : in out Project_Processing_Data);
172 -- Initialize or free memory for a project-specific data
174 procedure Find_Excluded_Sources
175 (Project : in out Project_Processing_Data;
176 Data : in out Tree_Processing_Data);
177 -- Find the list of files that should not be considered as source files
178 -- for this project. Sets the list in the Project.Excluded_Sources_Htable.
180 procedure Override_Kind (Source : Source_Id; Kind : Source_Kind);
181 -- Override the reference kind for a source file. This properly updates
182 -- the unit data if necessary.
184 procedure Load_Naming_Exceptions
185 (Project : in out Project_Processing_Data;
186 Data : in out Tree_Processing_Data);
187 -- All source files in Data.First_Source are considered as naming
188 -- exceptions, and copied into the Source_Names and Unit_Exceptions tables
189 -- as appropriate.
191 procedure Add_Source
192 (Id : out Source_Id;
193 Data : in out Tree_Processing_Data;
194 Project : Project_Id;
195 Source_Dir_Rank : Natural;
196 Lang_Id : Language_Ptr;
197 Kind : Source_Kind;
198 File_Name : File_Name_Type;
199 Display_File : File_Name_Type;
200 Naming_Exception : Boolean := False;
201 Path : Path_Information := No_Path_Information;
202 Alternate_Languages : Language_List := null;
203 Unit : Name_Id := No_Name;
204 Index : Int := 0;
205 Locally_Removed : Boolean := False;
206 Location : Source_Ptr := No_Location);
207 -- Add a new source to the different lists: list of all sources in the
208 -- project tree, list of source of a project and list of sources of a
209 -- language.
210 --
211 -- If Path is specified, the file is also added to Source_Paths_HT.
212 --
213 -- Location is used for error messages
215 function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type;
216 -- Same as Osint.Canonical_Case_File_Name but applies to Name_Id.
217 -- This alters Name_Buffer
219 function Suffix_Matches
220 (Filename : String;
221 Suffix : File_Name_Type) return Boolean;
222 -- True if the file name ends with the given suffix. Always returns False
223 -- if Suffix is No_Name.
225 procedure Replace_Into_Name_Buffer
226 (Str : String;
227 Pattern : String;
228 Replacement : Character);
229 -- Copy Str into Name_Buffer, replacing Pattern with Replacement. Str is
230 -- converted to lower-case at the same time.
232 procedure Check_Ada_Name (Name : String; Unit : out Name_Id);
233 -- Check that a name is a valid Ada unit name
235 procedure Check_Package_Naming
236 (Project : Project_Id;
237 Data : in out Tree_Processing_Data;
238 Bodies : out Array_Element_Id;
239 Specs : out Array_Element_Id);
240 -- Check the naming scheme part of Data, and initialize the naming scheme
241 -- data in the config of the various languages. This also returns the
242 -- naming scheme exceptions for unit-based languages (Bodies and Specs are
243 -- associative arrays mapping individual unit names to source file names).
245 procedure Check_Configuration
246 (Project : Project_Id;
247 Data : in out Tree_Processing_Data);
248 -- Check the configuration attributes for the project
250 procedure Check_If_Externally_Built
251 (Project : Project_Id;
252 Data : in out Tree_Processing_Data);
253 -- Check attribute Externally_Built of project Project in project tree
256 procedure Check_Interfaces
257 (Project : Project_Id;
258 Data : in out Tree_Processing_Data);
259 -- If a list of sources is specified in attribute Interfaces, set
260 -- In_Interfaces only for the sources specified in the list.
262 procedure Check_Library_Attributes
263 (Project : Project_Id;
264 Data : in out Tree_Processing_Data);
265 -- Check the library attributes of project Project in project tree
266 -- and modify its data Data accordingly.
268 procedure Check_Programming_Languages
269 (Project : Project_Id;
270 Data : in out Tree_Processing_Data);
271 -- Check attribute Languages for the project with data Data in project
272 -- tree Data.Tree and set the components of Data for all the programming
273 -- languages indicated in attribute Languages, if any.
275 procedure Check_Stand_Alone_Library
276 (Project : Project_Id;
277 Data : in out Tree_Processing_Data);
278 -- Check if project Project in project tree Data.Tree is a Stand-Alone
279 -- Library project, and modify its data Data accordingly if it is one.
281 function Compute_Directory_Last (Dir : String) return Natural;
282 -- Return the index of the last significant character in Dir. This is used
283 -- to avoid duplicate '/' (slash) characters at the end of directory names.
285 procedure Search_Directories
286 (Project : in out Project_Processing_Data;
287 Data : in out Tree_Processing_Data;
288 For_All_Sources : Boolean);
289 -- Search the source directories to find the sources. If For_All_Sources is
290 -- True, check each regular file name against the naming schemes of the
291 -- various languages. Otherwise consider only the file names in hash table
292 -- Source_Names. If Allow_Duplicate_Basenames then files with identical
293 -- base names are permitted within a project for source-based languages
294 -- (never for unit based languages).
296 procedure Check_File
297 (Project : in out Project_Processing_Data;
298 Data : in out Tree_Processing_Data;
299 Source_Dir_Rank : Natural;
300 Path : Path_Name_Type;
301 File_Name : File_Name_Type;
302 Display_File_Name : File_Name_Type;
303 Locally_Removed : Boolean;
304 For_All_Sources : Boolean);
305 -- Check if file File_Name is a valid source of the project. This is used
306 -- in multi-language mode only. When the file matches one of the naming
307 -- schemes, it is added to various htables through Add_Source and to
308 -- Source_Paths_Htable.
309 --
310 -- Name is the name of the candidate file. It hasn't been normalized yet
311 -- and is the direct result of readdir().
312 --
313 -- File_Name is the same as Name, but has been normalized.
314 -- Display_File_Name, however, has not been normalized.
315 --
316 -- Source_Directory is the directory in which the file was found. It is
317 -- neither normalized nor has had links resolved, and must not end with a
318 -- a directory separator, to avoid duplicates later on.
319 --
320 -- If For_All_Sources is True, then all possible file names are analyzed
321 -- otherwise only those currently set in the Source_Names hash table.
323 procedure Check_File_Naming_Schemes
324 (In_Tree : Project_Tree_Ref;
325 Project : Project_Processing_Data;
326 File_Name : File_Name_Type;
327 Alternate_Languages : out Language_List;
328 Language : out Language_Ptr;
329 Display_Language_Name : out Name_Id;
330 Unit : out Name_Id;
331 Lang_Kind : out Language_Kind;
332 Kind : out Source_Kind);
333 -- Check if the file name File_Name conforms to one of the naming schemes
334 -- of the project. If the file does not match one of the naming schemes,
335 -- set Language to No_Language_Index. Filename is the name of the file
336 -- being investigated. It has been normalized (case-folded). File_Name is
337 -- the same value.
339 procedure Get_Directories
340 (Project : Project_Id;
341 Data : in out Tree_Processing_Data);
342 -- Get the object directory, the exec directory and the source directories
343 -- of a project.
345 procedure Get_Mains
346 (Project : Project_Id;
347 Data : in out Tree_Processing_Data);
348 -- Get the mains of a project from attribute Main, if it exists, and put
349 -- them in the project data.
351 procedure Get_Sources_From_File
352 (Path : String;
353 Location : Source_Ptr;
354 Project : in out Project_Processing_Data;
355 Data : in out Tree_Processing_Data);
356 -- Get the list of sources from a text file and put them in hash table
357 -- Source_Names.
359 procedure Find_Sources
360 (Project : in out Project_Processing_Data;
361 Data : in out Tree_Processing_Data);
362 -- Process the Source_Files and Source_List_File attributes, and store the
363 -- list of source files into the Source_Names htable. When these attributes
364 -- are not defined, find all files matching the naming schemes in the
365 -- source directories. If Allow_Duplicate_Basenames, then files with the
366 -- same base names are authorized within a project for source-based
367 -- languages (never for unit based languages)
369 procedure Compute_Unit_Name
370 (File_Name : File_Name_Type;
371 Naming : Lang_Naming_Data;
372 Kind : out Source_Kind;
373 Unit : out Name_Id;
374 Project : Project_Processing_Data;
375 In_Tree : Project_Tree_Ref);
376 -- Check whether the file matches the naming scheme. If it does,
377 -- compute its unit name. If Unit is set to No_Name on exit, none of the
378 -- other out parameters are relevant.
380 procedure Check_Illegal_Suffix
381 (Project : Project_Id;
382 Suffix : File_Name_Type;
383 Dot_Replacement : File_Name_Type;
384 Attribute_Name : String;
385 Location : Source_Ptr;
386 Data : in out Tree_Processing_Data);
387 -- Display an error message if the given suffix is illegal for some reason.
388 -- The name of the attribute we are testing is specified in Attribute_Name,
389 -- which is used in the error message. Location is the location where the
390 -- suffix is defined.
392 procedure Locate_Directory
393 (Project : Project_Id;
394 Name : File_Name_Type;
395 Path : out Path_Information;
396 Dir_Exists : out Boolean;
397 Data : in out Tree_Processing_Data;
399 Location : Source_Ptr := No_Location;
400 Must_Exist : Boolean := True;
401 Externally_Built : Boolean := False);
402 -- Locate a directory. Name is the directory name. Relative paths are
403 -- resolved relative to the project's directory. If the directory does not
404 -- exist and Setup_Projects is True and Create is a non null string, an
405 -- attempt is made to create the directory. If the directory does not
406 -- exist, it is either created if Setup_Projects is False (and then
407 -- returned), or simply returned without checking for its existence (if
408 -- Must_Exist is False) or No_Path_Information is returned. In all cases,
409 -- Dir_Exists indicates whether the directory now exists. Create is also
410 -- used for debugging traces to show which path we are computing.
412 procedure Look_For_Sources
413 (Project : in out Project_Processing_Data;
414 Data : in out Tree_Processing_Data);
415 -- Find all the sources of project Project in project tree Data.Tree and
416 -- update its Data accordingly. This assumes that Data.First_Source has
417 -- been initialized with the list of excluded sources and special naming
418 -- exceptions.
420 function Path_Name_Of
421 (File_Name : File_Name_Type;
422 Directory : Path_Name_Type) return String;
423 -- Returns the path name of a (non project) file. Returns an empty string
424 -- if file cannot be found.
426 procedure Remove_Source
427 (Id : Source_Id;
428 Replaced_By : Source_Id);
429 -- Remove a file from the list of sources of a project. This might be
430 -- because the file is replaced by another one in an extending project,
431 -- or because a file was added as a naming exception but was not found
432 -- in the end.
434 procedure Report_No_Sources
435 (Project : Project_Id;
436 Lang_Name : String;
437 Data : Tree_Processing_Data;
438 Location : Source_Ptr;
439 Continuation : Boolean := False);
440 -- Report an error or a warning depending on the value of When_No_Sources
441 -- when there are no sources for language Lang_Name.
443 procedure Show_Source_Dirs
444 (Project : Project_Id; In_Tree : Project_Tree_Ref);
445 -- List all the source directories of a project
447 procedure Write_Attr (Name, Value : String);
448 -- Debug print a value for a specific property. Does nothing when not in
449 -- debug mode
451 ------------------------------
452 -- Replace_Into_Name_Buffer --
453 ------------------------------
455 procedure Replace_Into_Name_Buffer
456 (Str : String;
457 Pattern : String;
458 Replacement : Character)
459 is
460 Max : constant Integer := Str'Last - Pattern'Length + 1;
461 J : Positive;
463 begin
464 Name_Len := 0;
466 J := Str'First;
467 while J <= Str'Last loop
468 Name_Len := Name_Len + 1;
470 if J <= Max
471 and then Str (J .. J + Pattern'Length - 1) = Pattern
472 then
473 Name_Buffer (Name_Len) := Replacement;
474 J := J + Pattern'Length;
476 else
477 Name_Buffer (Name_Len) := GNAT.Case_Util.To_Lower (Str (J));
478 J := J + 1;
479 end if;
480 end loop;
481 end Replace_Into_Name_Buffer;
483 --------------------
484 -- Suffix_Matches --
485 --------------------
487 function Suffix_Matches
488 (Filename : String;
489 Suffix : File_Name_Type) return Boolean
490 is
491 Min_Prefix_Length : Natural := 0;
493 begin
494 if Suffix = No_File or else Suffix = Empty_File then
495 return False;
496 end if;
498 declare
499 Suf : String := Get_Name_String (Suffix);
501 begin
502 -- On non case-sensitive systems, use proper suffix casing
504 Canonical_Case_File_Name (Suf);
506 -- The file name must end with the suffix (which is not an extension)
508 -- same name. To avoid dummy cases, though, a suffix starting with
509 -- '.' requires a file that is at least one character longer ('.cpp'
510 -- should not match a file with the same name)
512 if Suf (Suf'First) = '.' then
513 Min_Prefix_Length := 1;
514 end if;
516 return Filename'Length >= Suf'Length + Min_Prefix_Length
517 and then Filename
518 (Filename'Last - Suf'Length + 1 .. Filename'Last) = Suf;
519 end;
520 end Suffix_Matches;
522 ----------------
523 -- Write_Attr --
524 ----------------
526 procedure Write_Attr (Name, Value : String) is
527 begin
528 if Current_Verbosity = High then
530 Write_Str (Value);
532 Write_Eol;
533 end if;
534 end Write_Attr;
536 ----------------
537 -- Add_Source --
538 ----------------
540 procedure Add_Source
541 (Id : out Source_Id;
542 Data : in out Tree_Processing_Data;
543 Project : Project_Id;
544 Source_Dir_Rank : Natural;
545 Lang_Id : Language_Ptr;
546 Kind : Source_Kind;
547 File_Name : File_Name_Type;
548 Display_File : File_Name_Type;
549 Naming_Exception : Boolean := False;
550 Path : Path_Information := No_Path_Information;
551 Alternate_Languages : Language_List := null;
552 Unit : Name_Id := No_Name;
553 Index : Int := 0;
554 Locally_Removed : Boolean := False;
555 Location : Source_Ptr := No_Location)
556 is
557 Config : constant Language_Config := Lang_Id.Config;
558 UData : Unit_Index;
559 Add_Src : Boolean;
560 Source : Source_Id;
561 Prev_Unit : Unit_Index := No_Unit_Index;
563 Source_To_Replace : Source_Id := No_Source;
565 begin
566 -- Check if the same file name or unit is used in the prj tree
568 Add_Src := True;
570 if Unit /= No_Name then
571 Prev_Unit := Units_Htable.Get (Data.Tree.Units_HT, Unit);
572 end if;
574 if Prev_Unit /= No_Unit_Index
575 and then (Kind = Impl or else Kind = Spec)
576 and then Prev_Unit.File_Names (Kind) /= null
577 then
578 -- Suspicious, we need to check later whether this is authorized
580 Add_Src := False;
581 Source := Prev_Unit.File_Names (Kind);
583 else
584 Source := Files_Htable.Get (Data.File_To_Source, File_Name);
586 if Source /= No_Source
587 and then Source.Index = Index
588 then
589 Add_Src := False;
590 end if;
591 end if;
593 -- Duplication of file/unit in same project is allowed if order of
594 -- source directories is known.
596 if Add_Src = False then
597 Add_Src := True;
599 if Project = Source.Project then
600 if Prev_Unit = No_Unit_Index then
601 if Data.Flags.Allow_Duplicate_Basenames then
602 Add_Src := True;
604 elsif Source_Dir_Rank /= Source.Source_Dir_Rank then
605 Add_Src := False;
607 else
608 Error_Msg_File_1 := File_Name;
609 Error_Msg
610 (Data.Flags, "duplicate source file name {",
611 Location, Project);
612 Add_Src := False;
613 end if;
615 else
616 if Source_Dir_Rank /= Source.Source_Dir_Rank then
617 Add_Src := False;
619 -- We might be seeing the same file through a different path
620 -- (for instance because of symbolic links).
622 elsif Source.Path.Name /= Path.Name then
623 Error_Msg_Name_1 := Unit;
624 Error_Msg
625 (Data.Flags, "duplicate unit %%", Location, Project);
626 Add_Src := False;
627 end if;
628 end if;
630 -- Do not allow the same unit name in different projects, except
631 -- if one is extending the other.
633 -- For a file based language, the same file name replaces a file
634 -- in a project being extended, but it is allowed to have the same
635 -- file name in unrelated projects.
637 elsif Is_Extending (Project, Source.Project) then
638 if not Locally_Removed then
639 Source_To_Replace := Source;
640 end if;
642 elsif Prev_Unit /= No_Unit_Index
643 and then not Source.Locally_Removed
644 then
645 -- Path is set if this is a source we found on the disk, in which
646 -- case we can provide more explicit error message. Path is unset
647 -- when the source is added from one of the naming exceptions in
648 -- the project.
650 if Path /= No_Path_Information then
651 Error_Msg_Name_1 := Unit;
652 Error_Msg
653 (Data.Flags,
654 "unit %% cannot belong to several projects",
655 Location, Project);
657 Error_Msg_Name_1 := Project.Name;
658 Error_Msg_Name_2 := Name_Id (Path.Display_Name);
659 Error_Msg
662 Error_Msg_Name_1 := Source.Project.Name;
663 Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name);
664 Error_Msg
667 else
668 Error_Msg_Name_1 := Unit;
669 Error_Msg_Name_2 := Source.Project.Name;
670 Error_Msg
671 (Data.Flags, "unit %% already belongs to project %%",
672 Location, Project);
673 end if;
675 Add_Src := False;
677 elsif not Source.Locally_Removed
678 and then not Data.Flags.Allow_Duplicate_Basenames
679 and then Lang_Id.Config.Kind = Unit_Based
680 then
681 Error_Msg_File_1 := File_Name;
682 Error_Msg_File_2 := File_Name_Type (Source.Project.Name);
683 Error_Msg
684 (Data.Flags,
685 "{ is already a source of project {", Location, Project);
687 -- Add the file anyway, to avoid further warnings like "language
688 -- unknown".
690 Add_Src := True;
691 end if;
692 end if;
694 if not Add_Src then
695 return;
696 end if;
698 -- Add the new file
700 Id := new Source_Data;
702 if Current_Verbosity = High then
703 Write_Str ("Adding source File: ");
704 Write_Str (Get_Name_String (File_Name));
706 if Index /= 0 then
707 Write_Str (" at" & Index'Img);
708 end if;
710 if Lang_Id.Config.Kind = Unit_Based then
711 Write_Str (" Unit: ");
713 -- ??? in gprclean, it seems we sometimes pass an empty Unit name
714 -- (see test extended_projects).
716 if Unit /= No_Name then
717 Write_Str (Get_Name_String (Unit));
718 end if;
720 Write_Str (" Kind: ");
721 Write_Str (Source_Kind'Image (Kind));
722 end if;
724 Write_Eol;
725 end if;
727 Id.Project := Project;
728 Id.Source_Dir_Rank := Source_Dir_Rank;
729 Id.Language := Lang_Id;
730 Id.Kind := Kind;
731 Id.Alternate_Languages := Alternate_Languages;
732 Id.Locally_Removed := Locally_Removed;
733 Id.Index := Index;
734 Id.File := File_Name;
735 Id.Display_File := Display_File;
736 Id.Dep_Name := Dependency_Name
737 (File_Name, Lang_Id.Config.Dependency_Kind);
738 Id.Naming_Exception := Naming_Exception;
740 -- Add the source id to the Unit_Sources_HT hash table, if the unit name
741 -- is not null.
743 if Unit /= No_Name then
745 -- Note: we might be creating a dummy unit here, when we in fact have
746 -- a separate. For instance, file file-bar.adb will initially be
747 -- assumed to be the IMPL of unit "file.bar". Only later on (in
748 -- Check_Object_Files) will we parse those units that only have an
749 -- impl and no spec to make sure whether we have a Separate in fact
750 -- (that significantly reduces the number of times we need to parse
751 -- the files, since we are then only interested in those with no
752 -- spec). We still need those dummy units in the table, since that's
753 -- the name we find in the ALI file
755 UData := Units_Htable.Get (Data.Tree.Units_HT, Unit);
757 if UData = No_Unit_Index then
758 UData := new Unit_Data;
759 UData.Name := Unit;
760 Units_Htable.Set (Data.Tree.Units_HT, Unit, UData);
761 end if;
763 Id.Unit := UData;
765 -- Note that this updates Unit information as well
767 Override_Kind (Id, Kind);
768 end if;
770 if Is_Compilable (Id) and then Config.Object_Generated then
771 Id.Object := Object_Name (File_Name, Config.Object_File_Suffix);
772 Id.Switches := Switches_Name (File_Name);
773 end if;
775 if Path /= No_Path_Information then
776 Id.Path := Path;
777 Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path.Name, Id);
778 end if;
780 if Index /= 0 then
781 Project.Has_Multi_Unit_Sources := True;
782 end if;
784 -- Add the source to the language list
786 Id.Next_In_Lang := Lang_Id.First_Source;
787 Lang_Id.First_Source := Id;
789 if Source_To_Replace /= No_Source then
790 Remove_Source (Source_To_Replace, Id);
791 end if;
793 Files_Htable.Set (Data.File_To_Source, File_Name, Id);
794 end Add_Source;
796 ------------------------------
797 -- Canonical_Case_File_Name --
798 ------------------------------
800 function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type is
801 begin
802 if Osint.File_Names_Case_Sensitive then
803 return File_Name_Type (Name);
804 else
805 Get_Name_String (Name);
806 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
807 return Name_Find;
808 end if;
809 end Canonical_Case_File_Name;
811 -----------
812 -- Check --
813 -----------
815 procedure Check
816 (Project : Project_Id;
817 Data : in out Tree_Processing_Data)
818 is
819 Specs : Array_Element_Id;
820 Bodies : Array_Element_Id;
821 Extending : Boolean := False;
822 Prj_Data : Project_Processing_Data;
824 begin
825 Initialize (Prj_Data, Project);
827 Check_If_Externally_Built (Project, Data);
829 -- Object, exec and source directories
831 Get_Directories (Project, Data);
833 -- Get the programming languages
835 Check_Programming_Languages (Project, Data);
837 if Project.Qualifier = Dry
838 and then Project.Source_Dirs /= Nil_String
839 then
840 declare
841 Source_Dirs : constant Variable_Value :=
842 Util.Value_Of
843 (Name_Source_Dirs,
844 Project.Decl.Attributes, Data.Tree);
845 Source_Files : constant Variable_Value :=
846 Util.Value_Of
847 (Name_Source_Files,
848 Project.Decl.Attributes, Data.Tree);
849 Source_List_File : constant Variable_Value :=
850 Util.Value_Of
851 (Name_Source_List_File,
852 Project.Decl.Attributes, Data.Tree);
853 Languages : constant Variable_Value :=
854 Util.Value_Of
855 (Name_Languages,
856 Project.Decl.Attributes, Data.Tree);
858 begin
859 if Source_Dirs.Values = Nil_String
860 and then Source_Files.Values = Nil_String
861 and then Languages.Values = Nil_String
862 and then Source_List_File.Default
863 then
864 Project.Source_Dirs := Nil_String;
866 else
867 Error_Msg
868 (Data.Flags,
869 "at least one of Source_Files, Source_Dirs or Languages "
870 & "must be declared empty for an abstract project",
871 Project.Location, Project);
872 end if;
873 end;
874 end if;
876 -- Check configuration. This must be done even for gnatmake (even though
877 -- no user configuration file was provided) since the default config we
878 -- generate indicates whether libraries are supported for instance.
880 Check_Configuration (Project, Data);
882 -- Library attributes
884 Check_Library_Attributes (Project, Data);
886 if Current_Verbosity = High then
887 Show_Source_Dirs (Project, Data.Tree);
888 end if;
890 Extending := Project.Extends /= No_Project;
892 Check_Package_Naming (Project, Data, Bodies => Bodies, Specs => Specs);
894 -- Find the sources
896 if Project.Source_Dirs /= Nil_String then
897 Look_For_Sources (Prj_Data, Data);
899 if not Project.Externally_Built
900 and then not Extending
901 then
902 declare
903 Language : Language_Ptr;
904 Source : Source_Id;
905 Alt_Lang : Language_List;
906 Continuation : Boolean := False;
907 Iter : Source_Iterator;
909 begin
910 Language := Project.Languages;
911 while Language /= No_Language_Index loop
913 -- If there are no sources for this language, check if there
914 -- are sources for which this is an alternate language.
916 if Language.First_Source = No_Source
917 and then (Data.Flags.Require_Sources_Other_Lang
918 or else Language.Name = Name_Ada)
919 then
920 Iter := For_Each_Source (In_Tree => Data.Tree,
921 Project => Project);
922 Source_Loop : loop
923 Source := Element (Iter);
924 exit Source_Loop when Source = No_Source
925 or else Source.Language = Language;
927 Alt_Lang := Source.Alternate_Languages;
928 while Alt_Lang /= null loop
929 exit Source_Loop when Alt_Lang.Language = Language;
930 Alt_Lang := Alt_Lang.Next;
931 end loop;
933 Next (Iter);
934 end loop Source_Loop;
936 if Source = No_Source then
938 Report_No_Sources
939 (Project,
940 Get_Name_String (Language.Display_Name),
941 Data,
942 Prj_Data.Source_List_File_Location,
943 Continuation);
944 Continuation := True;
945 end if;
946 end if;
948 Language := Language.Next;
949 end loop;
950 end;
951 end if;
952 end if;
954 -- If a list of sources is specified in attribute Interfaces, set
955 -- In_Interfaces only for the sources specified in the list.
957 Check_Interfaces (Project, Data);
959 -- If it is a library project file, check if it is a standalone library
961 if Project.Library then
962 Check_Stand_Alone_Library (Project, Data);
963 end if;
965 -- Put the list of Mains, if any, in the project data
967 Get_Mains (Project, Data);
969 Free (Prj_Data);
970 end Check;
972 --------------------
973 -- Check_Ada_Name --
974 --------------------
976 procedure Check_Ada_Name (Name : String; Unit : out Name_Id) is
977 The_Name : String := Name;
978 Real_Name : Name_Id;
979 Need_Letter : Boolean := True;
980 Last_Underscore : Boolean := False;
981 OK : Boolean := The_Name'Length > 0;
982 First : Positive;
984 function Is_Reserved (Name : Name_Id) return Boolean;
985 function Is_Reserved (S : String) return Boolean;
986 -- Check that the given name is not an Ada 95 reserved word. The reason
987 -- for the Ada 95 here is that we do not want to exclude the case of an
988 -- Ada 95 unit called Interface (for example). In Ada 2005, such a unit
989 -- name would be rejected anyway by the compiler. That means there is no
990 -- requirement that the project file parser reject this.
992 -----------------
993 -- Is_Reserved --
994 -----------------
996 function Is_Reserved (S : String) return Boolean is
997 begin
998 Name_Len := 0;
999 Add_Str_To_Name_Buffer (S);
1000 return Is_Reserved (Name_Find);
1001 end Is_Reserved;
1003 -----------------
1004 -- Is_Reserved --
1005 -----------------
1007 function Is_Reserved (Name : Name_Id) return Boolean is
1008 begin
1009 if Get_Name_Table_Byte (Name) /= 0
1010 and then Name /= Name_Project
1011 and then Name /= Name_Extends
1012 and then Name /= Name_External
1013 and then Name not in Ada_2005_Reserved_Words
1014 then
1015 Unit := No_Name;
1017 if Current_Verbosity = High then
1018 Write_Str (The_Name);
1019 Write_Line (" is an Ada reserved word.");
1020 end if;
1022 return True;
1024 else
1025 return False;
1026 end if;
1027 end Is_Reserved;
1029 -- Start of processing for Check_Ada_Name
1031 begin
1032 To_Lower (The_Name);
1034 Name_Len := The_Name'Length;
1035 Name_Buffer (1 .. Name_Len) := The_Name;
1037 -- Special cases of children of packages A, G, I and S on VMS
1039 if OpenVMS_On_Target
1040 and then Name_Len > 3
1041 and then Name_Buffer (2 .. 3) = "__"
1042 and then
1047 then
1049 Name_Buffer (3 .. Name_Len - 1) := Name_Buffer (4 .. Name_Len);
1050 Name_Len := Name_Len - 1;
1051 end if;
1053 Real_Name := Name_Find;
1055 if Is_Reserved (Real_Name) then
1056 return;
1057 end if;
1059 First := The_Name'First;
1061 for Index in The_Name'Range loop
1062 if Need_Letter then
1064 -- We need a letter (at the beginning, and following a dot),
1065 -- but we don't have one.
1067 if Is_Letter (The_Name (Index)) then
1068 Need_Letter := False;
1070 else
1071 OK := False;
1073 if Current_Verbosity = High then
1074 Write_Int (Types.Int (Index));
1076 Write_Char (The_Name (Index));
1078 end if;
1080 exit;
1081 end if;
1083 elsif Last_Underscore
1085 then
1086 -- Two underscores are illegal, and a dot cannot follow
1087 -- an underscore.
1089 OK := False;
1091 if Current_Verbosity = High then
1092 Write_Int (Types.Int (Index));
1094 Write_Char (The_Name (Index));
1096 end if;
1098 exit;
1102 -- First, check if the name before the dot is not a reserved word
1104 if Is_Reserved (The_Name (First .. Index - 1)) then
1105 return;
1106 end if;
1108 First := Index + 1;
1110 -- We need a letter after a dot
1112 Need_Letter := True;
1115 Last_Underscore := True;
1117 else
1118 -- We need an letter or a digit
1120 Last_Underscore := False;
1122 if not Is_Alphanumeric (The_Name (Index)) then
1123 OK := False;
1125 if Current_Verbosity = High then
1126 Write_Int (Types.Int (Index));
1128 Write_Char (The_Name (Index));
1130 end if;
1132 exit;
1133 end if;
1134 end if;
1135 end loop;
1137 -- Cannot end with an underscore or a dot
1139 OK := OK and then not Need_Letter and then not Last_Underscore;
1141 if OK then
1142 if First /= Name'First and then
1143 Is_Reserved (The_Name (First .. The_Name'Last))
1144 then
1145 return;
1146 end if;
1148 Unit := Real_Name;
1150 else
1151 -- Signal a problem with No_Name
1153 Unit := No_Name;
1154 end if;
1155 end Check_Ada_Name;
1157 -------------------------
1158 -- Check_Configuration --
1159 -------------------------
1161 procedure Check_Configuration
1162 (Project : Project_Id;
1163 Data : in out Tree_Processing_Data)
1164 is
1165 Dot_Replacement : File_Name_Type := No_File;
1166 Casing : Casing_Type := All_Lower_Case;
1167 Separate_Suffix : File_Name_Type := No_File;
1169 Lang_Index : Language_Ptr := No_Language_Index;
1170 -- The index of the language data being checked
1172 Prev_Index : Language_Ptr := No_Language_Index;
1173 -- The index of the previous language
1175 procedure Process_Project_Level_Simple_Attributes;
1176 -- Process the simple attributes at the project level
1178 procedure Process_Project_Level_Array_Attributes;
1179 -- Process the associate array attributes at the project level
1181 procedure Process_Packages;
1182 -- Read the packages of the project
1184 ----------------------
1185 -- Process_Packages --
1186 ----------------------
1188 procedure Process_Packages is
1189 Packages : Package_Id;
1190 Element : Package_Element;
1192 procedure Process_Binder (Arrays : Array_Id);
1193 -- Process the associate array attributes of package Binder
1195 procedure Process_Builder (Attributes : Variable_Id);
1196 -- Process the simple attributes of package Builder
1198 procedure Process_Compiler (Arrays : Array_Id);
1199 -- Process the associate array attributes of package Compiler
1201 procedure Process_Naming (Attributes : Variable_Id);
1202 -- Process the simple attributes of package Naming
1204 procedure Process_Naming (Arrays : Array_Id);
1205 -- Process the associate array attributes of package Naming
1207 procedure Process_Linker (Attributes : Variable_Id);
1208 -- Process the simple attributes of package Linker of a
1209 -- configuration project.
1211 --------------------
1212 -- Process_Binder --
1213 --------------------
1215 procedure Process_Binder (Arrays : Array_Id) is
1216 Current_Array_Id : Array_Id;
1217 Current_Array : Array_Data;
1218 Element_Id : Array_Element_Id;
1219 Element : Array_Element;
1221 begin
1222 -- Process the associative array attribute of package Binder
1224 Current_Array_Id := Arrays;
1225 while Current_Array_Id /= No_Array loop
1226 Current_Array := Data.Tree.Arrays.Table (Current_Array_Id);
1228 Element_Id := Current_Array.Value;
1229 while Element_Id /= No_Array_Element loop
1230 Element := Data.Tree.Array_Elements.Table (Element_Id);
1232 if Element.Index /= All_Other_Names then
1234 -- Get the name of the language
1236 Lang_Index :=
1237 Get_Language_From_Name
1238 (Project, Get_Name_String (Element.Index));
1240 if Lang_Index /= No_Language_Index then
1241 case Current_Array.Name is
1242 when Name_Driver =>
1244 -- Attribute Driver (<language>)
1246 Lang_Index.Config.Binder_Driver :=
1247 File_Name_Type (Element.Value.Value);
1249 when Name_Required_Switches =>
1250 Put
1251 (Into_List =>
1252 Lang_Index.Config.Binder_Required_Switches,
1253 From_List => Element.Value.Values,
1254 In_Tree => Data.Tree);
1256 when Name_Prefix =>
1258 -- Attribute Prefix (<language>)
1260 Lang_Index.Config.Binder_Prefix :=
1261 Element.Value.Value;
1263 when Name_Objects_Path =>
1265 -- Attribute Objects_Path (<language>)
1267 Lang_Index.Config.Objects_Path :=
1268 Element.Value.Value;
1270 when Name_Objects_Path_File =>
1272 -- Attribute Objects_Path (<language>)
1274 Lang_Index.Config.Objects_Path_File :=
1275 Element.Value.Value;
1277 when others =>
1278 null;
1279 end case;
1280 end if;
1281 end if;
1283 Element_Id := Element.Next;
1284 end loop;
1286 Current_Array_Id := Current_Array.Next;
1287 end loop;
1288 end Process_Binder;
1290 ---------------------
1291 -- Process_Builder --
1292 ---------------------
1294 procedure Process_Builder (Attributes : Variable_Id) is
1295 Attribute_Id : Variable_Id;
1296 Attribute : Variable;
1298 begin
1299 -- Process non associated array attribute from package Builder
1301 Attribute_Id := Attributes;
1302 while Attribute_Id /= No_Variable loop
1303 Attribute :=
1304 Data.Tree.Variable_Elements.Table (Attribute_Id);
1306 if not Attribute.Value.Default then
1307 if Attribute.Name = Name_Executable_Suffix then
1309 -- Attribute Executable_Suffix: the suffix of the
1310 -- executables.
1312 Project.Config.Executable_Suffix :=
1313 Attribute.Value.Value;
1314 end if;
1315 end if;
1317 Attribute_Id := Attribute.Next;
1318 end loop;
1319 end Process_Builder;
1321 ----------------------
1322 -- Process_Compiler --
1323 ----------------------
1325 procedure Process_Compiler (Arrays : Array_Id) is
1326 Current_Array_Id : Array_Id;
1327 Current_Array : Array_Data;
1328 Element_Id : Array_Element_Id;
1329 Element : Array_Element;
1330 List : String_List_Id;
1332 begin
1333 -- Process the associative array attribute of package Compiler
1335 Current_Array_Id := Arrays;
1336 while Current_Array_Id /= No_Array loop
1337 Current_Array := Data.Tree.Arrays.Table (Current_Array_Id);
1339 Element_Id := Current_Array.Value;
1340 while Element_Id /= No_Array_Element loop
1341 Element := Data.Tree.Array_Elements.Table (Element_Id);
1343 if Element.Index /= All_Other_Names then
1345 -- Get the name of the language
1347 Lang_Index := Get_Language_From_Name
1348 (Project, Get_Name_String (Element.Index));
1350 if Lang_Index /= No_Language_Index then
1351 case Current_Array.Name is
1352 when Name_Dependency_Switches =>
1354 -- Attribute Dependency_Switches (<language>)
1356 if Lang_Index.Config.Dependency_Kind = None then
1357 Lang_Index.Config.Dependency_Kind := Makefile;
1358 end if;
1360 List := Element.Value.Values;
1362 if List /= Nil_String then
1363 Put (Into_List =>
1364 Lang_Index.Config.Dependency_Option,
1365 From_List => List,
1366 In_Tree => Data.Tree);
1367 end if;
1369 when Name_Dependency_Driver =>
1371 -- Attribute Dependency_Driver (<language>)
1373 if Lang_Index.Config.Dependency_Kind = None then
1374 Lang_Index.Config.Dependency_Kind := Makefile;
1375 end if;
1377 List := Element.Value.Values;
1379 if List /= Nil_String then
1380 Put (Into_List =>
1381 Lang_Index.Config.Compute_Dependency,
1382 From_List => List,
1383 In_Tree => Data.Tree);
1384 end if;
1386 when Name_Include_Switches =>
1388 -- Attribute Include_Switches (<language>)
1390 List := Element.Value.Values;
1392 if List = Nil_String then
1393 Error_Msg
1394 (Data.Flags, "include option cannot be null",
1395 Element.Value.Location, Project);
1396 end if;
1398 Put (Into_List => Lang_Index.Config.Include_Option,
1399 From_List => List,
1400 In_Tree => Data.Tree);
1402 when Name_Include_Path =>
1404 -- Attribute Include_Path (<language>)
1406 Lang_Index.Config.Include_Path :=
1407 Element.Value.Value;
1409 when Name_Include_Path_File =>
1411 -- Attribute Include_Path_File (<language>)
1413 Lang_Index.Config.Include_Path_File :=
1414 Element.Value.Value;
1416 when Name_Driver =>
1418 -- Attribute Driver (<language>)
1420 Lang_Index.Config.Compiler_Driver :=
1421 File_Name_Type (Element.Value.Value);
1423 when Name_Required_Switches |
1424 Name_Leading_Required_Switches =>
1425 Put (Into_List =>
1426 Lang_Index.Config.
1427 Compiler_Leading_Required_Switches,
1428 From_List => Element.Value.Values,
1429 In_Tree => Data.Tree);
1431 when Name_Trailing_Required_Switches =>
1432 Put (Into_List =>
1433 Lang_Index.Config.
1434 Compiler_Trailing_Required_Switches,
1435 From_List => Element.Value.Values,
1436 In_Tree => Data.Tree);
1438 when Name_Multi_Unit_Switches =>
1439 Put (Into_List =>
1440 Lang_Index.Config.Multi_Unit_Switches,
1441 From_List => Element.Value.Values,
1442 In_Tree => Data.Tree);
1444 when Name_Multi_Unit_Object_Separator =>
1445 Get_Name_String (Element.Value.Value);
1447 if Name_Len /= 1 then
1448 Error_Msg
1449 (Data.Flags,
1450 "multi-unit object separator must have " &
1451 "a single character",
1452 Element.Value.Location, Project);
1455 Error_Msg
1456 (Data.Flags,
1457 "multi-unit object separator cannot be " &
1458 "a space",
1459 Element.Value.Location, Project);
1461 else
1462 Lang_Index.Config.Multi_Unit_Object_Separator :=
1463 Name_Buffer (1);
1464 end if;
1466 when Name_Path_Syntax =>
1467 begin
1468 Lang_Index.Config.Path_Syntax :=
1469 Path_Syntax_Kind'Value
1470 (Get_Name_String (Element.Value.Value));
1472 exception
1473 when Constraint_Error =>
1474 Error_Msg
1475 (Data.Flags,
1476 "invalid value for Path_Syntax",
1477 Element.Value.Location, Project);
1478 end;
1480 when Name_Object_File_Suffix =>
1481 if Get_Name_String (Element.Value.Value) = "" then
1482 Error_Msg
1483 (Data.Flags,
1484 "object file suffix cannot be empty",
1485 Element.Value.Location, Project);
1487 else
1488 Lang_Index.Config.Object_File_Suffix :=
1489 Element.Value.Value;
1490 end if;
1492 when Name_Object_File_Switches =>
1493 Put (Into_List =>
1494 Lang_Index.Config.Object_File_Switches,
1495 From_List => Element.Value.Values,
1496 In_Tree => Data.Tree);
1498 when Name_Pic_Option =>
1500 -- Attribute Compiler_Pic_Option (<language>)
1502 List := Element.Value.Values;
1504 if List = Nil_String then
1505 Error_Msg
1506 (Data.Flags,
1507 "compiler PIC option cannot be null",
1508 Element.Value.Location, Project);
1509 end if;
1511 Put (Into_List =>
1512 Lang_Index.Config.Compilation_PIC_Option,
1513 From_List => List,
1514 In_Tree => Data.Tree);
1516 when Name_Mapping_File_Switches =>
1518 -- Attribute Mapping_File_Switches (<language>)
1520 List := Element.Value.Values;
1522 if List = Nil_String then
1523 Error_Msg
1524 (Data.Flags,
1525 "mapping file switches cannot be null",
1526 Element.Value.Location, Project);
1527 end if;
1529 Put (Into_List =>
1530 Lang_Index.Config.Mapping_File_Switches,
1531 From_List => List,
1532 In_Tree => Data.Tree);
1534 when Name_Mapping_Spec_Suffix =>
1536 -- Attribute Mapping_Spec_Suffix (<language>)
1538 Lang_Index.Config.Mapping_Spec_Suffix :=
1539 File_Name_Type (Element.Value.Value);
1541 when Name_Mapping_Body_Suffix =>
1543 -- Attribute Mapping_Body_Suffix (<language>)
1545 Lang_Index.Config.Mapping_Body_Suffix :=
1546 File_Name_Type (Element.Value.Value);
1548 when Name_Config_File_Switches =>
1550 -- Attribute Config_File_Switches (<language>)
1552 List := Element.Value.Values;
1554 if List = Nil_String then
1555 Error_Msg
1556 (Data.Flags,
1557 "config file switches cannot be null",
1558 Element.Value.Location, Project);
1559 end if;
1561 Put (Into_List =>
1562 Lang_Index.Config.Config_File_Switches,
1563 From_List => List,
1564 In_Tree => Data.Tree);
1566 when Name_Objects_Path =>
1568 -- Attribute Objects_Path (<language>)
1570 Lang_Index.Config.Objects_Path :=
1571 Element.Value.Value;
1573 when Name_Objects_Path_File =>
1575 -- Attribute Objects_Path_File (<language>)
1577 Lang_Index.Config.Objects_Path_File :=
1578 Element.Value.Value;
1580 when Name_Config_Body_File_Name =>
1582 -- Attribute Config_Body_File_Name (<language>)
1584 Lang_Index.Config.Config_Body :=
1585 Element.Value.Value;
1587 when Name_Config_Body_File_Name_Index =>
1589 -- Attribute Config_Body_File_Name_Index
1590 -- ( < Language > )
1592 Lang_Index.Config.Config_Body_Index :=
1593 Element.Value.Value;
1595 when Name_Config_Body_File_Name_Pattern =>
1597 -- Attribute Config_Body_File_Name_Pattern
1598 -- (<language>)
1600 Lang_Index.Config.Config_Body_Pattern :=
1601 Element.Value.Value;
1603 when Name_Config_Spec_File_Name =>
1605 -- Attribute Config_Spec_File_Name (<language>)
1607 Lang_Index.Config.Config_Spec :=
1608 Element.Value.Value;
1610 when Name_Config_Spec_File_Name_Index =>
1612 -- Attribute Config_Spec_File_Name_Index
1613 -- ( < Language > )
1615 Lang_Index.Config.Config_Spec_Index :=
1616 Element.Value.Value;
1618 when Name_Config_Spec_File_Name_Pattern =>
1620 -- Attribute Config_Spec_File_Name_Pattern
1621 -- (<language>)
1623 Lang_Index.Config.Config_Spec_Pattern :=
1624 Element.Value.Value;
1626 when Name_Config_File_Unique =>
1628 -- Attribute Config_File_Unique (<language>)
1630 begin
1631 Lang_Index.Config.Config_File_Unique :=
1632 Boolean'Value
1633 (Get_Name_String (Element.Value.Value));
1634 exception
1635 when Constraint_Error =>
1636 Error_Msg
1637 (Data.Flags,
1638 "illegal value for Config_File_Unique",
1639 Element.Value.Location, Project);
1640 end;
1642 when others =>
1643 null;
1644 end case;
1645 end if;
1646 end if;
1648 Element_Id := Element.Next;
1649 end loop;
1651 Current_Array_Id := Current_Array.Next;
1652 end loop;
1653 end Process_Compiler;
1655 --------------------
1656 -- Process_Naming --
1657 --------------------
1659 procedure Process_Naming (Attributes : Variable_Id) is
1660 Attribute_Id : Variable_Id;
1661 Attribute : Variable;
1663 begin
1664 -- Process non associated array attribute from package Naming
1666 Attribute_Id := Attributes;
1667 while Attribute_Id /= No_Variable loop
1668 Attribute := Data.Tree.Variable_Elements.Table (Attribute_Id);
1670 if not Attribute.Value.Default then
1671 if Attribute.Name = Name_Separate_Suffix then
1673 -- Attribute Separate_Suffix
1675 Get_Name_String (Attribute.Value.Value);
1676 Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1677 Separate_Suffix := Name_Find;
1679 elsif Attribute.Name = Name_Casing then
1681 -- Attribute Casing
1683 begin
1684 Casing :=
1685 Value (Get_Name_String (Attribute.Value.Value));
1687 exception
1688 when Constraint_Error =>
1689 Error_Msg
1690 (Data.Flags,
1691 "invalid value for Casing",
1692 Attribute.Value.Location, Project);
1693 end;
1695 elsif Attribute.Name = Name_Dot_Replacement then
1697 -- Attribute Dot_Replacement
1699 Dot_Replacement := File_Name_Type (Attribute.Value.Value);
1701 end if;
1702 end if;
1704 Attribute_Id := Attribute.Next;
1705 end loop;
1706 end Process_Naming;
1708 procedure Process_Naming (Arrays : Array_Id) is
1709 Current_Array_Id : Array_Id;
1710 Current_Array : Array_Data;
1711 Element_Id : Array_Element_Id;
1712 Element : Array_Element;
1714 begin
1715 -- Process the associative array attribute of package Naming
1717 Current_Array_Id := Arrays;
1718 while Current_Array_Id /= No_Array loop
1719 Current_Array := Data.Tree.Arrays.Table (Current_Array_Id);
1721 Element_Id := Current_Array.Value;
1722 while Element_Id /= No_Array_Element loop
1723 Element := Data.Tree.Array_Elements.Table (Element_Id);
1725 -- Get the name of the language
1727 Lang_Index := Get_Language_From_Name
1728 (Project, Get_Name_String (Element.Index));
1730 if Lang_Index /= No_Language_Index then
1731 case Current_Array.Name is
1732 when Name_Spec_Suffix | Name_Specification_Suffix =>
1734 -- Attribute Spec_Suffix (<language>)
1736 Get_Name_String (Element.Value.Value);
1737 Canonical_Case_File_Name
1738 (Name_Buffer (1 .. Name_Len));
1739 Lang_Index.Config.Naming_Data.Spec_Suffix :=
1740 Name_Find;
1742 when Name_Implementation_Suffix | Name_Body_Suffix =>
1744 Get_Name_String (Element.Value.Value);
1745 Canonical_Case_File_Name
1746 (Name_Buffer (1 .. Name_Len));
1748 -- Attribute Body_Suffix (<language>)
1750 Lang_Index.Config.Naming_Data.Body_Suffix :=
1751 Name_Find;
1752 Lang_Index.Config.Naming_Data.Separate_Suffix :=
1753 Lang_Index.Config.Naming_Data.Body_Suffix;
1755 when others =>
1756 null;
1757 end case;
1758 end if;
1760 Element_Id := Element.Next;
1761 end loop;
1763 Current_Array_Id := Current_Array.Next;
1764 end loop;
1765 end Process_Naming;
1767 --------------------
1768 -- Process_Linker --
1769 --------------------
1771 procedure Process_Linker (Attributes : Variable_Id) is
1772 Attribute_Id : Variable_Id;
1773 Attribute : Variable;
1775 begin
1776 -- Process non associated array attribute from package Linker
1778 Attribute_Id := Attributes;
1779 while Attribute_Id /= No_Variable loop
1780 Attribute :=
1781 Data.Tree.Variable_Elements.Table (Attribute_Id);
1783 if not Attribute.Value.Default then
1784 if Attribute.Name = Name_Driver then
1786 -- Attribute Linker'Driver: the default linker to use
1788 Project.Config.Linker :=
1789 Path_Name_Type (Attribute.Value.Value);
1791 -- Linker'Driver is also used to link shared libraries
1792 -- if the obsolescent attribute Library_GCC has not been
1793 -- specified.
1795 if Project.Config.Shared_Lib_Driver = No_File then
1796 Project.Config.Shared_Lib_Driver :=
1797 File_Name_Type (Attribute.Value.Value);
1798 end if;
1800 elsif Attribute.Name = Name_Required_Switches then
1802 -- Attribute Required_Switches: the minimum
1803 -- options to use when invoking the linker
1805 Put (Into_List => Project.Config.Minimum_Linker_Options,
1806 From_List => Attribute.Value.Values,
1807 In_Tree => Data.Tree);
1809 elsif Attribute.Name = Name_Map_File_Option then
1810 Project.Config.Map_File_Option := Attribute.Value.Value;
1812 elsif Attribute.Name = Name_Max_Command_Line_Length then
1813 begin
1814 Project.Config.Max_Command_Line_Length :=
1815 Natural'Value (Get_Name_String
1816 (Attribute.Value.Value));
1818 exception
1819 when Constraint_Error =>
1820 Error_Msg
1821 (Data.Flags,
1822 "value must be positive or equal to 0",
1823 Attribute.Value.Location, Project);
1824 end;
1826 elsif Attribute.Name = Name_Response_File_Format then
1827 declare
1828 Name : Name_Id;
1830 begin
1831 Get_Name_String (Attribute.Value.Value);
1832 To_Lower (Name_Buffer (1 .. Name_Len));
1833 Name := Name_Find;
1835 if Name = Name_None then
1836 Project.Config.Resp_File_Format := None;
1838 elsif Name = Name_Gnu then
1839 Project.Config.Resp_File_Format := GNU;
1841 elsif Name = Name_Object_List then
1842 Project.Config.Resp_File_Format := Object_List;
1844 elsif Name = Name_Option_List then
1845 Project.Config.Resp_File_Format := Option_List;
1847 else
1848 Error_Msg
1849 (Data.Flags,
1850 "illegal response file format",
1851 Attribute.Value.Location, Project);
1852 end if;
1853 end;
1855 elsif Attribute.Name = Name_Response_File_Switches then
1856 Put (Into_List => Project.Config.Resp_File_Options,
1857 From_List => Attribute.Value.Values,
1858 In_Tree => Data.Tree);
1859 end if;
1860 end if;
1862 Attribute_Id := Attribute.Next;
1863 end loop;
1864 end Process_Linker;
1866 -- Start of processing for Process_Packages
1868 begin
1869 Packages := Project.Decl.Packages;
1870 while Packages /= No_Package loop
1871 Element := Data.Tree.Packages.Table (Packages);
1873 case Element.Name is
1874 when Name_Binder =>
1876 -- Process attributes of package Binder
1878 Process_Binder (Element.Decl.Arrays);
1880 when Name_Builder =>
1882 -- Process attributes of package Builder
1884 Process_Builder (Element.Decl.Attributes);
1886 when Name_Compiler =>
1888 -- Process attributes of package Compiler
1890 Process_Compiler (Element.Decl.Arrays);
1892 when Name_Linker =>
1894 -- Process attributes of package Linker
1896 Process_Linker (Element.Decl.Attributes);
1898 when Name_Naming =>
1900 -- Process attributes of package Naming
1902 Process_Naming (Element.Decl.Attributes);
1903 Process_Naming (Element.Decl.Arrays);
1905 when others =>
1906 null;
1907 end case;
1909 Packages := Element.Next;
1910 end loop;
1911 end Process_Packages;
1913 ---------------------------------------------
1914 -- Process_Project_Level_Simple_Attributes --
1915 ---------------------------------------------
1917 procedure Process_Project_Level_Simple_Attributes is
1918 Attribute_Id : Variable_Id;
1919 Attribute : Variable;
1920 List : String_List_Id;
1922 begin
1923 -- Process non associated array attribute at project level
1925 Attribute_Id := Project.Decl.Attributes;
1926 while Attribute_Id /= No_Variable loop
1927 Attribute :=
1928 Data.Tree.Variable_Elements.Table (Attribute_Id);
1930 if not Attribute.Value.Default then
1931 if Attribute.Name = Name_Target then
1933 -- Attribute Target: the target specified
1935 Project.Config.Target := Attribute.Value.Value;
1937 elsif Attribute.Name = Name_Library_Builder then
1939 -- Attribute Library_Builder: the application to invoke
1940 -- to build libraries.
1942 Project.Config.Library_Builder :=
1943 Path_Name_Type (Attribute.Value.Value);
1945 elsif Attribute.Name = Name_Archive_Builder then
1947 -- Attribute Archive_Builder: the archive builder
1948 -- (usually "ar") and its minimum options (usually "cr").
1950 List := Attribute.Value.Values;
1952 if List = Nil_String then
1953 Error_Msg
1954 (Data.Flags,
1955 "archive builder cannot be null",
1956 Attribute.Value.Location, Project);
1957 end if;
1959 Put (Into_List => Project.Config.Archive_Builder,
1960 From_List => List,
1961 In_Tree => Data.Tree);
1963 elsif Attribute.Name = Name_Archive_Builder_Append_Option then
1965 -- Attribute Archive_Builder: the archive builder
1966 -- (usually "ar") and its minimum options (usually "cr").
1968 List := Attribute.Value.Values;
1970 if List /= Nil_String then
1971 Put
1972 (Into_List =>
1973 Project.Config.Archive_Builder_Append_Option,
1974 From_List => List,
1975 In_Tree => Data.Tree);
1976 end if;
1978 elsif Attribute.Name = Name_Archive_Indexer then
1980 -- Attribute Archive_Indexer: the optional archive
1981 -- indexer (usually "ranlib") with its minimum options
1982 -- (usually none).
1984 List := Attribute.Value.Values;
1986 if List = Nil_String then
1987 Error_Msg
1988 (Data.Flags,
1989 "archive indexer cannot be null",
1990 Attribute.Value.Location, Project);
1991 end if;
1993 Put (Into_List => Project.Config.Archive_Indexer,
1994 From_List => List,
1995 In_Tree => Data.Tree);
1997 elsif Attribute.Name = Name_Library_Partial_Linker then
1999 -- Attribute Library_Partial_Linker: the optional linker
2000 -- driver with its minimum options, to partially link
2001 -- archives.
2003 List := Attribute.Value.Values;
2005 if List = Nil_String then
2006 Error_Msg
2007 (Data.Flags,
2008 "partial linker cannot be null",
2009 Attribute.Value.Location, Project);
2010 end if;
2012 Put (Into_List => Project.Config.Lib_Partial_Linker,
2013 From_List => List,
2014 In_Tree => Data.Tree);
2016 elsif Attribute.Name = Name_Library_GCC then
2017 Project.Config.Shared_Lib_Driver :=
2018 File_Name_Type (Attribute.Value.Value);
2019 Error_Msg
2020 (Data.Flags,
2023 Attribute.Value.Location, Project);
2025 elsif Attribute.Name = Name_Archive_Suffix then
2026 Project.Config.Archive_Suffix :=
2027 File_Name_Type (Attribute.Value.Value);
2029 elsif Attribute.Name = Name_Linker_Executable_Option then
2031 -- Attribute Linker_Executable_Option: optional options
2034 List := Attribute.Value.Values;
2036 if List = Nil_String then
2037 Error_Msg
2038 (Data.Flags,
2040 Attribute.Value.Location, Project);
2041 end if;
2043 Put (Into_List => Project.Config.Linker_Executable_Option,
2044 From_List => List,
2045 In_Tree => Data.Tree);
2047 elsif Attribute.Name = Name_Linker_Lib_Dir_Option then
2049 -- Attribute Linker_Lib_Dir_Option: optional options
2050 -- to specify a library search directory. Defaults to
2053 Get_Name_String (Attribute.Value.Value);
2055 if Name_Len = 0 then
2056 Error_Msg
2057 (Data.Flags,
2059 Attribute.Value.Location, Project);
2060 end if;
2062 Project.Config.Linker_Lib_Dir_Option :=
2063 Attribute.Value.Value;
2065 elsif Attribute.Name = Name_Linker_Lib_Name_Option then
2067 -- Attribute Linker_Lib_Name_Option: optional options
2068 -- to specify the name of a library to be linked in.
2071 Get_Name_String (Attribute.Value.Value);
2073 if Name_Len = 0 then
2074 Error_Msg
2075 (Data.Flags,
2077 Attribute.Value.Location, Project);
2078 end if;
2080 Project.Config.Linker_Lib_Name_Option :=
2081 Attribute.Value.Value;
2083 elsif Attribute.Name = Name_Run_Path_Option then
2085 -- Attribute Run_Path_Option: optional options to
2086 -- specify a path for libraries.
2088 List := Attribute.Value.Values;
2090 if List /= Nil_String then
2091 Put (Into_List => Project.Config.Run_Path_Option,
2092 From_List => List,
2093 In_Tree => Data.Tree);
2094 end if;
2096 elsif Attribute.Name = Name_Separate_Run_Path_Options then
2097 declare
2098 pragma Unsuppress (All_Checks);
2099 begin
2100 Project.Config.Separate_Run_Path_Options :=
2101 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2102 exception
2103 when Constraint_Error =>
2104 Error_Msg
2105 (Data.Flags,
2107 Get_Name_String (Attribute.Value.Value) &
2109 Attribute.Value.Location, Project);
2110 end;
2112 elsif Attribute.Name = Name_Library_Support then
2113 declare
2114 pragma Unsuppress (All_Checks);
2115 begin
2116 Project.Config.Lib_Support :=
2117 Library_Support'Value (Get_Name_String
2118 (Attribute.Value.Value));
2119 exception
2120 when Constraint_Error =>
2121 Error_Msg
2122 (Data.Flags,
2124 Get_Name_String (Attribute.Value.Value) &
2126 Attribute.Value.Location, Project);
2127 end;
2129 elsif Attribute.Name = Name_Shared_Library_Prefix then
2130 Project.Config.Shared_Lib_Prefix :=
2131 File_Name_Type (Attribute.Value.Value);
2133 elsif Attribute.Name = Name_Shared_Library_Suffix then
2134 Project.Config.Shared_Lib_Suffix :=
2135 File_Name_Type (Attribute.Value.Value);
2137 elsif Attribute.Name = Name_Symbolic_Link_Supported then
2138 declare
2139 pragma Unsuppress (All_Checks);
2140 begin
2141 Project.Config.Symbolic_Link_Supported :=
2142 Boolean'Value (Get_Name_String
2143 (Attribute.Value.Value));
2144 exception
2145 when Constraint_Error =>
2146 Error_Msg
2147 (Data.Flags,
2149 & Get_Name_String (Attribute.Value.Value)
2151 Attribute.Value.Location, Project);
2152 end;
2154 elsif
2155 Attribute.Name = Name_Library_Major_Minor_Id_Supported
2156 then
2157 declare
2158 pragma Unsuppress (All_Checks);
2159 begin
2160 Project.Config.Lib_Maj_Min_Id_Supported :=
2161 Boolean'Value (Get_Name_String
2162 (Attribute.Value.Value));
2163 exception
2164 when Constraint_Error =>
2165 Error_Msg
2166 (Data.Flags,
2168 Get_Name_String (Attribute.Value.Value) &
2170 Attribute.Value.Location, Project);
2171 end;
2173 elsif Attribute.Name = Name_Library_Auto_Init_Supported then
2174 declare
2175 pragma Unsuppress (All_Checks);
2176 begin
2177 Project.Config.Auto_Init_Supported :=
2178 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2179 exception
2180 when Constraint_Error =>
2181 Error_Msg
2182 (Data.Flags,
2184 & Get_Name_String (Attribute.Value.Value)
2186 Attribute.Value.Location, Project);
2187 end;
2189 elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then
2190 List := Attribute.Value.Values;
2192 if List /= Nil_String then
2193 Put (Into_List => Project.Config.Shared_Lib_Min_Options,
2194 From_List => List,
2195 In_Tree => Data.Tree);
2196 end if;
2198 elsif Attribute.Name = Name_Library_Version_Switches then
2199 List := Attribute.Value.Values;
2201 if List /= Nil_String then
2202 Put (Into_List => Project.Config.Lib_Version_Options,
2203 From_List => List,
2204 In_Tree => Data.Tree);
2205 end if;
2206 end if;
2207 end if;
2209 Attribute_Id := Attribute.Next;
2210 end loop;
2211 end Process_Project_Level_Simple_Attributes;
2213 --------------------------------------------
2214 -- Process_Project_Level_Array_Attributes --
2215 --------------------------------------------
2217 procedure Process_Project_Level_Array_Attributes is
2218 Current_Array_Id : Array_Id;
2219 Current_Array : Array_Data;
2220 Element_Id : Array_Element_Id;
2221 Element : Array_Element;
2222 List : String_List_Id;
2224 begin
2225 -- Process the associative array attributes at project level
2227 Current_Array_Id := Project.Decl.Arrays;
2228 while Current_Array_Id /= No_Array loop
2229 Current_Array := Data.Tree.Arrays.Table (Current_Array_Id);
2231 Element_Id := Current_Array.Value;
2232 while Element_Id /= No_Array_Element loop
2233 Element := Data.Tree.Array_Elements.Table (Element_Id);
2235 -- Get the name of the language
2237 Lang_Index :=
2238 Get_Language_From_Name
2239 (Project, Get_Name_String (Element.Index));
2241 if Lang_Index /= No_Language_Index then
2242 case Current_Array.Name is
2243 when Name_Inherit_Source_Path =>
2244 List := Element.Value.Values;
2246 if List /= Nil_String then
2247 Put
2248 (Into_List =>
2249 Lang_Index.Config.Include_Compatible_Languages,
2250 From_List => List,
2251 In_Tree => Data.Tree,
2252 Lower_Case => True);
2253 end if;
2255 when Name_Toolchain_Description =>
2257 -- Attribute Toolchain_Description (<language>)
2259 Lang_Index.Config.Toolchain_Description :=
2260 Element.Value.Value;
2262 when Name_Toolchain_Version =>
2264 -- Attribute Toolchain_Version (<language>)
2266 Lang_Index.Config.Toolchain_Version :=
2267 Element.Value.Value;
2269 when Name_Runtime_Library_Dir =>
2271 -- Attribute Runtime_Library_Dir (<language>)
2273 Lang_Index.Config.Runtime_Library_Dir :=
2274 Element.Value.Value;
2276 when Name_Runtime_Source_Dir =>
2278 -- Attribute Runtime_Library_Dir (<language>)
2280 Lang_Index.Config.Runtime_Source_Dir :=
2281 Element.Value.Value;
2283 when Name_Object_Generated =>
2284 declare
2285 pragma Unsuppress (All_Checks);
2286 Value : Boolean;
2288 begin
2289 Value :=
2290 Boolean'Value
2291 (Get_Name_String (Element.Value.Value));
2293 Lang_Index.Config.Object_Generated := Value;
2295 -- If no object is generated, no object may be
2296 -- linked.
2298 if not Value then
2299 Lang_Index.Config.Objects_Linked := False;
2300 end if;
2302 exception
2303 when Constraint_Error =>
2304 Error_Msg
2305 (Data.Flags,
2307 & Get_Name_String (Element.Value.Value)
2309 Element.Value.Location, Project);
2310 end;
2312 when Name_Objects_Linked =>
2313 declare
2314 pragma Unsuppress (All_Checks);
2315 Value : Boolean;
2317 begin
2318 Value :=
2319 Boolean'Value
2320 (Get_Name_String (Element.Value.Value));
2322 -- No change if Object_Generated is False, as this
2323 -- forces Objects_Linked to be False too.
2325 if Lang_Index.Config.Object_Generated then
2326 Lang_Index.Config.Objects_Linked := Value;
2327 end if;
2329 exception
2330 when Constraint_Error =>
2331 Error_Msg
2332 (Data.Flags,
2334 & Get_Name_String (Element.Value.Value)
2336 Element.Value.Location, Project);
2337 end;
2338 when others =>
2339 null;
2340 end case;
2341 end if;
2343 Element_Id := Element.Next;
2344 end loop;
2346 Current_Array_Id := Current_Array.Next;
2347 end loop;
2348 end Process_Project_Level_Array_Attributes;
2350 -- Start of processing for Check_Configuration
2352 begin
2353 Process_Project_Level_Simple_Attributes;
2354 Process_Project_Level_Array_Attributes;
2355 Process_Packages;
2357 -- For unit based languages, set Casing, Dot_Replacement and
2358 -- Separate_Suffix in Naming_Data.
2360 Lang_Index := Project.Languages;
2361 while Lang_Index /= No_Language_Index loop
2362 if Lang_Index.Name = Name_Ada then
2363 Lang_Index.Config.Naming_Data.Casing := Casing;
2364 Lang_Index.Config.Naming_Data.Dot_Replacement := Dot_Replacement;
2366 if Separate_Suffix /= No_File then
2367 Lang_Index.Config.Naming_Data.Separate_Suffix :=
2368 Separate_Suffix;
2369 end if;
2371 exit;
2372 end if;
2374 Lang_Index := Lang_Index.Next;
2375 end loop;
2377 -- Give empty names to various prefixes/suffixes, if they have not
2378 -- been specified in the configuration.
2380 if Project.Config.Archive_Suffix = No_File then
2381 Project.Config.Archive_Suffix := Empty_File;
2382 end if;
2384 if Project.Config.Shared_Lib_Prefix = No_File then
2385 Project.Config.Shared_Lib_Prefix := Empty_File;
2386 end if;
2388 if Project.Config.Shared_Lib_Suffix = No_File then
2389 Project.Config.Shared_Lib_Suffix := Empty_File;
2390 end if;
2392 Lang_Index := Project.Languages;
2393 while Lang_Index /= No_Language_Index loop
2395 -- For all languages, Compiler_Driver needs to be specified. This is
2396 -- only needed if we do intend to compile (not in GPS for instance).
2398 if Data.Flags.Compiler_Driver_Mandatory
2399 and then Lang_Index.Config.Compiler_Driver = No_File
2400 then
2401 Error_Msg_Name_1 := Lang_Index.Display_Name;
2402 Error_Msg
2403 (Data.Flags,
2406 No_Location, Project);
2408 if Lang_Index = Project.Languages then
2409 Project.Languages := Lang_Index.Next;
2410 else
2411 Prev_Index.Next := Lang_Index.Next;
2412 end if;
2414 elsif Lang_Index.Name = Name_Ada then
2415 Prev_Index := Lang_Index;
2417 -- For unit based languages, Dot_Replacement, Spec_Suffix and
2418 -- Body_Suffix need to be specified.
2420 if Lang_Index.Config.Naming_Data.Dot_Replacement = No_File then
2421 Error_Msg
2422 (Data.Flags,
2424 No_Location, Project);
2425 end if;
2427 if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then
2428 Error_Msg
2429 (Data.Flags,
2431 No_Location, Project);
2432 end if;
2434 if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then
2435 Error_Msg
2436 (Data.Flags,
2438 No_Location, Project);
2439 end if;
2441 else
2442 Prev_Index := Lang_Index;
2444 -- For file based languages, either Spec_Suffix or Body_Suffix
2445 -- need to be specified.
2447 if Data.Flags.Require_Sources_Other_Lang
2448 and then Lang_Index.Config.Naming_Data.Spec_Suffix = No_File
2449 and then Lang_Index.Config.Naming_Data.Body_Suffix = No_File
2450 then
2451 Error_Msg_Name_1 := Lang_Index.Display_Name;
2452 Error_Msg
2453 (Data.Flags,
2455 No_Location, Project);
2456 end if;
2457 end if;
2459 Lang_Index := Lang_Index.Next;
2460 end loop;
2461 end Check_Configuration;
2463 -------------------------------
2464 -- Check_If_Externally_Built --
2465 -------------------------------
2467 procedure Check_If_Externally_Built
2468 (Project : Project_Id;
2469 Data : in out Tree_Processing_Data)
2470 is
2471 Externally_Built : constant Variable_Value :=
2472 Util.Value_Of
2473 (Name_Externally_Built,
2474 Project.Decl.Attributes, Data.Tree);
2476 begin
2477 if not Externally_Built.Default then
2478 Get_Name_String (Externally_Built.Value);
2479 To_Lower (Name_Buffer (1 .. Name_Len));
2482 Project.Externally_Built := True;
2485 Error_Msg (Data.Flags,
2487 Externally_Built.Location, Project);
2488 end if;
2489 end if;
2491 -- A virtual project extending an externally built project is itself
2492 -- externally built.
2494 if Project.Virtual and then Project.Extends /= No_Project then
2495 Project.Externally_Built := Project.Extends.Externally_Built;
2496 end if;
2498 if Current_Verbosity = High then
2501 if not Project.Externally_Built then
2503 end if;
2506 end if;
2507 end Check_If_Externally_Built;
2509 ----------------------
2510 -- Check_Interfaces --
2511 ----------------------
2513 procedure Check_Interfaces
2514 (Project : Project_Id;
2515 Data : in out Tree_Processing_Data)
2516 is
2517 Interfaces : constant Prj.Variable_Value :=
2518 Prj.Util.Value_Of
2519 (Snames.Name_Interfaces,
2520 Project.Decl.Attributes,
2521 Data.Tree);
2523 Library_Interface : constant Prj.Variable_Value :=
2524 Prj.Util.Value_Of
2525 (Snames.Name_Library_Interface,
2526 Project.Decl.Attributes,
2527 Data.Tree);
2529 List : String_List_Id;
2530 Element : String_Element;
2531 Name : File_Name_Type;
2532 Iter : Source_Iterator;
2533 Source : Source_Id;
2534 Project_2 : Project_Id;
2535 Other : Source_Id;
2537 begin
2538 if not Interfaces.Default then
2540 -- Set In_Interfaces to False for all sources. It will be set to True
2541 -- later for the sources in the Interfaces list.
2543 Project_2 := Project;
2544 while Project_2 /= No_Project loop
2545 Iter := For_Each_Source (Data.Tree, Project_2);
2546 loop
2547 Source := Prj.Element (Iter);
2548 exit when Source = No_Source;
2549 Source.In_Interfaces := False;
2550 Next (Iter);
2551 end loop;
2553 Project_2 := Project_2.Extends;
2554 end loop;
2556 List := Interfaces.Values;
2557 while List /= Nil_String loop
2558 Element := Data.Tree.String_Elements.Table (List);
2559 Name := Canonical_Case_File_Name (Element.Value);
2561 Project_2 := Project;
2562 Big_Loop :
2563 while Project_2 /= No_Project loop
2564 Iter := For_Each_Source (Data.Tree, Project_2);
2566 loop
2567 Source := Prj.Element (Iter);
2568 exit when Source = No_Source;
2570 if Source.File = Name then
2571 if not Source.Locally_Removed then
2572 Source.In_Interfaces := True;
2573 Source.Declared_In_Interfaces := True;
2575 Other := Other_Part (Source);
2577 if Other /= No_Source then
2578 Other.In_Interfaces := True;
2579 Other.Declared_In_Interfaces := True;
2580 end if;
2582 if Current_Verbosity = High then
2584 Write_Line (Get_Name_String (Source.Path.Name));
2585 end if;
2586 end if;
2588 exit Big_Loop;
2589 end if;
2591 Next (Iter);
2592 end loop;
2594 Project_2 := Project_2.Extends;
2595 end loop Big_Loop;
2597 if Source = No_Source then
2598 Error_Msg_File_1 := File_Name_Type (Element.Value);
2599 Error_Msg_Name_1 := Project.Name;
2601 Error_Msg
2602 (Data.Flags,
2605 Element.Location, Project);
2606 end if;
2608 List := Element.Next;
2609 end loop;
2611 Project.Interfaces_Defined := True;
2613 elsif Project.Library and then not Library_Interface.Default then
2615 -- Set In_Interfaces to False for all sources. It will be set to True
2616 -- later for the sources in the Library_Interface list.
2618 Project_2 := Project;
2619 while Project_2 /= No_Project loop
2620 Iter := For_Each_Source (Data.Tree, Project_2);
2621 loop
2622 Source := Prj.Element (Iter);
2623 exit when Source = No_Source;
2624 Source.In_Interfaces := False;
2625 Next (Iter);
2626 end loop;
2628 Project_2 := Project_2.Extends;
2629 end loop;
2631 List := Library_Interface.Values;
2632 while List /= Nil_String loop
2633 Element := Data.Tree.String_Elements.Table (List);
2634 Get_Name_String (Element.Value);
2635 To_Lower (Name_Buffer (1 .. Name_Len));
2636 Name := Name_Find;
2638 Project_2 := Project;
2639 Big_Loop_2 :
2640 while Project_2 /= No_Project loop
2641 Iter := For_Each_Source (Data.Tree, Project_2);
2643 loop
2644 Source := Prj.Element (Iter);
2645 exit when Source = No_Source;
2647 if Source.Unit /= No_Unit_Index and then
2648 Source.Unit.Name = Name_Id (Name)
2649 then
2650 if not Source.Locally_Removed then
2651 Source.In_Interfaces := True;
2652 Source.Declared_In_Interfaces := True;
2654 Other := Other_Part (Source);
2656 if Other /= No_Source then
2657 Other.In_Interfaces := True;
2658 Other.Declared_In_Interfaces := True;
2659 end if;
2661 if Current_Verbosity = High then
2663 Write_Line (Get_Name_String (Source.Path.Name));
2664 end if;
2665 end if;
2667 exit Big_Loop_2;
2668 end if;
2670 Next (Iter);
2671 end loop;
2673 Project_2 := Project_2.Extends;
2674 end loop Big_Loop_2;
2676 List := Element.Next;
2677 end loop;
2679 Project.Interfaces_Defined := True;
2681 elsif Project.Extends /= No_Project
2682 and then Project.Extends.Interfaces_Defined
2683 then
2684 Project.Interfaces_Defined := True;
2686 Iter := For_Each_Source (Data.Tree, Project);
2687 loop
2688 Source := Prj.Element (Iter);
2689 exit when Source = No_Source;
2691 if not Source.Declared_In_Interfaces then
2692 Source.In_Interfaces := False;
2693 end if;
2695 Next (Iter);
2696 end loop;
2697 end if;
2698 end Check_Interfaces;
2700 --------------------------
2701 -- Check_Package_Naming --
2702 --------------------------
2704 procedure Check_Package_Naming
2705 (Project : Project_Id;
2706 Data : in out Tree_Processing_Data;
2707 Bodies : out Array_Element_Id;
2708 Specs : out Array_Element_Id)
2709 is
2710 Naming_Id : constant Package_Id :=
2711 Util.Value_Of
2712 (Name_Naming, Project.Decl.Packages, Data.Tree);
2713 Naming : Package_Element;
2715 Ada_Body_Suffix_Loc : Source_Ptr := No_Location;
2717 procedure Check_Naming;
2718 -- Check the validity of the Naming package (suffixes valid, ...)
2720 procedure Check_Common
2721 (Dot_Replacement : in out File_Name_Type;
2722 Casing : in out Casing_Type;
2723 Casing_Defined : out Boolean;
2724 Separate_Suffix : in out File_Name_Type;
2725 Sep_Suffix_Loc : out Source_Ptr);
2726 -- Check attributes common
2728 procedure Process_Exceptions_File_Based
2729 (Lang_Id : Language_Ptr;
2730 Kind : Source_Kind);
2731 procedure Process_Exceptions_Unit_Based
2732 (Lang_Id : Language_Ptr;
2733 Kind : Source_Kind);
2734 -- Process the naming exceptions for the two types of languages
2736 procedure Initialize_Naming_Data;
2737 -- Initialize internal naming data for the various languages
2739 ------------------
2740 -- Check_Common --
2741 ------------------
2743 procedure Check_Common
2744 (Dot_Replacement : in out File_Name_Type;
2745 Casing : in out Casing_Type;
2746 Casing_Defined : out Boolean;
2747 Separate_Suffix : in out File_Name_Type;
2748 Sep_Suffix_Loc : out Source_Ptr)
2749 is
2750 Dot_Repl : constant Variable_Value :=
2751 Util.Value_Of
2752 (Name_Dot_Replacement,
2753 Naming.Decl.Attributes,
2754 Data.Tree);
2755 Casing_String : constant Variable_Value :=
2756 Util.Value_Of
2757 (Name_Casing,
2758 Naming.Decl.Attributes,
2759 Data.Tree);
2760 Sep_Suffix : constant Variable_Value :=
2761 Util.Value_Of
2762 (Name_Separate_Suffix,
2763 Naming.Decl.Attributes,
2764 Data.Tree);
2765 Dot_Repl_Loc : Source_Ptr;
2767 begin
2768 Sep_Suffix_Loc := No_Location;
2770 if not Dot_Repl.Default then
2771 pragma Assert
2774 if Length_Of_Name (Dot_Repl.Value) = 0 then
2775 Error_Msg
2777 Dot_Repl.Location, Project);
2778 end if;
2780 Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value);
2781 Dot_Repl_Loc := Dot_Repl.Location;
2783 declare
2784 Repl : constant String := Get_Name_String (Dot_Replacement);
2786 begin
2787 -- Dot_Replacement cannot
2788 -- - be empty
2789 -- - start or end with an alphanumeric
2790 -- - be a single '_'
2791 -- - start with an '_' followed by an alphanumeric
2794 if Repl'Length = 0
2795 or else Is_Alphanumeric (Repl (Repl'First))
2796 or else Is_Alphanumeric (Repl (Repl'Last))
2797 or else (Repl (Repl'First) = '_'
2798 and then
2799 (Repl'Length = 1
2800 or else
2801 Is_Alphanumeric (Repl (Repl'First + 1))))
2802 or else (Repl'Length > 1
2803 and then
2805 then
2806 Error_Msg
2807 (Data.Flags,
2809 """ is illegal for Dot_Replacement.",
2810 Dot_Repl_Loc, Project);
2811 end if;
2812 end;
2813 end if;
2815 if Dot_Replacement /= No_File then
2816 Write_Attr
2817 ("Dot_Replacement", Get_Name_String (Dot_Replacement));
2818 end if;
2820 Casing_Defined := False;
2822 if not Casing_String.Default then
2823 pragma Assert
2824 (Casing_String.Kind = Single, "Casing is not a string");
2826 declare
2827 Casing_Image : constant String :=
2828 Get_Name_String (Casing_String.Value);
2830 begin
2831 if Casing_Image'Length = 0 then
2832 Error_Msg
2833 (Data.Flags,
2834 "Casing cannot be an empty string",
2835 Casing_String.Location, Project);
2836 end if;
2838 Casing := Value (Casing_Image);
2839 Casing_Defined := True;
2841 exception
2842 when Constraint_Error =>
2843 Name_Len := Casing_Image'Length;
2844 Name_Buffer (1 .. Name_Len) := Casing_Image;
2845 Err_Vars.Error_Msg_Name_1 := Name_Find;
2846 Error_Msg
2847 (Data.Flags,
2848 "%% is not a correct Casing",
2849 Casing_String.Location, Project);
2850 end;
2851 end if;
2853 Write_Attr ("Casing", Image (Casing));
2855 if not Sep_Suffix.Default then
2856 if Length_Of_Name (Sep_Suffix.Value) = 0 then
2857 Error_Msg
2858 (Data.Flags,
2859 "Separate_Suffix cannot be empty",
2860 Sep_Suffix.Location, Project);
2862 else
2863 Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value);
2864 Sep_Suffix_Loc := Sep_Suffix.Location;
2866 Check_Illegal_Suffix
2867 (Project, Separate_Suffix,
2868 Dot_Replacement, "Separate_Suffix", Sep_Suffix.Location,
2869 Data);
2870 end if;
2871 end if;
2873 if Separate_Suffix /= No_File then
2874 Write_Attr
2875 ("Separate_Suffix", Get_Name_String (Separate_Suffix));
2876 end if;
2877 end Check_Common;
2879 -----------------------------------
2880 -- Process_Exceptions_File_Based --
2881 -----------------------------------
2883 procedure Process_Exceptions_File_Based
2884 (Lang_Id : Language_Ptr;
2885 Kind : Source_Kind)
2886 is
2887 Lang : constant Name_Id := Lang_Id.Name;
2888 Exceptions : Array_Element_Id;
2889 Exception_List : Variable_Value;
2890 Element_Id : String_List_Id;
2891 Element : String_Element;
2892 File_Name : File_Name_Type;
2893 Source : Source_Id;
2894 Iter : Source_Iterator;
2896 begin
2897 case Kind is
2898 when Impl | Sep =>
2899 Exceptions :=
2900 Value_Of
2901 (Name_Implementation_Exceptions,
2902 In_Arrays => Naming.Decl.Arrays,
2903 In_Tree => Data.Tree);
2905 when Spec =>
2906 Exceptions :=
2907 Value_Of
2908 (Name_Specification_Exceptions,
2909 In_Arrays => Naming.Decl.Arrays,
2910 In_Tree => Data.Tree);
2911 end case;
2913 Exception_List := Value_Of
2914 (Index => Lang,
2915 In_Array => Exceptions,
2916 In_Tree => Data.Tree);
2918 if Exception_List /= Nil_Variable_Value then
2919 Element_Id := Exception_List.Values;
2920 while Element_Id /= Nil_String loop
2921 Element := Data.Tree.String_Elements.Table (Element_Id);
2922 File_Name := Canonical_Case_File_Name (Element.Value);
2924 Iter := For_Each_Source (Data.Tree, Project);
2925 loop
2926 Source := Prj.Element (Iter);
2927 exit when Source = No_Source or else Source.File = File_Name;
2928 Next (Iter);
2929 end loop;
2931 if Source = No_Source then
2932 Add_Source
2933 (Id => Source,
2934 Data => Data,
2935 Project => Project,
2936 Source_Dir_Rank => 0,
2937 Lang_Id => Lang_Id,
2938 Kind => Kind,
2939 File_Name => File_Name,
2940 Display_File => File_Name_Type (Element.Value),
2941 Naming_Exception => True);
2943 else
2944 -- Check if the file name is already recorded for another
2945 -- language or another kind.
2947 if Source.Language /= Lang_Id then
2948 Error_Msg
2949 (Data.Flags,
2950 "the same file cannot be a source of two languages",
2951 Element.Location, Project);
2953 elsif Source.Kind /= Kind then
2954 Error_Msg
2955 (Data.Flags,
2956 "the same file cannot be a source and a template",
2957 Element.Location, Project);
2958 end if;
2960 -- If the file is already recorded for the same
2961 -- language and the same kind, it means that the file
2962 -- name appears several times in the *_Exceptions
2963 -- attribute; so there is nothing to do.
2964 end if;
2966 Element_Id := Element.Next;
2967 end loop;
2968 end if;
2969 end Process_Exceptions_File_Based;
2971 -----------------------------------
2972 -- Process_Exceptions_Unit_Based --
2973 -----------------------------------
2975 procedure Process_Exceptions_Unit_Based
2976 (Lang_Id : Language_Ptr;
2977 Kind : Source_Kind)
2978 is
2979 Lang : constant Name_Id := Lang_Id.Name;
2980 Exceptions : Array_Element_Id;
2981 Element : Array_Element;
2982 Unit : Name_Id;
2983 Index : Int;
2984 File_Name : File_Name_Type;
2985 Source : Source_Id;
2987 begin
2988 case Kind is
2989 when Impl | Sep =>
2990 Exceptions :=
2991 Value_Of
2992 (Name_Body,
2993 In_Arrays => Naming.Decl.Arrays,
2994 In_Tree => Data.Tree);
2996 if Exceptions = No_Array_Element then
2997 Exceptions :=
2998 Value_Of
2999 (Name_Implementation,
3000 In_Arrays => Naming.Decl.Arrays,
3001 In_Tree => Data.Tree);
3002 end if;
3004 when Spec =>
3005 Exceptions :=
3006 Value_Of
3007 (Name_Spec,
3008 In_Arrays => Naming.Decl.Arrays,
3009 In_Tree => Data.Tree);
3011 if Exceptions = No_Array_Element then
3012 Exceptions :=
3013 Value_Of
3014 (Name_Spec,
3015 In_Arrays => Naming.Decl.Arrays,
3016 In_Tree => Data.Tree);
3017 end if;
3018 end case;
3020 while Exceptions /= No_Array_Element loop
3021 Element := Data.Tree.Array_Elements.Table (Exceptions);
3022 File_Name := Canonical_Case_File_Name (Element.Value.Value);
3024 Get_Name_String (Element.Index);
3025 To_Lower (Name_Buffer (1 .. Name_Len));
3026 Unit := Name_Find;
3027 Index := Element.Value.Index;
3029 -- For Ada, check if it is a valid unit name
3031 if Lang = Name_Ada then
3032 Get_Name_String (Element.Index);
3033 Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit);
3035 if Unit = No_Name then
3036 Err_Vars.Error_Msg_Name_1 := Element.Index;
3037 Error_Msg
3038 (Data.Flags,
3039 "%% is not a valid unit name.",
3040 Element.Value.Location, Project);
3041 end if;
3042 end if;
3044 if Unit /= No_Name then
3045 Add_Source
3046 (Id => Source,
3047 Data => Data,
3048 Project => Project,
3049 Source_Dir_Rank => 0,
3050 Lang_Id => Lang_Id,
3051 Kind => Kind,
3052 File_Name => File_Name,
3053 Display_File => File_Name_Type (Element.Value.Value),
3054 Unit => Unit,
3055 Index => Index,
3056 Location => Element.Value.Location,
3057 Naming_Exception => True);
3058 end if;
3060 Exceptions := Element.Next;
3061 end loop;
3062 end Process_Exceptions_Unit_Based;
3064 ------------------
3065 -- Check_Naming --
3066 ------------------
3068 procedure Check_Naming is
3069 Dot_Replacement : File_Name_Type :=
3070 File_Name_Type
3072 Separate_Suffix : File_Name_Type := No_File;
3073 Casing : Casing_Type := All_Lower_Case;
3074 Casing_Defined : Boolean;
3075 Lang_Id : Language_Ptr;
3076 Sep_Suffix_Loc : Source_Ptr;
3077 Suffix : Variable_Value;
3078 Lang : Name_Id;
3080 begin
3081 Check_Common
3082 (Dot_Replacement => Dot_Replacement,
3083 Casing => Casing,
3084 Casing_Defined => Casing_Defined,
3085 Separate_Suffix => Separate_Suffix,
3086 Sep_Suffix_Loc => Sep_Suffix_Loc);
3088 -- For all unit based languages, if any, set the specified value
3089 -- of Dot_Replacement, Casing and/or Separate_Suffix. Do not
3090 -- systematically overwrite, since the defaults come from the
3091 -- configuration file.
3093 if Dot_Replacement /= No_File
3094 or else Casing_Defined
3095 or else Separate_Suffix /= No_File
3096 then
3097 Lang_Id := Project.Languages;
3098 while Lang_Id /= No_Language_Index loop
3099 if Lang_Id.Config.Kind = Unit_Based then
3100 if Dot_Replacement /= No_File then
3101 Lang_Id.Config.Naming_Data.Dot_Replacement :=
3102 Dot_Replacement;
3103 end if;
3105 if Casing_Defined then
3106 Lang_Id.Config.Naming_Data.Casing := Casing;
3107 end if;
3108 end if;
3110 Lang_Id := Lang_Id.Next;
3111 end loop;
3112 end if;
3114 -- Next, get the spec and body suffixes
3116 Lang_Id := Project.Languages;
3117 while Lang_Id /= No_Language_Index loop
3118 Lang := Lang_Id.Name;
3120 -- Spec_Suffix
3122 Suffix := Value_Of
3123 (Name => Lang,
3124 Attribute_Or_Array_Name => Name_Spec_Suffix,
3125 In_Package => Naming_Id,
3126 In_Tree => Data.Tree);
3128 if Suffix = Nil_Variable_Value then
3129 Suffix := Value_Of
3130 (Name => Lang,
3131 Attribute_Or_Array_Name => Name_Specification_Suffix,
3132 In_Package => Naming_Id,
3133 In_Tree => Data.Tree);
3134 end if;
3136 if Suffix /= Nil_Variable_Value then
3137 Lang_Id.Config.Naming_Data.Spec_Suffix :=
3138 File_Name_Type (Suffix.Value);
3140 Check_Illegal_Suffix
3141 (Project,
3142 Lang_Id.Config.Naming_Data.Spec_Suffix,
3143 Lang_Id.Config.Naming_Data.Dot_Replacement,
3144 "Spec_Suffix", Suffix.Location, Data);
3146 Write_Attr
3147 ("Spec_Suffix",
3148 Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix));
3149 end if;
3151 -- Body_Suffix
3153 Suffix :=
3154 Value_Of
3155 (Name => Lang,
3156 Attribute_Or_Array_Name => Name_Body_Suffix,
3157 In_Package => Naming_Id,
3158 In_Tree => Data.Tree);
3160 if Suffix = Nil_Variable_Value then
3161 Suffix :=
3162 Value_Of
3163 (Name => Lang,
3164 Attribute_Or_Array_Name => Name_Implementation_Suffix,
3165 In_Package => Naming_Id,
3166 In_Tree => Data.Tree);
3167 end if;
3169 if Suffix /= Nil_Variable_Value then
3170 Lang_Id.Config.Naming_Data.Body_Suffix :=
3171 File_Name_Type (Suffix.Value);
3173 -- The default value of separate suffix should be the same as
3174 -- the body suffix, so we need to compute that first.
3176 if Separate_Suffix = No_File then
3177 Lang_Id.Config.Naming_Data.Separate_Suffix :=
3178 Lang_Id.Config.Naming_Data.Body_Suffix;
3179 Write_Attr
3180 ("Sep_Suffix",
3181 Get_Name_String
3182 (Lang_Id.Config.Naming_Data.Separate_Suffix));
3183 else
3184 Lang_Id.Config.Naming_Data.Separate_Suffix :=
3185 Separate_Suffix;
3186 end if;
3188 Check_Illegal_Suffix
3189 (Project,
3190 Lang_Id.Config.Naming_Data.Body_Suffix,
3191 Lang_Id.Config.Naming_Data.Dot_Replacement,
3192 "Body_Suffix", Suffix.Location, Data);
3194 Write_Attr
3195 ("Body_Suffix",
3196 Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix));
3198 elsif Separate_Suffix /= No_File then
3199 Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix;
3200 end if;
3202 -- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix,
3203 -- since that would cause a clear ambiguity. Note that we do allow
3204 -- a Spec_Suffix to have the same termination as one of these,
3205 -- which causes a potential ambiguity, but we resolve that my
3206 -- matching the longest possible suffix.
3208 if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File
3209 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
3210 Lang_Id.Config.Naming_Data.Body_Suffix
3211 then
3212 Error_Msg
3213 (Data.Flags,
3214 "Body_Suffix ("""
3215 & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)
3216 & """) cannot be the same as Spec_Suffix.",
3217 Ada_Body_Suffix_Loc, Project);
3218 end if;
3220 if Lang_Id.Config.Naming_Data.Body_Suffix /=
3221 Lang_Id.Config.Naming_Data.Separate_Suffix
3222 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
3223 Lang_Id.Config.Naming_Data.Separate_Suffix
3224 then
3225 Error_Msg
3226 (Data.Flags,
3227 "Separate_Suffix ("""
3228 & Get_Name_String
3229 (Lang_Id.Config.Naming_Data.Separate_Suffix)
3230 & """) cannot be the same as Spec_Suffix.",
3231 Sep_Suffix_Loc, Project);
3232 end if;
3234 Lang_Id := Lang_Id.Next;
3235 end loop;
3237 -- Get the naming exceptions for all languages
3239 for Kind in Spec .. Impl loop
3240 Lang_Id := Project.Languages;
3241 while Lang_Id /= No_Language_Index loop
3242 case Lang_Id.Config.Kind is
3243 when File_Based =>
3244 Process_Exceptions_File_Based (Lang_Id, Kind);
3246 when Unit_Based =>
3247 Process_Exceptions_Unit_Based (Lang_Id, Kind);
3248 end case;
3250 Lang_Id := Lang_Id.Next;
3251 end loop;
3252 end loop;
3253 end Check_Naming;
3255 ----------------------------
3256 -- Initialize_Naming_Data --
3257 ----------------------------
3259 procedure Initialize_Naming_Data is
3260 Specs : Array_Element_Id :=
3261 Util.Value_Of
3262 (Name_Spec_Suffix,
3263 Naming.Decl.Arrays,
3264 Data.Tree);
3266 Impls : Array_Element_Id :=
3267 Util.Value_Of
3268 (Name_Body_Suffix,
3269 Naming.Decl.Arrays,
3270 Data.Tree);
3272 Lang : Language_Ptr;
3273 Lang_Name : Name_Id;
3274 Value : Variable_Value;
3275 Extended : Project_Id;
3277 begin
3278 -- At this stage, the project already contains the default extensions
3279 -- for the various languages. We now merge those suffixes read in the
3280 -- user project, and they override the default.
3282 while Specs /= No_Array_Element loop
3283 Lang_Name := Data.Tree.Array_Elements.Table (Specs).Index;
3284 Lang :=
3285 Get_Language_From_Name
3286 (Project, Name => Get_Name_String (Lang_Name));
3288 -- An extending project inherits its parent projects' languages
3289 -- so if needed we should create entries for those languages
3294 Lang := Get_Language_From_Name
3303 Lang.First_Source := null;
3304 Lang.Next := Project.Languages;
3305 Project.Languages := Lang;
3306 end if;
3307 end if;
3309 -- If language was not found in project or the projects it extends
3311 if Lang = null then
3312 if Current_Verbosity = High then
3313 Write_Line
3314 ("Ignoring spec naming data for "
3315 & Get_Name_String (Lang_Name)
3316 & " since language is not defined for this project");
3317 end if;
3319 else
3320 Value := Data.Tree.Array_Elements.Table (Specs).Value;
3322 if Value.Kind = Single then
3323 Lang.Config.Naming_Data.Spec_Suffix :=
3324 Canonical_Case_File_Name (Value.Value);
3325 end if;
3326 end if;
3328 Specs := Data.Tree.Array_Elements.Table (Specs).Next;
3329 end loop;
3331 while Impls /= No_Array_Element loop
3332 Lang_Name := Data.Tree.Array_Elements.Table (Impls).Index;
3333 Lang :=
3334 Get_Language_From_Name
3335 (Project, Name => Get_Name_String (Lang_Name));
3337 if Lang = null then
3338 if Current_Verbosity = High then
3339 Write_Line
3340 ("Ignoring impl naming data for "
3341 & Get_Name_String (Lang_Name)
3342 & " since language is not defined for this project");
3343 end if;
3344 else
3345 Value := Data.Tree.Array_Elements.Table (Impls).Value;
3347 if Lang.Name = Name_Ada then
3348 Ada_Body_Suffix_Loc := Value.Location;
3349 end if;
3351 if Value.Kind = Single then
3352 Lang.Config.Naming_Data.Body_Suffix :=
3353 Canonical_Case_File_Name (Value.Value);
3354 end if;
3355 end if;
3357 Impls := Data.Tree.Array_Elements.Table (Impls).Next;
3358 end loop;
3359 end Initialize_Naming_Data;
3361 -- Start of processing for Check_Naming_Schemes
3363 begin
3364 Specs := No_Array_Element;
3365 Bodies := No_Array_Element;
3367 -- No Naming package or parsing a configuration file? nothing to do
3369 if Naming_Id /= No_Package
3370 and then Project.Qualifier /= Configuration
3371 then
3372 Naming := Data.Tree.Packages.Table (Naming_Id);
3374 if Current_Verbosity = High then
3375 Write_Line ("Checking package Naming for project "
3376 & Get_Name_String (Project.Name));
3377 end if;
3379 Initialize_Naming_Data;
3380 Check_Naming;
3381 end if;
3382 end Check_Package_Naming;
3384 ------------------------------
3385 -- Check_Library_Attributes --
3386 ------------------------------
3388 procedure Check_Library_Attributes
3389 (Project : Project_Id;
3390 Data : in out Tree_Processing_Data)
3391 is
3392 Attributes : constant Prj.Variable_Id := Project.Decl.Attributes;
3394 Lib_Dir : constant Prj.Variable_Value :=
3395 Prj.Util.Value_Of
3396 (Snames.Name_Library_Dir, Attributes, Data.Tree);
3398 Lib_Name : constant Prj.Variable_Value :=
3399 Prj.Util.Value_Of
3400 (Snames.Name_Library_Name, Attributes, Data.Tree);
3402 Lib_Version : constant Prj.Variable_Value :=
3403 Prj.Util.Value_Of
3404 (Snames.Name_Library_Version, Attributes, Data.Tree);
3406 Lib_ALI_Dir : constant Prj.Variable_Value :=
3407 Prj.Util.Value_Of
3408 (Snames.Name_Library_Ali_Dir, Attributes, Data.Tree);
3410 Lib_GCC : constant Prj.Variable_Value :=
3411 Prj.Util.Value_Of
3412 (Snames.Name_Library_GCC, Attributes, Data.Tree);
3414 The_Lib_Kind : constant Prj.Variable_Value :=
3415 Prj.Util.Value_Of
3416 (Snames.Name_Library_Kind, Attributes, Data.Tree);
3418 Imported_Project_List : Project_List;
3420 Continuation : String_Access := No_Continuation_String'Access;
3422 Support_For_Libraries : Library_Support;
3424 Library_Directory_Present : Boolean;
3426 procedure Check_Library (Proj : Project_Id; Extends : Boolean);
3427 -- Check if an imported or extended project if also a library project
3429 -------------------
3430 -- Check_Library --
3431 -------------------
3433 procedure Check_Library (Proj : Project_Id; Extends : Boolean) is
3434 Src_Id : Source_Id;
3435 Iter : Source_Iterator;
3437 begin
3438 if Proj /= No_Project then
3439 if not Proj.Library then
3441 -- The only not library projects that are OK are those that
3442 -- have no sources. However, header files from non-Ada
3443 -- languages are OK, as there is nothing to compile.
3445 Iter := For_Each_Source (Data.Tree, Proj);
3446 loop
3447 Src_Id := Prj.Element (Iter);
3448 exit when Src_Id = No_Source
3449 or else Src_Id.Language.Config.Kind /= File_Based
3450 or else Src_Id.Kind /= Spec;
3451 Next (Iter);
3452 end loop;
3454 if Src_Id /= No_Source then
3455 Error_Msg_Name_1 := Project.Name;
3456 Error_Msg_Name_2 := Proj.Name;
3458 if Extends then
3459 if Project.Library_Kind /= Static then
3460 Error_Msg
3461 (Data.Flags,
3462 Continuation.all &
3463 "shared library project %% cannot extend " &
3464 "project %% that is not a library project",
3465 Project.Location, Project);
3466 Continuation := Continuation_String'Access;
3467 end if;
3469 elsif (not Unchecked_Shared_Lib_Imports)
3470 and then Project.Library_Kind /= Static
3471 then
3472 Error_Msg
3473 (Data.Flags,
3474 Continuation.all &
3475 "shared library project %% cannot import project %% " &
3476 "that is not a shared library project",
3477 Project.Location, Project);
3478 Continuation := Continuation_String'Access;
3479 end if;
3480 end if;
3482 elsif Project.Library_Kind /= Static and then
3483 Proj.Library_Kind = Static
3484 then
3485 Error_Msg_Name_1 := Project.Name;
3486 Error_Msg_Name_2 := Proj.Name;
3488 if Extends then
3489 Error_Msg
3490 (Data.Flags,
3491 Continuation.all &
3492 "shared library project %% cannot extend static " &
3493 "library project %%",
3494 Project.Location, Project);
3495 Continuation := Continuation_String'Access;
3497 elsif not Unchecked_Shared_Lib_Imports then
3498 Error_Msg
3499 (Data.Flags,
3500 Continuation.all &
3501 "shared library project %% cannot import static " &
3502 "library project %%",
3503 Project.Location, Project);
3504 Continuation := Continuation_String'Access;
3505 end if;
3507 end if;
3508 end if;
3509 end Check_Library;
3511 Dir_Exists : Boolean;
3513 -- Start of processing for Check_Library_Attributes
3515 begin
3516 Library_Directory_Present := Lib_Dir.Value /= Empty_String;
3518 -- Special case of extending project
3520 if Project.Extends /= No_Project then
3522 -- If the project extended is a library project, we inherit the
3523 -- library name, if it is not redefined; we check that the library
3524 -- directory is specified.
3526 if Project.Extends.Library then
3527 if Project.Qualifier = Standard then
3528 Error_Msg
3529 (Data.Flags,
3530 "a standard project cannot extend a library project",
3531 Project.Location, Project);
3533 else
3534 if Lib_Name.Default then
3535 Project.Library_Name := Project.Extends.Library_Name;
3536 end if;
3538 if Lib_Dir.Default then
3539 if not Project.Virtual then
3540 Error_Msg
3541 (Data.Flags,
3542 "a project extending a library project must " &
3543 "specify an attribute Library_Dir",
3544 Project.Location, Project);
3546 else
3547 -- For a virtual project extending a library project,
3548 -- inherit library directory.
3550 Project.Library_Dir := Project.Extends.Library_Dir;
3551 Library_Directory_Present := True;
3552 end if;
3553 end if;
3554 end if;
3555 end if;
3556 end if;
3558 pragma Assert (Lib_Name.Kind = Single);
3560 if Lib_Name.Value = Empty_String then
3561 if Current_Verbosity = High
3562 and then Project.Library_Name = No_Name
3563 then
3564 Write_Line ("No library name");
3565 end if;
3567 else
3568 -- There is no restriction on the syntax of library names
3570 Project.Library_Name := Lib_Name.Value;
3571 end if;
3573 if Project.Library_Name /= No_Name then
3574 if Current_Verbosity = High then
3575 Write_Attr
3576 ("Library name", Get_Name_String (Project.Library_Name));
3577 end if;
3579 pragma Assert (Lib_Dir.Kind = Single);
3581 if not Library_Directory_Present then
3582 if Current_Verbosity = High then
3583 Write_Line ("No library directory");
3584 end if;
3586 else
3587 -- Find path name (unless inherited), check that it is a directory
3589 if Project.Library_Dir = No_Path_Information then
3590 Locate_Directory
3591 (Project,
3592 File_Name_Type (Lib_Dir.Value),
3593 Path => Project.Library_Dir,
3594 Dir_Exists => Dir_Exists,
3595 Data => Data,
3596 Create => "library",
3597 Must_Exist => False,
3598 Location => Lib_Dir.Location,
3599 Externally_Built => Project.Externally_Built);
3601 else
3602 Dir_Exists :=
3603 Is_Directory
3604 (Get_Name_String
3605 (Project.Library_Dir.Display_Name));
3606 end if;
3608 if not Dir_Exists then
3610 -- Get the absolute name of the library directory that
3611 -- does not exist, to report an error.
3613 Err_Vars.Error_Msg_File_1 :=
3614 File_Name_Type (Project.Library_Dir.Display_Name);
3615 Error_Msg
3616 (Data.Flags,
3617 "library directory { does not exist",
3618 Lib_Dir.Location, Project);
3620 -- The library directory cannot be the same as the Object
3621 -- directory.
3623 elsif Project.Library_Dir.Name = Project.Object_Directory.Name then
3624 Error_Msg
3625 (Data.Flags,
3626 "library directory cannot be the same " &
3627 "as object directory",
3628 Lib_Dir.Location, Project);
3629 Project.Library_Dir := No_Path_Information;
3631 else
3632 declare
3633 OK : Boolean := True;
3634 Dirs_Id : String_List_Id;
3635 Dir_Elem : String_Element;
3636 Pid : Project_List;
3638 begin
3639 -- The library directory cannot be the same as a source
3640 -- directory of the current project.
3642 Dirs_Id := Project.Source_Dirs;
3643 while Dirs_Id /= Nil_String loop
3644 Dir_Elem := Data.Tree.String_Elements.Table (Dirs_Id);
3645 Dirs_Id := Dir_Elem.Next;
3647 if Project.Library_Dir.Name =
3648 Path_Name_Type (Dir_Elem.Value)
3649 then
3650 Err_Vars.Error_Msg_File_1 :=
3651 File_Name_Type (Dir_Elem.Value);
3652 Error_Msg
3653 (Data.Flags,
3654 "library directory cannot be the same " &
3655 "as source directory {",
3656 Lib_Dir.Location, Project);
3657 OK := False;
3658 exit;
3659 end if;
3660 end loop;
3662 if OK then
3664 -- The library directory cannot be the same as a source
3665 -- directory of another project either.
3667 Pid := Data.Tree.Projects;
3668 Project_Loop : loop
3669 exit Project_Loop when Pid = null;
3671 if Pid.Project /= Project then
3672 Dirs_Id := Pid.Project.Source_Dirs;
3674 Dir_Loop : while Dirs_Id /= Nil_String loop
3675 Dir_Elem :=
3676 Data.Tree.String_Elements.Table (Dirs_Id);
3677 Dirs_Id := Dir_Elem.Next;
3679 if Project.Library_Dir.Name =
3680 Path_Name_Type (Dir_Elem.Value)
3681 then
3682 Err_Vars.Error_Msg_File_1 :=
3683 File_Name_Type (Dir_Elem.Value);
3684 Err_Vars.Error_Msg_Name_1 := Pid.Project.Name;
3686 Error_Msg
3687 (Data.Flags,
3688 "library directory cannot be the same " &
3689 "as source directory { of project %%",
3690 Lib_Dir.Location, Project);
3691 OK := False;
3692 exit Project_Loop;
3693 end if;
3694 end loop Dir_Loop;
3695 end if;
3697 Pid := Pid.Next;
3698 end loop Project_Loop;
3699 end if;
3701 if not OK then
3702 Project.Library_Dir := No_Path_Information;
3704 elsif Current_Verbosity = High then
3706 -- Display the Library directory in high verbosity
3708 Write_Attr
3709 ("Library directory",
3710 Get_Name_String (Project.Library_Dir.Display_Name));
3711 end if;
3712 end;
3713 end if;
3714 end if;
3716 end if;
3718 Project.Library :=
3719 Project.Library_Dir /= No_Path_Information
3720 and then Project.Library_Name /= No_Name;
3722 if Project.Extends = No_Project then
3723 case Project.Qualifier is
3724 when Standard =>
3725 if Project.Library then
3726 Error_Msg
3727 (Data.Flags,
3728 "a standard project cannot be a library project",
3729 Lib_Name.Location, Project);
3730 end if;
3732 when Library =>
3733 if not Project.Library then
3734 if Project.Library_Dir = No_Path_Information then
3735 Error_Msg
3736 (Data.Flags,
3738 Project.Location, Project);
3739 end if;
3741 if Project.Library_Name = No_Name then
3742 Error_Msg
3743 (Data.Flags,
3745 Project.Location, Project);
3746 end if;
3747 end if;
3749 when others =>
3750 null;
3752 end case;
3753 end if;
3755 if Project.Library then
3756 Support_For_Libraries := Project.Config.Lib_Support;
3758 if Support_For_Libraries = Prj.None then
3759 Error_Msg
3760 (Data.Flags,
3761 "?libraries are not supported on this platform",
3762 Lib_Name.Location, Project);
3763 Project.Library := False;
3765 else
3766 if Lib_ALI_Dir.Value = Empty_String then
3767 if Current_Verbosity = High then
3768 Write_Line ("No library ALI directory specified");
3769 end if;
3771 Project.Library_ALI_Dir := Project.Library_Dir;
3773 else
3774 -- Find path name, check that it is a directory
3776 Locate_Directory
3777 (Project,
3778 File_Name_Type (Lib_ALI_Dir.Value),
3779 Path => Project.Library_ALI_Dir,
3780 Create => "library ALI",
3781 Dir_Exists => Dir_Exists,
3782 Data => Data,
3783 Must_Exist => False,
3784 Location => Lib_ALI_Dir.Location,
3785 Externally_Built => Project.Externally_Built);
3787 if not Dir_Exists then
3789 -- Get the absolute name of the library ALI directory that
3790 -- does not exist, to report an error.
3792 Err_Vars.Error_Msg_File_1 :=
3793 File_Name_Type (Project.Library_ALI_Dir.Display_Name);
3794 Error_Msg
3795 (Data.Flags,
3797 Lib_ALI_Dir.Location, Project);
3798 end if;
3800 if Project.Library_ALI_Dir /= Project.Library_Dir then
3802 -- The library ALI directory cannot be the same as the
3803 -- Object directory.
3805 if Project.Library_ALI_Dir = Project.Object_Directory then
3806 Error_Msg
3807 (Data.Flags,
3809 "as object directory",
3810 Lib_ALI_Dir.Location, Project);
3811 Project.Library_ALI_Dir := No_Path_Information;
3813 else
3814 declare
3815 OK : Boolean := True;
3816 Dirs_Id : String_List_Id;
3817 Dir_Elem : String_Element;
3818 Pid : Project_List;
3820 begin
3821 -- The library ALI directory cannot be the same as
3822 -- a source directory of the current project.
3824 Dirs_Id := Project.Source_Dirs;
3825 while Dirs_Id /= Nil_String loop
3826 Dir_Elem :=
3827 Data.Tree.String_Elements.Table (Dirs_Id);
3828 Dirs_Id := Dir_Elem.Next;
3830 if Project.Library_ALI_Dir.Name =
3831 Path_Name_Type (Dir_Elem.Value)
3832 then
3833 Err_Vars.Error_Msg_File_1 :=
3834 File_Name_Type (Dir_Elem.Value);
3835 Error_Msg
3836 (Data.Flags,
3838 "the same as source directory {",
3839 Lib_ALI_Dir.Location, Project);
3840 OK := False;
3841 exit;
3842 end if;
3843 end loop;
3845 if OK then
3847 -- The library ALI directory cannot be the same as
3848 -- a source directory of another project either.
3850 Pid := Data.Tree.Projects;
3851 ALI_Project_Loop : loop
3852 exit ALI_Project_Loop when Pid = null;
3854 if Pid.Project /= Project then
3855 Dirs_Id := Pid.Project.Source_Dirs;
3857 ALI_Dir_Loop :
3858 while Dirs_Id /= Nil_String loop
3859 Dir_Elem :=
3860 Data.Tree.String_Elements.Table
3861 (Dirs_Id);
3862 Dirs_Id := Dir_Elem.Next;
3864 if Project.Library_ALI_Dir.Name =
3865 Path_Name_Type (Dir_Elem.Value)
3866 then
3867 Err_Vars.Error_Msg_File_1 :=
3868 File_Name_Type (Dir_Elem.Value);
3869 Err_Vars.Error_Msg_Name_1 :=
3870 Pid.Project.Name;
3872 Error_Msg
3873 (Data.Flags,
3875 "be the same as source directory " &
3876 "{ of project %%",
3877 Lib_ALI_Dir.Location, Project);
3878 OK := False;
3879 exit ALI_Project_Loop;
3880 end if;
3881 end loop ALI_Dir_Loop;
3882 end if;
3883 Pid := Pid.Next;
3884 end loop ALI_Project_Loop;
3885 end if;
3887 if not OK then
3888 Project.Library_ALI_Dir := No_Path_Information;
3890 elsif Current_Verbosity = High then
3892 -- Display Library ALI directory in high verbosity
3894 Write_Attr
3895 ("Library ALI dir",
3896 Get_Name_String
3897 (Project.Library_ALI_Dir.Display_Name));
3898 end if;
3899 end;
3900 end if;
3901 end if;
3902 end if;
3904 pragma Assert (Lib_Version.Kind = Single);
3906 if Lib_Version.Value = Empty_String then
3907 if Current_Verbosity = High then
3908 Write_Line ("No library version specified");
3909 end if;
3911 else
3912 Project.Lib_Internal_Name := Lib_Version.Value;
3913 end if;
3915 pragma Assert (The_Lib_Kind.Kind = Single);
3917 if The_Lib_Kind.Value = Empty_String then
3918 if Current_Verbosity = High then
3919 Write_Line ("No library kind specified");
3920 end if;
3922 else
3923 Get_Name_String (The_Lib_Kind.Value);
3925 declare
3926 Kind_Name : constant String :=
3927 To_Lower (Name_Buffer (1 .. Name_Len));
3929 OK : Boolean := True;
3931 begin
3932 if Kind_Name = "static" then
3933 Project.Library_Kind := Static;
3935 elsif Kind_Name = "dynamic" then
3936 Project.Library_Kind := Dynamic;
3938 elsif Kind_Name = "relocatable" then
3939 Project.Library_Kind := Relocatable;
3941 else
3942 Error_Msg
3943 (Data.Flags,
3944 "illegal value for Library_Kind",
3945 The_Lib_Kind.Location, Project);
3946 OK := False;
3947 end if;
3949 if Current_Verbosity = High and then OK then
3950 Write_Attr ("Library kind", Kind_Name);
3951 end if;
3953 if Project.Library_Kind /= Static then
3954 if Support_For_Libraries = Prj.Static_Only then
3955 Error_Msg
3956 (Data.Flags,
3957 "only static libraries are supported " &
3958 "on this platform",
3959 The_Lib_Kind.Location, Project);
3960 Project.Library := False;
3962 else
3963 -- Check if (obsolescent) attribute Library_GCC or
3964 -- Linker'Driver is declared.
3966 if Lib_GCC.Value /= Empty_String then
3967 Error_Msg
3968 (Data.Flags,
3971 Lib_GCC.Location, Project);
3972 Project.Config.Shared_Lib_Driver :=
3973 File_Name_Type (Lib_GCC.Value);
3975 else
3976 declare
3977 Linker : constant Package_Id :=
3978 Value_Of
3979 (Name_Linker,
3980 Project.Decl.Packages,
3981 Data.Tree);
3982 Driver : constant Variable_Value :=
3983 Value_Of
3984 (Name => No_Name,
3985 Attribute_Or_Array_Name =>
3986 Name_Driver,
3987 In_Package => Linker,
3988 In_Tree => Data.Tree);
3990 begin
3991 if Driver /= Nil_Variable_Value
3992 and then Driver.Value /= Empty_String
3993 then
3994 Project.Config.Shared_Lib_Driver :=
3995 File_Name_Type (Driver.Value);
3996 end if;
3997 end;
3998 end if;
3999 end if;
4000 end if;
4001 end;
4002 end if;
4004 if Project.Library then
4005 if Current_Verbosity = High then
4007 end if;
4009 Check_Library (Project.Extends, Extends => True);
4011 Imported_Project_List := Project.Imported_Projects;
4012 while Imported_Project_List /= null loop
4013 Check_Library
4014 (Imported_Project_List.Project,
4015 Extends => False);
4016 Imported_Project_List := Imported_Project_List.Next;
4017 end loop;
4018 end if;
4020 end if;
4021 end if;
4023 -- Check if Linker'Switches or Linker'Default_Switches are declared.
4024 -- Warn if they are declared, as it is a common error to think that
4027 if Project.Library then
4028 declare
4029 Linker_Package_Id : constant Package_Id :=
4030 Util.Value_Of
4031 (Name_Linker,
4032 Project.Decl.Packages, Data.Tree);
4033 Linker_Package : Package_Element;
4034 Switches : Array_Element_Id := No_Array_Element;
4036 begin
4037 if Linker_Package_Id /= No_Package then
4038 Linker_Package := Data.Tree.Packages.Table (Linker_Package_Id);
4040 Switches :=
4041 Value_Of
4042 (Name => Name_Switches,
4043 In_Arrays => Linker_Package.Decl.Arrays,
4044 In_Tree => Data.Tree);
4046 if Switches = No_Array_Element then
4047 Switches :=
4048 Value_Of
4049 (Name => Name_Default_Switches,
4050 In_Arrays => Linker_Package.Decl.Arrays,
4051 In_Tree => Data.Tree);
4052 end if;
4054 if Switches /= No_Array_Element then
4055 Error_Msg
4056 (Data.Flags,
4059 No_Location, Project);
4060 end if;
4061 end if;
4062 end;
4063 end if;
4065 if Project.Extends /= No_Project then
4066 Project.Extends.Library := False;
4067 end if;
4068 end Check_Library_Attributes;
4070 ---------------------------------
4071 -- Check_Programming_Languages --
4072 ---------------------------------
4074 procedure Check_Programming_Languages
4075 (Project : Project_Id;
4076 Data : in out Tree_Processing_Data)
4077 is
4078 Languages : Variable_Value := Nil_Variable_Value;
4079 Def_Lang : Variable_Value := Nil_Variable_Value;
4080 Def_Lang_Id : Name_Id;
4082 procedure Add_Language (Name, Display_Name : Name_Id);
4083 -- Add a new language to the list of languages for the project.
4084 -- Nothing is done if the language has already been defined
4086 ------------------
4087 -- Add_Language --
4088 ------------------
4090 procedure Add_Language (Name, Display_Name : Name_Id) is
4091 Lang : Language_Ptr;
4093 begin
4094 Lang := Project.Languages;
4095 while Lang /= No_Language_Index loop
4096 if Name = Lang.Name then
4097 return;
4098 end if;
4100 Lang := Lang.Next;
4101 end loop;
4103 Lang := new Language_Data'(No_Language_Data);
4104 Lang.Next := Project.Languages;
4105 Project.Languages := Lang;
4106 Lang.Name := Name;
4107 Lang.Display_Name := Display_Name;
4109 if Name = Name_Ada then
4110 Lang.Config.Kind := Unit_Based;
4111 Lang.Config.Dependency_Kind := ALI_File;
4112 else
4113 Lang.Config.Kind := File_Based;
4114 end if;
4115 end Add_Language;
4117 -- Start of processing for Check_Programming_Languages
4119 begin
4120 Project.Languages := null;
4121 Languages :=
4122 Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, Data.Tree);
4123 Def_Lang :=
4124 Prj.Util.Value_Of
4125 (Name_Default_Language, Project.Decl.Attributes, Data.Tree);
4127 if Project.Source_Dirs /= Nil_String then
4129 -- Check if languages are specified in this project
4131 if Languages.Default then
4133 -- Fail if there is no default language defined
4135 if Def_Lang.Default then
4136 Error_Msg
4137 (Data.Flags,
4139 Project.Location, Project);
4140 Def_Lang_Id := No_Name;
4142 else
4143 Get_Name_String (Def_Lang.Value);
4144 To_Lower (Name_Buffer (1 .. Name_Len));
4145 Def_Lang_Id := Name_Find;
4146 end if;
4148 if Def_Lang_Id /= No_Name then
4149 Get_Name_String (Def_Lang_Id);
4150 Name_Buffer (1) := GNAT.Case_Util.To_Upper (Name_Buffer (1));
4151 Add_Language
4152 (Name => Def_Lang_Id,
4153 Display_Name => Name_Find);
4154 end if;
4156 else
4157 declare
4158 Current : String_List_Id := Languages.Values;
4159 Element : String_Element;
4161 begin
4162 -- If there are no languages declared, there are no sources
4164 if Current = Nil_String then
4165 Project.Source_Dirs := Nil_String;
4167 if Project.Qualifier = Standard then
4168 Error_Msg
4169 (Data.Flags,
4171 Languages.Location, Project);
4172 end if;
4174 else
4175 -- Look through all the languages specified in attribute
4176 -- Languages.
4178 while Current /= Nil_String loop
4179 Element := Data.Tree.String_Elements.Table (Current);
4180 Get_Name_String (Element.Value);
4181 To_Lower (Name_Buffer (1 .. Name_Len));
4183 Add_Language
4184 (Name => Name_Find,
4185 Display_Name => Element.Value);
4187 Current := Element.Next;
4188 end loop;
4189 end if;
4190 end;
4191 end if;
4192 end if;
4193 end Check_Programming_Languages;
4195 -------------------------------
4196 -- Check_Stand_Alone_Library --
4197 -------------------------------
4199 procedure Check_Stand_Alone_Library
4200 (Project : Project_Id;
4201 Data : in out Tree_Processing_Data)
4202 is
4203 Lib_Interfaces : constant Prj.Variable_Value :=
4204 Prj.Util.Value_Of
4205 (Snames.Name_Library_Interface,
4206 Project.Decl.Attributes,
4207 Data.Tree);
4209 Lib_Auto_Init : constant Prj.Variable_Value :=
4210 Prj.Util.Value_Of
4211 (Snames.Name_Library_Auto_Init,
4212 Project.Decl.Attributes,
4213 Data.Tree);
4215 Lib_Src_Dir : constant Prj.Variable_Value :=
4216 Prj.Util.Value_Of
4217 (Snames.Name_Library_Src_Dir,
4218 Project.Decl.Attributes,
4219 Data.Tree);
4221 Lib_Symbol_File : constant Prj.Variable_Value :=
4222 Prj.Util.Value_Of
4223 (Snames.Name_Library_Symbol_File,
4224 Project.Decl.Attributes,
4225 Data.Tree);
4227 Lib_Symbol_Policy : constant Prj.Variable_Value :=
4228 Prj.Util.Value_Of
4229 (Snames.Name_Library_Symbol_Policy,
4230 Project.Decl.Attributes,
4231 Data.Tree);
4233 Lib_Ref_Symbol_File : constant Prj.Variable_Value :=
4234 Prj.Util.Value_Of
4235 (Snames.Name_Library_Reference_Symbol_File,
4236 Project.Decl.Attributes,
4237 Data.Tree);
4239 Auto_Init_Supported : Boolean;
4240 OK : Boolean := True;
4241 Source : Source_Id;
4242 Next_Proj : Project_Id;
4243 Iter : Source_Iterator;
4245 begin
4246 Auto_Init_Supported := Project.Config.Auto_Init_Supported;
4248 pragma Assert (Lib_Interfaces.Kind = List);
4250 -- It is a stand-alone library project file if attribute
4251 -- Library_Interface is defined.
4253 if not Lib_Interfaces.Default then
4254 declare
4255 Interfaces : String_List_Id := Lib_Interfaces.Values;
4256 Interface_ALIs : String_List_Id := Nil_String;
4257 Unit : Name_Id;
4259 begin
4260 Project.Standalone_Library := True;
4262 -- Library_Interface cannot be an empty list
4264 if Interfaces = Nil_String then
4265 Error_Msg
4266 (Data.Flags,
4268 Lib_Interfaces.Location, Project);
4269 end if;
4271 -- Process each unit name specified in the attribute
4272 -- Library_Interface.
4274 while Interfaces /= Nil_String loop
4275 Get_Name_String
4276 (Data.Tree.String_Elements.Table (Interfaces).Value);
4277 To_Lower (Name_Buffer (1 .. Name_Len));
4279 if Name_Len = 0 then
4280 Error_Msg
4281 (Data.Flags,
4283 Data.Tree.String_Elements.Table (Interfaces).Location,
4284 Project);
4286 else
4287 Unit := Name_Find;
4288 Error_Msg_Name_1 := Unit;
4290 Next_Proj := Project.Extends;
4291 Iter := For_Each_Source (Data.Tree, Project);
4292 loop
4293 while Prj.Element (Iter) /= No_Source
4294 and then
4295 (Prj.Element (Iter).Unit = null
4296 or else Prj.Element (Iter).Unit.Name /= Unit)
4297 loop
4298 Next (Iter);
4299 end loop;
4301 Source := Prj.Element (Iter);
4302 exit when Source /= No_Source
4303 or else Next_Proj = No_Project;
4305 Iter := For_Each_Source (Data.Tree, Next_Proj);
4306 Next_Proj := Next_Proj.Extends;
4307 end loop;
4309 if Source /= No_Source then
4310 if Source.Kind = Sep then
4311 Source := No_Source;
4313 elsif Source.Kind = Spec
4314 and then Other_Part (Source) /= No_Source
4315 then
4316 Source := Other_Part (Source);
4317 end if;
4318 end if;
4320 if Source /= No_Source then
4321 if Source.Project /= Project
4322 and then not Is_Extending (Project, Source.Project)
4323 then
4324 Source := No_Source;
4325 end if;
4326 end if;
4328 if Source = No_Source then
4329 Error_Msg
4330 (Data.Flags,
4332 Data.Tree.String_Elements.Table
4333 (Interfaces).Location, Project);
4335 else
4336 if Source.Kind = Spec
4337 and then Other_Part (Source) /= No_Source
4338 then
4339 Source := Other_Part (Source);
4340 end if;
4342 String_Element_Table.Increment_Last
4343 (Data.Tree.String_Elements);
4345 Data.Tree.String_Elements.Table
4346 (String_Element_Table.Last
4347 (Data.Tree.String_Elements)) :=
4348 (Value => Name_Id (Source.Dep_Name),
4349 Index => 0,
4350 Display_Value => Name_Id (Source.Dep_Name),
4351 Location =>
4352 Data.Tree.String_Elements.Table
4353 (Interfaces).Location,
4354 Flag => False,
4355 Next => Interface_ALIs);
4357 Interface_ALIs :=
4358 String_Element_Table.Last
4359 (Data.Tree.String_Elements);
4360 end if;
4361 end if;
4363 Interfaces := Data.Tree.String_Elements.Table (Interfaces).Next;
4364 end loop;
4366 -- Put the list of Interface ALIs in the project data
4368 Project.Lib_Interface_ALIs := Interface_ALIs;
4370 -- Check value of attribute Library_Auto_Init and set
4371 -- Lib_Auto_Init accordingly.
4373 if Lib_Auto_Init.Default then
4375 -- If no attribute Library_Auto_Init is declared, then set auto
4376 -- init only if it is supported.
4378 Project.Lib_Auto_Init := Auto_Init_Supported;
4380 else
4381 Get_Name_String (Lib_Auto_Init.Value);
4382 To_Lower (Name_Buffer (1 .. Name_Len));
4385 Project.Lib_Auto_Init := False;
4388 if Auto_Init_Supported then
4389 Project.Lib_Auto_Init := True;
4391 else
4393 -- supported.
4395 Error_Msg
4396 (Data.Flags,
4399 Lib_Auto_Init.Location, Project);
4400 end if;
4402 else
4403 Error_Msg
4404 (Data.Flags,
4406 Lib_Auto_Init.Location, Project);
4407 end if;
4408 end if;
4409 end;
4411 -- If attribute Library_Src_Dir is defined and not the empty string,
4412 -- check if the directory exist and is not the object directory or
4413 -- one of the source directories. This is the directory where copies
4414 -- of the interface sources will be copied. Note that this directory
4415 -- may be the library directory.
4417 if Lib_Src_Dir.Value /= Empty_String then
4418 declare
4419 Dir_Id : constant File_Name_Type :=
4420 File_Name_Type (Lib_Src_Dir.Value);
4421 Dir_Exists : Boolean;
4423 begin
4424 Locate_Directory
4425 (Project,
4426 Dir_Id,
4427 Path => Project.Library_Src_Dir,
4428 Dir_Exists => Dir_Exists,
4429 Data => Data,
4430 Must_Exist => False,
4432 Location => Lib_Src_Dir.Location,
4433 Externally_Built => Project.Externally_Built);
4435 -- If directory does not exist, report an error
4437 if not Dir_Exists then
4439 -- Get the absolute name of the library directory that does
4440 -- not exist, to report an error.
4442 Err_Vars.Error_Msg_File_1 :=
4443 File_Name_Type (Project.Library_Src_Dir.Display_Name);
4444 Error_Msg
4445 (Data.Flags,
4447 Lib_Src_Dir.Location, Project);
4449 -- Report error if it is the same as the object directory
4451 elsif Project.Library_Src_Dir = Project.Object_Directory then
4452 Error_Msg
4453 (Data.Flags,
4456 Lib_Src_Dir.Location, Project);
4457 Project.Library_Src_Dir := No_Path_Information;
4459 else
4460 declare
4461 Src_Dirs : String_List_Id;
4462 Src_Dir : String_Element;
4463 Pid : Project_List;
4465 begin
4466 -- Interface copy directory cannot be one of the source
4467 -- directory of the current project.
4469 Src_Dirs := Project.Source_Dirs;
4470 while Src_Dirs /= Nil_String loop
4471 Src_Dir := Data.Tree.String_Elements.Table (Src_Dirs);
4473 -- Report error if it is one of the source directories
4475 if Project.Library_Src_Dir.Name =
4476 Path_Name_Type (Src_Dir.Value)
4477 then
4478 Error_Msg
4479 (Data.Flags,
4482 Lib_Src_Dir.Location, Project);
4483 Project.Library_Src_Dir := No_Path_Information;
4484 exit;
4485 end if;
4487 Src_Dirs := Src_Dir.Next;
4488 end loop;
4490 if Project.Library_Src_Dir /= No_Path_Information then
4492 -- It cannot be a source directory of any other
4493 -- project either.
4495 Pid := Data.Tree.Projects;
4496 Project_Loop : loop
4497 exit Project_Loop when Pid = null;
4499 Src_Dirs := Pid.Project.Source_Dirs;
4500 Dir_Loop : while Src_Dirs /= Nil_String loop
4501 Src_Dir :=
4502 Data.Tree.String_Elements.Table (Src_Dirs);
4504 -- Report error if it is one of the source
4505 -- directories.
4507 if Project.Library_Src_Dir.Name =
4508 Path_Name_Type (Src_Dir.Value)
4509 then
4510 Error_Msg_File_1 :=
4511 File_Name_Type (Src_Dir.Value);
4512 Error_Msg_Name_1 := Pid.Project.Name;
4513 Error_Msg
4514 (Data.Flags,
4518 Lib_Src_Dir.Location, Project);
4519 Project.Library_Src_Dir :=
4520 No_Path_Information;
4521 exit Project_Loop;
4522 end if;
4524 Src_Dirs := Src_Dir.Next;
4525 end loop Dir_Loop;
4527 Pid := Pid.Next;
4528 end loop Project_Loop;
4529 end if;
4530 end;
4532 -- In high verbosity, if there is a valid Library_Src_Dir,
4533 -- display its path name.
4535 if Project.Library_Src_Dir /= No_Path_Information
4536 and then Current_Verbosity = High
4537 then
4538 Write_Attr
4540 Get_Name_String (Project.Library_Src_Dir.Name));
4541 end if;
4542 end if;
4543 end;
4544 end if;
4546 -- Check the symbol related attributes
4548 -- First, the symbol policy
4550 if not Lib_Symbol_Policy.Default then
4551 declare
4552 Value : constant String :=
4553 To_Lower
4554 (Get_Name_String (Lib_Symbol_Policy.Value));
4556 begin
4557 -- Symbol policy must hove one of a limited number of values
4560 Project.Symbol_Data.Symbol_Policy := Autonomous;
4563 Project.Symbol_Data.Symbol_Policy := Compliant;
4566 Project.Symbol_Data.Symbol_Policy := Controlled;
4569 Project.Symbol_Data.Symbol_Policy := Restricted;
4572 Project.Symbol_Data.Symbol_Policy := Direct;
4574 else
4575 Error_Msg
4576 (Data.Flags,
4578 Lib_Symbol_Policy.Location, Project);
4579 end if;
4580 end;
4581 end if;
4583 -- If attribute Library_Symbol_File is not specified, symbol policy
4584 -- cannot be Restricted.
4586 if Lib_Symbol_File.Default then
4587 if Project.Symbol_Data.Symbol_Policy = Restricted then
4588 Error_Msg
4589 (Data.Flags,
4592 Lib_Symbol_Policy.Location, Project);
4593 end if;
4595 else
4596 -- Library_Symbol_File is defined
4598 Project.Symbol_Data.Symbol_File :=
4599 Path_Name_Type (Lib_Symbol_File.Value);
4601 Get_Name_String (Lib_Symbol_File.Value);
4603 if Name_Len = 0 then
4604 Error_Msg
4605 (Data.Flags,
4607 Lib_Symbol_File.Location, Project);
4609 else
4610 OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
4612 if OK then
4613 for J in 1 .. Name_Len loop
4614 if Name_Buffer (J) = '/'
4615 or else Name_Buffer (J) = Directory_Separator
4616 then
4617 OK := False;
4618 exit;
4619 end if;
4620 end loop;
4621 end if;
4623 if not OK then
4624 Error_Msg_File_1 := File_Name_Type (Lib_Symbol_File.Value);
4625 Error_Msg
4626 (Data.Flags,
4629 Lib_Symbol_File.Location, Project);
4630 end if;
4631 end if;
4632 end if;
4634 -- If attribute Library_Reference_Symbol_File is not defined,
4635 -- symbol policy cannot be Compliant or Controlled.
4637 if Lib_Ref_Symbol_File.Default then
4638 if Project.Symbol_Data.Symbol_Policy = Compliant
4639 or else Project.Symbol_Data.Symbol_Policy = Controlled
4640 then
4641 Error_Msg
4642 (Data.Flags,
4644 Lib_Symbol_Policy.Location, Project);
4645 end if;
4647 else
4648 -- Library_Reference_Symbol_File is defined, check file exists
4650 Project.Symbol_Data.Reference :=
4651 Path_Name_Type (Lib_Ref_Symbol_File.Value);
4653 Get_Name_String (Lib_Ref_Symbol_File.Value);
4655 if Name_Len = 0 then
4656 Error_Msg
4657 (Data.Flags,
4659 Lib_Symbol_File.Location, Project);
4661 else
4662 if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then
4663 Name_Len := 0;
4664 Add_Str_To_Name_Buffer
4665 (Get_Name_String (Project.Directory.Name));
4666 Add_Str_To_Name_Buffer
4667 (Get_Name_String (Lib_Ref_Symbol_File.Value));
4668 Project.Symbol_Data.Reference := Name_Find;
4669 end if;
4671 if not Is_Regular_File
4672 (Get_Name_String (Project.Symbol_Data.Reference))
4673 then
4674 Error_Msg_File_1 :=
4675 File_Name_Type (Lib_Ref_Symbol_File.Value);
4677 -- For controlled and direct symbol policies, it is an error
4678 -- if the reference symbol file does not exist. For other
4679 -- symbol policies, this is just a warning
4681 Error_Msg_Warn :=
4682 Project.Symbol_Data.Symbol_Policy /= Controlled
4683 and then Project.Symbol_Data.Symbol_Policy /= Direct;
4685 Error_Msg
4686 (Data.Flags,
4688 Lib_Ref_Symbol_File.Location, Project);
4690 -- In addition in the non-controlled case, if symbol policy
4691 -- is Compliant, it is changed to Autonomous, because there
4692 -- is no reference to check against, and we don't want to
4693 -- fail in this case.
4695 if Project.Symbol_Data.Symbol_Policy /= Controlled then
4696 if Project.Symbol_Data.Symbol_Policy = Compliant then
4697 Project.Symbol_Data.Symbol_Policy := Autonomous;
4698 end if;
4699 end if;
4700 end if;
4702 -- If both the reference symbol file and the symbol file are
4703 -- defined, then check that they are not the same file.
4705 if Project.Symbol_Data.Symbol_File /= No_Path then
4706 Get_Name_String (Project.Symbol_Data.Symbol_File);
4708 if Name_Len > 0 then
4709 declare
4710 -- We do not need to pass a Directory to
4711 -- Normalize_Pathname, since the path_information
4712 -- already contains absolute information.
4714 Symb_Path : constant String :=
4715 Normalize_Pathname
4716 (Get_Name_String
4717 (Project.Object_Directory.Name) &
4718 Name_Buffer (1 .. Name_Len),
4720 Resolve_Links =>
4721 Opt.Follow_Links_For_Files);
4722 Ref_Path : constant String :=
4723 Normalize_Pathname
4724 (Get_Name_String
4725 (Project.Symbol_Data.Reference),
4727 Resolve_Links =>
4728 Opt.Follow_Links_For_Files);
4729 begin
4730 if Symb_Path = Ref_Path then
4731 Error_Msg
4732 (Data.Flags,
4735 Lib_Ref_Symbol_File.Location, Project);
4736 end if;
4737 end;
4738 end if;
4739 end if;
4740 end if;
4741 end if;
4742 end if;
4743 end Check_Stand_Alone_Library;
4745 ----------------------------
4746 -- Compute_Directory_Last --
4747 ----------------------------
4749 function Compute_Directory_Last (Dir : String) return Natural is
4750 begin
4751 if Dir'Length > 1
4752 and then (Dir (Dir'Last - 1) = Directory_Separator
4753 or else
4754 Dir (Dir'Last - 1) = '/')
4755 then
4756 return Dir'Last - 1;
4757 else
4758 return Dir'Last;
4759 end if;
4760 end Compute_Directory_Last;
4762 ---------------------
4763 -- Get_Directories --
4764 ---------------------
4766 procedure Get_Directories
4767 (Project : Project_Id;
4768 Data : in out Tree_Processing_Data)
4769 is
4770 package Recursive_Dirs is new GNAT.Dynamic_HTables.Simple_HTable
4771 (Header_Num => Header_Num,
4772 Element => Boolean,
4773 No_Element => False,
4774 Key => Name_Id,
4775 Hash => Hash,
4777 -- Hash table stores recursive source directories, to avoid looking
4778 -- several times, and to avoid cycles that may be introduced by symbolic
4779 -- links.
4781 Visited : Recursive_Dirs.Instance;
4783 Object_Dir : constant Variable_Value :=
4784 Util.Value_Of
4785 (Name_Object_Dir, Project.Decl.Attributes, Data.Tree);
4787 Exec_Dir : constant Variable_Value :=
4788 Util.Value_Of
4789 (Name_Exec_Dir, Project.Decl.Attributes, Data.Tree);
4791 Source_Dirs : constant Variable_Value :=
4792 Util.Value_Of
4793 (Name_Source_Dirs, Project.Decl.Attributes, Data.Tree);
4795 Excluded_Source_Dirs : constant Variable_Value :=
4796 Util.Value_Of
4797 (Name_Excluded_Source_Dirs,
4798 Project.Decl.Attributes,
4799 Data.Tree);
4801 Source_Files : constant Variable_Value :=
4802 Util.Value_Of
4803 (Name_Source_Files,
4804 Project.Decl.Attributes, Data.Tree);
4806 Last_Source_Dir : String_List_Id := Nil_String;
4807 Last_Src_Dir_Rank : Number_List_Index := No_Number_List;
4809 Languages : constant Variable_Value :=
4810 Prj.Util.Value_Of
4811 (Name_Languages, Project.Decl.Attributes, Data.Tree);
4813 procedure Find_Source_Dirs
4814 (From : File_Name_Type;
4815 Location : Source_Ptr;
4816 Rank : Natural;
4817 Removed : Boolean := False);
4818 -- Find one or several source directories, and add (or remove, if
4819 -- Removed is True) them to list of source directories of the project.
4821 ----------------------
4822 -- Find_Source_Dirs --
4823 ----------------------
4825 procedure Find_Source_Dirs
4826 (From : File_Name_Type;
4827 Location : Source_Ptr;
4828 Rank : Natural;
4829 Removed : Boolean := False)
4830 is
4831 Directory : constant String := Get_Name_String (From);
4833 procedure Add_To_Or_Remove_From_List
4834 (Path_Id : Name_Id;
4835 Display_Path_Id : Name_Id);
4836 -- When Removed = False, the directory Path_Id to the list of
4837 -- source_dirs if not already in the list. When Removed = True,
4838 -- removed directory Path_Id if in the list.
4840 procedure Recursive_Find_Dirs (Path : Name_Id);
4841 -- Find all the subdirectories (recursively) of Path and add them
4842 -- to the list of source directories of the project.
4844 --------------------------------
4845 -- Add_To_Or_Remove_From_List --
4846 --------------------------------
4848 procedure Add_To_Or_Remove_From_List
4849 (Path_Id : Name_Id;
4850 Display_Path_Id : Name_Id)
4851 is
4852 List : String_List_Id;
4853 Prev : String_List_Id;
4854 Rank_List : Number_List_Index;
4855 Prev_Rank : Number_List_Index;
4856 Element : String_Element;
4858 begin
4859 Prev := Nil_String;
4860 Prev_Rank := No_Number_List;
4861 List := Project.Source_Dirs;
4862 Rank_List := Project.Source_Dir_Ranks;
4863 while List /= Nil_String loop
4864 Element := Data.Tree.String_Elements.Table (List);
4865 exit when Element.Value = Path_Id;
4866 Prev := List;
4867 List := Element.Next;
4868 Prev_Rank := Rank_List;
4869 Rank_List := Data.Tree.Number_Lists.Table (Prev_Rank).Next;
4870 end loop;
4872 -- The directory is in the list if List is not Nil_String
4874 if not Removed and then List = Nil_String then
4875 if Current_Verbosity = High then
4877 Write_Line (Get_Name_String (Path_Id));
4878 end if;
4880 String_Element_Table.Increment_Last (Data.Tree.String_Elements);
4881 Element :=
4882 (Value => Path_Id,
4883 Index => 0,
4884 Display_Value => Display_Path_Id,
4885 Location => No_Location,
4886 Flag => False,
4887 Next => Nil_String);
4889 Number_List_Table.Increment_Last (Data.Tree.Number_Lists);
4891 if Last_Source_Dir = Nil_String then
4893 -- This is the first source directory
4895 Project.Source_Dirs :=
4896 String_Element_Table.Last (Data.Tree.String_Elements);
4897 Project.Source_Dir_Ranks :=
4898 Number_List_Table.Last (Data.Tree.Number_Lists);
4900 else
4901 -- We already have source directories, link the previous
4902 -- last to the new one.
4904 Data.Tree.String_Elements.Table (Last_Source_Dir).Next :=
4905 String_Element_Table.Last (Data.Tree.String_Elements);
4906 Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank).Next :=
4907 Number_List_Table.Last (Data.Tree.Number_Lists);
4908 end if;
4910 -- And register this source directory as the new last
4912 Last_Source_Dir :=
4913 String_Element_Table.Last (Data.Tree.String_Elements);
4914 Data.Tree.String_Elements.Table (Last_Source_Dir) := Element;
4915 Last_Src_Dir_Rank :=
4916 Number_List_Table.Last (Data.Tree.Number_Lists);
4917 Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank) :=
4918 (Number => Rank, Next => No_Number_List);
4920 elsif Removed and then List /= Nil_String then
4922 -- Remove source dir, if present
4924 if Prev = Nil_String then
4925 Project.Source_Dirs :=
4926 Data.Tree.String_Elements.Table (List).Next;
4927 Project.Source_Dir_Ranks :=
4928 Data.Tree.Number_Lists.Table (Rank_List).Next;
4930 else
4931 Data.Tree.String_Elements.Table (Prev).Next :=
4932 Data.Tree.String_Elements.Table (List).Next;
4933 Data.Tree.Number_Lists.Table (Prev_Rank).Next :=
4934 Data.Tree.Number_Lists.Table (Rank_List).Next;
4935 end if;
4936 end if;
4937 end Add_To_Or_Remove_From_List;
4939 -------------------------
4940 -- Recursive_Find_Dirs --
4941 -------------------------
4943 procedure Recursive_Find_Dirs (Path : Name_Id) is
4944 Dir : Dir_Type;
4945 Name : String (1 .. 250);
4946 Last : Natural;
4948 Non_Canonical_Path : Name_Id := No_Name;
4949 Canonical_Path : Name_Id := No_Name;
4951 The_Path : constant String :=
4952 Normalize_Pathname
4953 (Get_Name_String (Path),
4954 Directory =>
4955 Get_Name_String (Project.Directory.Display_Name),
4956 Resolve_Links => Opt.Follow_Links_For_Dirs) &
4957 Directory_Separator;
4959 The_Path_Last : constant Natural :=
4960 Compute_Directory_Last (The_Path);
4962 begin
4963 Name_Len := The_Path_Last - The_Path'First + 1;
4964 Name_Buffer (1 .. Name_Len) :=
4965 The_Path (The_Path'First .. The_Path_Last);
4966 Non_Canonical_Path := Name_Find;
4967 Canonical_Path :=
4968 Name_Id (Canonical_Case_File_Name (Non_Canonical_Path));
4970 -- To avoid processing the same directory several times, check
4971 -- if the directory is already in Recursive_Dirs. If it is, then
4972 -- there is nothing to do, just return. If it is not, put it there
4973 -- and continue recursive processing.
4975 if not Removed then
4976 if Recursive_Dirs.Get (Visited, Canonical_Path) then
4977 return;
4978 else
4979 Recursive_Dirs.Set (Visited, Canonical_Path, True);
4980 end if;
4981 end if;
4983 Add_To_Or_Remove_From_List
4984 (Path_Id => Canonical_Path,
4985 Display_Path_Id => Non_Canonical_Path);
4987 -- Now look for subdirectories. Do that even when this directory
4988 -- is already in the list, because some of its subdirectories may
4989 -- not be in the list yet.
4991 Open (Dir, The_Path (The_Path'First .. The_Path_Last));
4993 loop
4994 Read (Dir, Name, Last);
4995 exit when Last = 0;
4999 then
5000 -- Avoid . and .. directories
5002 if Current_Verbosity = High then
5004 Write_Line (Name (1 .. Last));
5005 end if;
5007 declare
5008 Path_Name : constant String :=
5009 Normalize_Pathname
5010 (Name => Name (1 .. Last),
5011 Directory =>
5012 The_Path
5013 (The_Path'First .. The_Path_Last),
5014 Resolve_Links =>
5015 Opt.Follow_Links_For_Dirs,
5016 Case_Sensitive => True);
5018 begin
5019 if Is_Directory (Path_Name) then
5021 -- We have found a new subdirectory, call self
5023 Name_Len := Path_Name'Length;
5024 Name_Buffer (1 .. Name_Len) := Path_Name;
5025 Recursive_Find_Dirs (Name_Find);
5026 end if;
5027 end;
5028 end if;
5029 end loop;
5031 Close (Dir);
5033 exception
5034 when Directory_Error =>
5035 null;
5036 end Recursive_Find_Dirs;
5038 -- Start of processing for Find_Source_Dirs
5040 begin
5041 if Current_Verbosity = High and then not Removed then
5043 Write_Str (Directory);
5045 Write_Str (Rank'Img);
5047 end if;
5049 -- First, check if we are looking for a directory tree, indicated
5052 if Directory'Length >= 3
5054 and then (Directory (Directory'Last - 2) = '/'
5055 or else
5056 Directory (Directory'Last - 2) = Directory_Separator)
5057 then
5058 Name_Len := Directory'Length - 3;
5060 if Name_Len = 0 then
5064 Name_Len := 1;
5065 Name_Buffer (1) := Directory (Directory'First);
5067 else
5068 Name_Buffer (1 .. Name_Len) :=
5069 Directory (Directory'First .. Directory'Last - 3);
5070 end if;
5072 if Current_Verbosity = High then
5074 Write_Str (Name_Buffer (1 .. Name_Len));
5076 end if;
5078 declare
5079 Base_Dir : constant File_Name_Type := Name_Find;
5080 Root_Dir : constant String :=
5081 Normalize_Pathname
5082 (Name => Get_Name_String (Base_Dir),
5083 Directory =>
5084 Get_Name_String
5085 (Project.Directory.Display_Name),
5086 Resolve_Links =>
5087 Opt.Follow_Links_For_Dirs,
5088 Case_Sensitive => True);
5090 begin
5091 if Root_Dir'Length = 0 then
5092 Err_Vars.Error_Msg_File_1 := Base_Dir;
5094 if Location = No_Location then
5095 Error_Msg
5096 (Data.Flags,
5098 Project.Location, Project);
5099 else
5100 Error_Msg
5101 (Data.Flags,
5103 Location, Project);
5104 end if;
5106 else
5107 -- We have an existing directory, we register it and all of
5108 -- its subdirectories.
5110 if Current_Verbosity = High then
5112 end if;
5114 Name_Len := Root_Dir'Length;
5115 Name_Buffer (1 .. Name_Len) := Root_Dir;
5116 Recursive_Find_Dirs (Name_Find);
5118 if Current_Verbosity = High then
5120 end if;
5121 end if;
5122 end;
5124 -- We have a single directory
5126 else
5127 declare
5128 Path_Name : Path_Information;
5129 Dir_Exists : Boolean;
5131 begin
5132 Locate_Directory
5133 (Project => Project,
5134 Name => From,
5135 Path => Path_Name,
5136 Dir_Exists => Dir_Exists,
5137 Data => Data,
5138 Must_Exist => False);
5140 if not Dir_Exists then
5141 Err_Vars.Error_Msg_File_1 := From;
5143 if Location = No_Location then
5144 Error_Msg
5145 (Data.Flags,
5147 Project.Location, Project);
5148 else
5149 Error_Msg
5150 (Data.Flags,
5152 Location, Project);
5153 end if;
5155 else
5156 declare
5157 Path : constant String :=
5158 Normalize_Pathname
5159 (Name =>
5160 Get_Name_String (Path_Name.Name),
5161 Directory =>
5162 Get_Name_String (Project.Directory.Name),
5163 Resolve_Links => Opt.Follow_Links_For_Dirs,
5164 Case_Sensitive => True) &
5165 Directory_Separator;
5167 Last_Path : constant Natural :=
5168 Compute_Directory_Last (Path);
5169 Path_Id : Name_Id;
5170 Display_Path : constant String :=
5171 Get_Name_String
5172 (Path_Name.Display_Name);
5173 Last_Display_Path : constant Natural :=
5174 Compute_Directory_Last
5175 (Display_Path);
5176 Display_Path_Id : Name_Id;
5178 begin
5179 Name_Len := 0;
5180 Add_Str_To_Name_Buffer (Path (Path'First .. Last_Path));
5181 Path_Id := Name_Find;
5183 Name_Len := 0;
5184 Add_Str_To_Name_Buffer
5185 (Display_Path
5186 (Display_Path'First .. Last_Display_Path));
5187 Display_Path_Id := Name_Find;
5189 Add_To_Or_Remove_From_List
5190 (Path_Id => Path_Id,
5191 Display_Path_Id => Display_Path_Id);
5192 end;
5193 end if;
5194 end;
5195 end if;
5197 Recursive_Dirs.Reset (Visited);
5198 end Find_Source_Dirs;
5200 -- Start of processing for Get_Directories
5202 Dir_Exists : Boolean;
5204 begin
5205 if Current_Verbosity = High then
5207 end if;
5209 -- Set the object directory to its default which may be nil, if there
5210 -- is no sources in the project.
5212 if (((not Source_Files.Default)
5213 and then Source_Files.Values = Nil_String)
5214 or else
5215 ((not Source_Dirs.Default) and then Source_Dirs.Values = Nil_String)
5216 or else
5217 ((not Languages.Default) and then Languages.Values = Nil_String))
5218 and then Project.Extends = No_Project
5219 then
5220 Project.Object_Directory := No_Path_Information;
5221 else
5222 Project.Object_Directory := Project.Directory;
5223 end if;
5225 -- Check the object directory
5227 if Object_Dir.Value /= Empty_String then
5228 Get_Name_String (Object_Dir.Value);
5230 if Name_Len = 0 then
5231 Error_Msg
5232 (Data.Flags,
5234 Object_Dir.Location, Project);
5236 else
5237 -- We check that the specified object directory does exist.
5238 -- However, even when it doesn't exist, we set it to a default
5239 -- value. This is for the benefit of tools that recover from
5240 -- errors; for example, these tools could create the non existent
5241 -- directory. We always return an absolute directory name though.
5243 Locate_Directory
5244 (Project,
5245 File_Name_Type (Object_Dir.Value),
5246 Path => Project.Object_Directory,
5248 Dir_Exists => Dir_Exists,
5249 Data => Data,
5250 Location => Object_Dir.Location,
5251 Must_Exist => False,
5252 Externally_Built => Project.Externally_Built);
5254 if not Dir_Exists
5255 and then not Project.Externally_Built
5256 then
5257 -- The object directory does not exist, report an error if
5258 -- the project is not externally built.
5260 Err_Vars.Error_Msg_File_1 :=
5261 File_Name_Type (Object_Dir.Value);
5263 case Data.Flags.Require_Obj_Dirs is
5264 when Error =>
5265 Error_Msg
5266 (Data.Flags,
5268 Project.Location, Project);
5269 when Warning =>
5270 Error_Msg
5271 (Data.Flags,
5273 Project.Location, Project);
5274 when Silent =>
5275 null;
5276 end case;
5277 end if;
5278 end if;
5280 elsif Project.Object_Directory /= No_Path_Information
5281 and then Subdirs /= null
5282 then
5283 Name_Len := 1;
5284 Name_Buffer (1) := '.';
5285 Locate_Directory
5286 (Project,
5287 Name_Find,
5288 Path => Project.Object_Directory,
5290 Dir_Exists => Dir_Exists,
5291 Data => Data,
5292 Location => Object_Dir.Location,
5293 Externally_Built => Project.Externally_Built);
5294 end if;
5296 if Current_Verbosity = High then
5297 if Project.Object_Directory = No_Path_Information then
5299 else
5300 Write_Attr
5302 Get_Name_String (Project.Object_Directory.Display_Name));
5303 end if;
5304 end if;
5306 -- Check the exec directory
5308 -- We set the object directory to its default
5310 Project.Exec_Directory := Project.Object_Directory;
5312 if Exec_Dir.Value /= Empty_String then
5313 Get_Name_String (Exec_Dir.Value);
5315 if Name_Len = 0 then
5316 Error_Msg
5317 (Data.Flags,
5319 Exec_Dir.Location, Project);
5321 else
5322 -- We check that the specified exec directory does exist
5324 Locate_Directory
5325 (Project,
5326 File_Name_Type (Exec_Dir.Value),
5327 Path => Project.Exec_Directory,
5328 Dir_Exists => Dir_Exists,
5329 Data => Data,
5331 Location => Exec_Dir.Location,
5332 Externally_Built => Project.Externally_Built);
5334 if not Dir_Exists then
5335 Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value);
5336 Error_Msg
5337 (Data.Flags,
5339 Project.Location, Project);
5340 end if;
5341 end if;
5342 end if;
5344 if Current_Verbosity = High then
5345 if Project.Exec_Directory = No_Path_Information then
5347 else
5349 Write_Str (Get_Name_String (Project.Exec_Directory.Display_Name));
5351 end if;
5352 end if;
5354 -- Look for the source directories
5356 if Current_Verbosity = High then
5358 end if;
5362 if (not Source_Files.Default)
5363 and then Source_Files.Values = Nil_String
5364 then
5365 Project.Source_Dirs := Nil_String;
5367 if Project.Qualifier = Standard then
5368 Error_Msg
5369 (Data.Flags,
5371 Source_Files.Location, Project);
5372 end if;
5374 elsif Source_Dirs.Default then
5376 -- No Source_Dirs specified: the single source directory is the one
5377 -- containing the project file.
5379 String_Element_Table.Append (Data.Tree.String_Elements,
5380 (Value => Name_Id (Project.Directory.Name),
5381 Display_Value => Name_Id (Project.Directory.Display_Name),
5382 Location => No_Location,
5383 Flag => False,
5384 Next => Nil_String,
5385 Index => 0));
5387 Project.Source_Dirs :=
5388 String_Element_Table.Last (Data.Tree.String_Elements);
5390 Number_List_Table.Append
5391 (Data.Tree.Number_Lists,
5392 (Number => 1, Next => No_Number_List));
5394 Project.Source_Dir_Ranks :=
5395 Number_List_Table.Last (Data.Tree.Number_Lists);
5397 if Current_Verbosity = High then
5398 Write_Attr
5400 Get_Name_String (Project.Directory.Display_Name));
5401 end if;
5403 elsif Source_Dirs.Values = Nil_String then
5404 if Project.Qualifier = Standard then
5405 Error_Msg
5406 (Data.Flags,
5408 Source_Dirs.Location, Project);
5409 end if;
5411 Project.Source_Dirs := Nil_String;
5413 else
5414 declare
5415 Source_Dir : String_List_Id;
5416 Element : String_Element;
5417 Rank : Natural;
5418 begin
5419 -- Process the source directories for each element of the list
5421 Source_Dir := Source_Dirs.Values;
5422 Rank := 0;
5423 while Source_Dir /= Nil_String loop
5424 Element := Data.Tree.String_Elements.Table (Source_Dir);
5425 Rank := Rank + 1;
5426 Find_Source_Dirs
5427 (File_Name_Type (Element.Value), Element.Location, Rank);
5428 Source_Dir := Element.Next;
5429 end loop;
5430 end;
5431 end if;
5433 if not Excluded_Source_Dirs.Default
5434 and then Excluded_Source_Dirs.Values /= Nil_String
5435 then
5436 declare
5437 Source_Dir : String_List_Id;
5438 Element : String_Element;
5440 begin
5441 -- Process the source directories for each element of the list
5443 Source_Dir := Excluded_Source_Dirs.Values;
5444 while Source_Dir /= Nil_String loop
5445 Element := Data.Tree.String_Elements.Table (Source_Dir);
5446 Find_Source_Dirs
5447 (File_Name_Type (Element.Value),
5448 Element.Location,
5449 0,
5450 Removed => True);
5451 Source_Dir := Element.Next;
5452 end loop;
5453 end;
5454 end if;
5456 if Current_Verbosity = High then
5458 end if;
5460 declare
5461 Current : String_List_Id := Project.Source_Dirs;
5462 Element : String_Element;
5464 begin
5465 while Current /= Nil_String loop
5466 Element := Data.Tree.String_Elements.Table (Current);
5467 if Element.Value /= No_Name then
5468 Element.Value :=
5469 Name_Id (Canonical_Case_File_Name (Name_Id (Element.Value)));
5470 Data.Tree.String_Elements.Table (Current) := Element;
5471 end if;
5473 Current := Element.Next;
5474 end loop;
5475 end;
5476 end Get_Directories;
5478 ---------------
5479 -- Get_Mains --
5480 ---------------
5482 procedure Get_Mains
5483 (Project : Project_Id;
5484 Data : in out Tree_Processing_Data)
5485 is
5486 Mains : constant Variable_Value :=
5487 Prj.Util.Value_Of
5488 (Name_Main, Project.Decl.Attributes, Data.Tree);
5489 List : String_List_Id;
5490 Elem : String_Element;
5492 begin
5493 Project.Mains := Mains.Values;
5495 -- If no Mains were specified, and if we are an extending project,
5496 -- inherit the Mains from the project we are extending.
5498 if Mains.Default then
5499 if not Project.Library and then Project.Extends /= No_Project then
5500 Project.Mains := Project.Extends.Mains;
5501 end if;
5503 -- In a library project file, Main cannot be specified
5505 elsif Project.Library then
5506 Error_Msg
5507 (Data.Flags,
5509 Mains.Location, Project);
5511 else
5512 List := Mains.Values;
5513 while List /= Nil_String loop
5514 Elem := Data.Tree.String_Elements.Table (List);
5516 if Length_Of_Name (Elem.Value) = 0 then
5517 Error_Msg
5518 (Data.Flags,
5520 Elem.Location, Project);
5521 exit;
5522 end if;
5524 List := Elem.Next;
5525 end loop;
5526 end if;
5527 end Get_Mains;
5529 ---------------------------
5530 -- Get_Sources_From_File --
5531 ---------------------------
5533 procedure Get_Sources_From_File
5534 (Path : String;
5535 Location : Source_Ptr;
5536 Project : in out Project_Processing_Data;
5537 Data : in out Tree_Processing_Data)
5538 is
5539 File : Prj.Util.Text_File;
5540 Line : String (1 .. 250);
5541 Last : Natural;
5542 Source_Name : File_Name_Type;
5543 Name_Loc : Name_Location;
5545 begin
5546 if Current_Verbosity = High then
5548 Write_Str (Path);
5550 end if;
5552 -- Open the file
5554 Prj.Util.Open (File, Path);
5556 if not Prj.Util.Is_Valid (File) then
5557 Error_Msg
5560 else
5561 -- Read the lines one by one
5563 while not Prj.Util.End_Of_File (File) loop
5564 Prj.Util.Get_Line (File, Line, Last);
5566 -- A non empty, non comment line should contain a file name
5568 if Last /= 0
5570 then
5576 -- Check that there is no directory information
5581 Error_Msg
5593 Name_Loc :=
5600 Source_Names_Htable.Set
5610 -----------------------
5611 -- Compute_Unit_Name --
5612 -----------------------
5614 procedure Compute_Unit_Name
5621 is
5631 begin
5638 then
5654 -- Choose the longest suffix that matches. If there are several matches,
5655 -- give priority to specs, then bodies, then separates.
5659 then
5666 then
5673 then
5686 -- Check that the casing matches
5694 then
5707 then
5721 -- If Dot_Replacement is not a single dot, then there should not
5722 -- be any dot in the name.
5724 declare
5728 begin
5740 Replace_Into_Name_Buffer
5743 else
5746 Fixed.Translate
5752 -- In the standard GNAT naming scheme, check for special cases: children
5753 -- or separates of A, G, I or S, and run time sources.
5757 then
5758 declare
5763 begin
5768 then
5769 -- Children or separates of packages A, G, I or S. These names
5770 -- are x__ ... or x~... (where x is a, g, i, or s). Both
5771 -- versions (x__... and x~...) are allowed in all platforms,
5772 -- because it is not possible to know the platform before
5773 -- processing of the project files.
5786 -- If it is potentially a run time source
5794 -- Name_Buffer contains the name of the the unit in lower-cases. Check
5795 -- that this is a valid unit name
5799 -- If there is a naming exception for the same unit, the file is not
5800 -- a source for the unit.
5803 Unit_Except :=
5808 and then
5810 else
5812 and then
5823 else
5837 then
5848 --------------------------
5849 -- Check_Illegal_Suffix --
5850 --------------------------
5852 procedure Check_Illegal_Suffix
5859 is
5862 begin
5865 -- Always valid
5871 Error_Msg
5878 -- Case of dot replacement is a single dot, and first character of
5879 -- suffix is also a dot.
5884 then
5887 -- If there are multiple dots in the name
5891 -- It is illegal to have a letter following the initial dot
5895 Error_Msg
5907 ----------------------
5908 -- Locate_Directory --
5909 ----------------------
5911 procedure Locate_Directory
5921 is
5931 begin
5934 -- Add Subdirs.all if it is a directory that may be created and
5935 -- Subdirs is not null;
5945 -- Convert '/' to directory separator (for Windows)
5969 else
5971 Add_Str_To_Name_Buffer
5977 declare
5981 begin
5982 if (Setup_Projects or else Subdirs /= null)
5983 and then Create'Length > 0
5984 then
5985 if not Is_Directory (Full_Path_Name.all) then
5987 -- If project is externally built, do not create a subdir,
5988 -- use the specified directory, without the subdir.
5990 if Externally_Built then
5991 if Is_Absolute_Path (Get_Name_String (Name)) then
5992 Get_Name_String (Name);
5994 else
5995 Name_Len := 0;
5996 Add_Str_To_Name_Buffer
5997 (The_Parent (The_Parent'First .. The_Parent_Last));
5998 Add_Str_To_Name_Buffer (Get_Name_String (Name));
5999 end if;
6003 else
6004 begin
6015 exception
6017 Error_Msg
6030 declare
6032 Normalize_Pathname
6034 Directory =>
6040 Normalize_Pathname
6042 Directory =>
6043 The_Parent
6045 Resolve_Links =>
6049 begin
6053 -- Directories should always end with a directory separator
6076 ---------------------------
6077 -- Find_Excluded_Sources --
6078 ---------------------------
6080 procedure Find_Excluded_Sources
6083 is
6085 Util.Value_Of
6103 begin
6104 -- If Excluded_Source_Files is not declared, check Locally_Removed_Files
6108 Excluded_Sources :=
6109 Util.Value_Of
6114 -- If there are excluded sources, put them in the table
6119 Error_Msg
6124 else
6125 Error_Msg
6138 -- If the element has no location, then use the location of
6139 -- Excluded_Sources to report possible errors.
6143 else
6147 Excluded_Sources_Htable.Set
6155 declare
6157 Path_Name_Of
6158 (File_Name_Type
6162 begin
6166 Error_Msg
6171 else
6172 -- Open the file
6177 Error_Msg
6180 else
6181 -- Read the lines one by one
6186 -- Non empty, non comment line should contain a file name
6190 then
6196 -- Check that there is no directory information
6201 then
6203 Error_Msg
6212 Excluded_Sources_Htable.Set
6224 ------------------
6225 -- Find_Sources --
6226 ------------------
6228 procedure Find_Sources
6231 is
6233 Util.Value_Of
6239 Util.Value_Of
6247 begin
6249 pragma Assert
6255 -- If the user has specified a Source_Files attribute
6259 Error_Msg
6266 -- Sources is a list of file names
6268 declare
6274 begin
6278 -- This project contains no source. For projects that don't
6279 -- extend other projects, this also means that there is no
6280 -- need for an object directory, if not specified.
6285 then
6295 -- If the element has no location, then use the location of
6296 -- Sources to report possible errors.
6300 else
6304 -- Check that there is no directory information
6309 then
6311 Error_Msg
6320 -- Check whether the file is already there: the same file name
6321 -- may be in the list. If the source is missing, the error will
6322 -- be on the first mention of the source file name.
6328 Name_Loc :=
6333 Source_Names_Htable.Set
6343 -- If we have no Source_Files attribute, check the Source_List_File
6344 -- attribute.
6348 -- Source_List_File is the name of the file that contains the source
6349 -- file names.
6351 declare
6353 Path_Name_Of
6357 begin
6363 Error_Msg
6368 else
6369 Get_Sources_From_File
6375 else
6376 -- Neither Source_Files nor Source_List_File has been specified. Find
6377 -- all the files that satisfy the naming scheme in all the source
6378 -- directories.
6383 Search_Directories
6388 -- Check if all exceptions have been found
6390 declare
6394 begin
6396 loop
6402 then
6405 -- For multi-unit source files, source_id gets duplicated
6406 -- once for every unit. Only the first source_id got its
6407 -- full path set. So if it isn't set for that first one,
6408 -- the file wasn't found. Otherwise we need to update for
6409 -- units after the first one.
6413 then
6416 Error_Msg
6421 else
6446 -- It is an error if a source file name in a source list or in a source
6447 -- list file is not found.
6450 declare
6454 begin
6462 Error_Msg
6468 else
6469 Error_Msg
6482 ----------------
6483 -- Initialize --
6484 ----------------
6486 procedure Initialize
6490 is
6491 begin
6497 ----------
6498 -- Free --
6499 ----------
6502 begin
6506 ----------------
6507 -- Initialize --
6508 ----------------
6510 procedure Initialize
6513 is
6514 begin
6518 ----------
6519 -- Free --
6520 ----------
6523 begin
6529 -------------------------------
6530 -- Check_File_Naming_Schemes --
6531 -------------------------------
6533 procedure Check_File_Naming_Schemes
6543 is
6549 -- True if we found at least one language for which the file is a header
6550 -- In such a case, we search for all possible languages where this is
6551 -- also a header (C and C++ for instance), since the file might be used
6552 -- for several such languages.
6555 -- Does the naming scheme test for file-based languages. For those,
6556 -- there is no Unit. Just check if the file name has the implementation
6557 -- or, if it is specified, the template suffix of the language.
6558 --
6559 -- Returns True if the file belongs to the current language and we
6560 -- should stop searching for matching languages. Not that a given header
6561 -- file could belong to several languages (C and C++ for instance). Thus
6562 -- if we found a header we'll check whether it matches other languages.
6564 ---------------------------
6565 -- Check_File_Based_Lang --
6566 ---------------------------
6569 begin
6570 if not Header_File
6572 then
6590 (Language => Language,
6591 Next => Alternate_Languages);
6593 else
6594 Header_File := True;
6595 Kind := Spec;
6596 Unit := No_Name;
6597 Language := Tmp_Lang;
6598 end if;
6599 end if;
6600 end Check_File_Based_Lang;
6602 -- Start of processing for Check_File_Naming_Schemes
6604 begin
6605 Language := No_Language_Index;
6606 Alternate_Languages := null;
6607 Display_Language_Name := No_Name;
6608 Unit := No_Name;
6609 Lang_Kind := File_Based;
6610 Kind := Spec;
6612 Tmp_Lang := Project.Project.Languages;
6613 while Tmp_Lang /= No_Language_Index loop
6614 if Current_Verbosity = High then
6615 Write_Line
6616 (" Testing language "
6617 & Get_Name_String (Tmp_Lang.Name)
6618 & " Header_File=" & Header_File'Img);
6619 end if;
6621 Display_Language_Name := Tmp_Lang.Display_Name;
6622 Config := Tmp_Lang.Config;
6623 Lang_Kind := Config.Kind;
6625 case Config.Kind is
6626 when File_Based =>
6627 Check_File_Based_Lang;
6628 exit when Kind = Impl;
6630 when Unit_Based =>
6632 -- We know it belongs to a least a file_based language, no
6633 -- need to check unit-based ones.
6635 if not Header_File then
6636 Compute_Unit_Name
6637 (File_Name => File_Name,
6638 Naming => Config.Naming_Data,
6639 Kind => Kind,
6640 Unit => Unit,
6641 Project => Project,
6642 In_Tree => In_Tree);
6644 if Unit /= No_Name then
6645 Language := Tmp_Lang;
6646 exit;
6647 end if;
6648 end if;
6649 end case;
6651 Tmp_Lang := Tmp_Lang.Next;
6652 end loop;
6654 if Language = No_Language_Index
6655 and then Current_Verbosity = High
6656 then
6657 Write_Line (" not a source of any language");
6658 end if;
6659 end Check_File_Naming_Schemes;
6661 -------------------
6662 -- Override_Kind --
6663 -------------------
6665 procedure Override_Kind (Source : Source_Id; Kind : Source_Kind) is
6666 begin
6667 -- If the file was previously already associated with a unit, change it
6669 if Source.Unit /= null
6670 and then Source.Kind in Spec_Or_Body
6671 and then Source.Unit.File_Names (Source.Kind) /= null
6672 then
6673 -- If we had another file referencing the same unit (for instance it
6674 -- was in an extended project), that source file is in fact invisible
6675 -- from now on, and in particular doesn't belong to the same unit.
6677 if Source.Unit.File_Names (Source.Kind) /= Source then
6678 Source.Unit.File_Names (Source.Kind).Unit := No_Unit_Index;
6679 end if;
6681 Source.Unit.File_Names (Source.Kind) := null;
6682 end if;
6684 Source.Kind := Kind;
6686 if Current_Verbosity = High
6687 and then Source.File /= No_File
6688 then
6689 Write_Line ("Override kind for "
6690 & Get_Name_String (Source.File)
6691 & " kind=" & Source.Kind'Img);
6692 end if;
6694 if Source.Kind in Spec_Or_Body and then Source.Unit /= null then
6695 Source.Unit.File_Names (Source.Kind) := Source;
6696 end if;
6697 end Override_Kind;
6699 ----------------
6700 -- Check_File --
6701 ----------------
6703 procedure Check_File
6704 (Project : in out Project_Processing_Data;
6705 Data : in out Tree_Processing_Data;
6706 Source_Dir_Rank : Natural;
6707 Path : Path_Name_Type;
6708 File_Name : File_Name_Type;
6709 Display_File_Name : File_Name_Type;
6710 Locally_Removed : Boolean;
6711 For_All_Sources : Boolean)
6712 is
6713 Canonical_Path : constant Path_Name_Type :=
6714 Path_Name_Type
6715 (Canonical_Case_File_Name (Name_Id (Path)));
6717 Name_Loc : Name_Location :=
6718 Source_Names_Htable.Get
6719 (Project.Source_Names, File_Name);
6720 Check_Name : Boolean := False;
6721 Alternate_Languages : Language_List;
6722 Language : Language_Ptr;
6723 Source : Source_Id;
6724 Src_Ind : Source_File_Index;
6725 Unit : Name_Id;
6726 Display_Language_Name : Name_Id;
6727 Lang_Kind : Language_Kind;
6728 Kind : Source_Kind := Spec;
6730 begin
6731 if Current_Verbosity = High then
6732 Write_Line ("Checking file:");
6733 Write_Str (" Path = ");
6734 Write_Line (Get_Name_String (Path));
6735 Write_Str (" Rank =");
6736 Write_Line (Source_Dir_Rank'Img);
6737 end if;
6739 if Name_Loc = No_Name_Location then
6740 Check_Name := For_All_Sources;
6742 else
6743 if Name_Loc.Found then
6745 -- Check if it is OK to have the same file name in several
6746 -- source directories.
6748 if Source_Dir_Rank = Name_Loc.Source.Source_Dir_Rank then
6749 Error_Msg_File_1 := File_Name;
6750 Error_Msg
6751 (Data.Flags,
6752 "{ is found in several source directories",
6753 Name_Loc.Location, Project.Project);
6754 end if;
6756 else
6757 Name_Loc.Found := True;
6759 Source_Names_Htable.Set
6760 (Project.Source_Names, File_Name, Name_Loc);
6762 if Name_Loc.Source = No_Source then
6763 Check_Name := True;
6765 else
6766 Name_Loc.Source.Path := (Canonical_Path, Path);
6768 Source_Paths_Htable.Set
6769 (Data.Tree.Source_Paths_HT,
6770 Canonical_Path,
6771 Name_Loc.Source);
6773 -- Check if this is a subunit
6775 if Name_Loc.Source.Unit /= No_Unit_Index
6776 and then Name_Loc.Source.Kind = Impl
6777 then
6778 Src_Ind := Sinput.P.Load_Project_File
6779 (Get_Name_String (Canonical_Path));
6781 if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
6782 Override_Kind (Name_Loc.Source, Sep);
6783 end if;
6784 end if;
6786 Files_Htable.Set
6787 (Data.File_To_Source, File_Name, Name_Loc.Source);
6788 end if;
6789 end if;
6790 end if;
6792 if Check_Name then
6793 Check_File_Naming_Schemes
6794 (In_Tree => Data.Tree,
6795 Project => Project,
6796 File_Name => File_Name,
6797 Alternate_Languages => Alternate_Languages,
6798 Language => Language,
6799 Display_Language_Name => Display_Language_Name,
6800 Unit => Unit,
6801 Lang_Kind => Lang_Kind,
6802 Kind => Kind);
6804 if Language = No_Language_Index then
6806 -- A file name in a list must be a source of a language
6808 if Data.Flags.Error_On_Unknown_Language
6809 and then Name_Loc.Found
6810 then
6811 Error_Msg_File_1 := File_Name;
6812 Error_Msg
6813 (Data.Flags,
6814 "language unknown for {",
6815 Name_Loc.Location, Project.Project);
6816 end if;
6818 else
6819 Add_Source
6820 (Id => Source,
6821 Project => Project.Project,
6822 Source_Dir_Rank => Source_Dir_Rank,
6823 Lang_Id => Language,
6824 Kind => Kind,
6825 Data => Data,
6826 Alternate_Languages => Alternate_Languages,
6827 File_Name => File_Name,
6828 Display_File => Display_File_Name,
6829 Unit => Unit,
6830 Locally_Removed => Locally_Removed,
6831 Path => (Canonical_Path, Path));
6833 -- If it is a source specified in a list, update the entry in
6834 -- the Source_Names table.
6836 if Name_Loc.Found and then Name_Loc.Source = No_Source then
6837 Name_Loc.Source := Source;
6838 Source_Names_Htable.Set
6839 (Project.Source_Names, File_Name, Name_Loc);
6840 end if;
6841 end if;
6842 end if;
6843 end Check_File;
6845 ------------------------
6846 -- Search_Directories --
6847 ------------------------
6849 procedure Search_Directories
6850 (Project : in out Project_Processing_Data;
6851 Data : in out Tree_Processing_Data;
6852 For_All_Sources : Boolean)
6853 is
6854 Source_Dir : String_List_Id;
6855 Element : String_Element;
6856 Src_Dir_Rank : Number_List_Index;
6857 Num_Nod : Number_Node;
6858 Dir : Dir_Type;
6859 Name : String (1 .. 1_000);
6860 Last : Natural;
6861 File_Name : File_Name_Type;
6862 Display_File_Name : File_Name_Type;
6864 begin
6865 if Current_Verbosity = High then
6866 Write_Line ("Looking for sources:");
6867 end if;
6869 -- Loop through subdirectories
6871 Source_Dir := Project.Project.Source_Dirs;
6872 Src_Dir_Rank := Project.Project.Source_Dir_Ranks;
6873 while Source_Dir /= Nil_String loop
6874 begin
6875 Num_Nod := Data.Tree.Number_Lists.Table (Src_Dir_Rank);
6876 Element := Data.Tree.String_Elements.Table (Source_Dir);
6878 if Element.Value /= No_Name then
6879 Get_Name_String (Element.Display_Value);
6881 if Current_Verbosity = High then
6882 Write_Str ("Directory: ");
6883 Write_Str (Name_Buffer (1 .. Name_Len));
6884 Write_Line (Num_Nod.Number'Img);
6885 end if;
6887 declare
6888 Source_Directory : constant String :=
6889 Name_Buffer (1 .. Name_Len) &
6890 Directory_Separator;
6892 Dir_Last : constant Natural :=
6893 Compute_Directory_Last
6894 (Source_Directory);
6896 begin
6897 if Current_Verbosity = High then
6898 Write_Attr ("Source_Dir", Source_Directory);
6899 end if;
6901 -- We look to every entry in the source directory
6903 Open (Dir, Source_Directory);
6905 loop
6906 Read (Dir, Name, Last);
6908 exit when Last = 0;
6910 -- In fast project loading mode (without -eL), the user
6911 -- guarantees that no directory has a name which is a
6912 -- valid source name, so we can avoid doing a system call
6913 -- here. This provides a very significant speed up on
6914 -- slow file systems (remote files for instance).
6916 if not Opt.Follow_Links_For_Files
6917 or else Is_Regular_File
6918 (Source_Directory & Name (1 .. Last))
6919 then
6920 if Current_Verbosity = High then
6921 Write_Str (" Checking ");
6922 Write_Line (Name (1 .. Last));
6923 end if;
6925 Name_Len := Last;
6926 Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
6927 Display_File_Name := Name_Find;
6929 if Osint.File_Names_Case_Sensitive then
6930 File_Name := Display_File_Name;
6931 else
6932 Canonical_Case_File_Name
6933 (Name_Buffer (1 .. Name_Len));
6934 File_Name := Name_Find;
6935 end if;
6937 declare
6938 Path_Name : constant String :=
6939 Normalize_Pathname
6940 (Name (1 .. Last),
6941 Directory =>
6942 Source_Directory
6943 (Source_Directory'First ..
6944 Dir_Last),
6945 Resolve_Links =>
6946 Opt.Follow_Links_For_Files,
6947 Case_Sensitive => True);
6948 -- Case_Sensitive set True (no folding)
6950 Path : Path_Name_Type;
6951 FF : File_Found := Excluded_Sources_Htable.Get
6952 (Project.Excluded, File_Name);
6953 To_Remove : Boolean := False;
6955 begin
6956 Name_Len := Path_Name'Length;
6957 Name_Buffer (1 .. Name_Len) := Path_Name;
6958 Path := Name_Find;
6960 if FF /= No_File_Found then
6961 if not FF.Found then
6962 FF.Found := True;
6963 Excluded_Sources_Htable.Set
6964 (Project.Excluded, File_Name, FF);
6966 if Current_Verbosity = High then
6967 Write_Str (" excluded source """);
6968 Write_Str (Get_Name_String (File_Name));
6969 Write_Line ("""");
6970 end if;
6972 -- Will mark the file as removed, but we
6973 -- still need to add it to the list: if we
6974 -- don't, the file will not appear in the
6975 -- mapping file and will cause the compiler
6976 -- to fail.
6978 To_Remove := True;
6979 end if;
6980 end if;
6982 Check_File
6983 (Project => Project,
6984 Source_Dir_Rank => Num_Nod.Number,
6985 Data => Data,
6986 Path => Path,
6987 File_Name => File_Name,
6988 Locally_Removed => To_Remove,
6989 Display_File_Name => Display_File_Name,
6990 For_All_Sources => For_All_Sources);
6991 end;
6992 end if;
6993 end loop;
6995 Close (Dir);
6996 end;
6997 end if;
6999 exception
7000 when Directory_Error =>
7001 null;
7002 end;
7004 Source_Dir := Element.Next;
7005 Src_Dir_Rank := Num_Nod.Next;
7006 end loop;
7008 if Current_Verbosity = High then
7009 Write_Line ("end Looking for sources.");
7010 end if;
7011 end Search_Directories;
7013 ----------------------------
7014 -- Load_Naming_Exceptions --
7015 ----------------------------
7017 procedure Load_Naming_Exceptions
7018 (Project : in out Project_Processing_Data;
7019 Data : in out Tree_Processing_Data)
7020 is
7021 Source : Source_Id;
7022 Iter : Source_Iterator;
7024 begin
7025 Iter := For_Each_Source (Data.Tree, Project.Project);
7026 loop
7027 Source := Prj.Element (Iter);
7028 exit when Source = No_Source;
7030 -- An excluded file cannot also be an exception file name
7032 if Excluded_Sources_Htable.Get (Project.Excluded, Source.File) /=
7033 No_File_Found
7034 then
7035 Error_Msg_File_1 := Source.File;
7036 Error_Msg
7037 (Data.Flags,
7038 "{ cannot be both excluded and an exception file name",
7039 No_Location, Project.Project);
7040 end if;
7042 if Current_Verbosity = High then
7043 Write_Str ("Naming exception: Putting source file ");
7044 Write_Str (Get_Name_String (Source.File));
7045 Write_Line (" in Source_Names");
7046 end if;
7048 Source_Names_Htable.Set
7049 (Project.Source_Names,
7050 K => Source.File,
7051 E => Name_Location'
7057 -- If this is an Ada exception, record in table Unit_Exceptions
7060 declare
7062 Unit_Exceptions_Htable.Get
7065 begin
7070 else
7074 Unit_Exceptions_Htable.Set
7083 ----------------------
7084 -- Look_For_Sources --
7085 ----------------------
7087 procedure Look_For_Sources
7090 is
7096 -- Check if object file name of Src is already used in the project tree,
7097 -- and report an error if so.
7100 -- Check that no two sources of this project have the same object file
7103 -- Mark as such the sources that are declared as excluded
7105 ------------------
7106 -- Check_Object --
7107 ------------------
7112 begin
7115 -- We cannot just check on "Source /= Src", since we might have
7116 -- two different entries for the same file (and since that's
7117 -- the same file it is expected that it has the same object)
7121 then
7124 Error_Msg
7129 else
7134 ---------------------------
7135 -- Mark_Excluded_Sources --
7136 ---------------------------
7143 begin
7144 -- Minor optimization: if there are no excluded files, no need to
7145 -- traverse the list of sources. We cannot however also check whether
7146 -- the existing exceptions have ".Found" set to True (indicating we
7147 -- found them before) because we need to do some final processing on
7148 -- them in any case.
7151 No_File_Found
7152 then
7167 Write_Line
7172 Excluded_Sources_Htable.Remove
7183 -- If we have any excluded element left, that means we did not find
7184 -- the source file
7190 -- Check if the file belongs to another imported project to
7191 -- provide a better error message.
7193 Src := Find_Source
7202 Error_Msg
7205 else
7206 Error_Msg
7217 ------------------------
7218 -- Check_Object_Files --
7219 ------------------------
7226 begin
7228 loop
7235 then
7241 else
7255 else
7256 -- Check if it is a subunit
7258 Src_Ind :=
7264 else
7276 -- Start of processing for Look_For_Sources
7278 begin
7284 Mark_Excluded_Sources;
7285 Check_Object_Files;
7291 ------------------
7292 -- Path_Name_Of --
7293 ------------------
7295 function Path_Name_Of
7298 is
7302 begin
7304 Result :=
7305 Locate_Regular_File
7311 else
7312 declare
7314 begin
7322 -------------------
7323 -- Remove_Source --
7324 -------------------
7326 procedure Remove_Source
7329 is
7332 begin
7341 Write_Eol;
7352 -- ??? Should we remove the source from the unit ? The file is not used,
7353 -- so probably should not be referenced from the unit. On the other hand
7354 -- it might give useful additional info
7355 -- if Id.Unit /= null then
7356 -- Id.Unit.File_Names (Id.Kind) := null;
7357 -- end if;
7364 else
7373 -----------------------
7374 -- Report_No_Sources --
7375 -----------------------
7377 procedure Report_No_Sources
7383 is
7384 begin
7390 declare
7393 Lang_Name &
7396 begin
7401 else
7402 Error_Msg (Data.Flags, Msg, Location, Project);
7403 end if;
7404 end;
7405 end case;
7406 end Report_No_Sources;
7408 ----------------------
7409 -- Show_Source_Dirs --
7410 ----------------------
7412 procedure Show_Source_Dirs
7413 (Project : Project_Id;
7414 In_Tree : Project_Tree_Ref)
7415 is
7416 Current : String_List_Id;
7417 Element : String_Element;
7419 begin
7422 Current := Project.Source_Dirs;
7423 while Current /= Nil_String loop
7424 Element := In_Tree.String_Elements.Table (Current);
7426 Write_Line (Get_Name_String (Element.Value));
7427 Current := Element.Next;
7428 end loop;
7431 end Show_Source_Dirs;
7433 ---------------------------
7434 -- Process_Naming_Scheme --
7435 ---------------------------
7437 procedure Process_Naming_Scheme
7438 (Tree : Project_Tree_Ref;
7439 Root_Project : Project_Id;
7440 Flags : Processing_Flags)
7441 is
7442 procedure Recursive_Check
7443 (Project : Project_Id;
7444 Data : in out Tree_Processing_Data);
7445 -- Check_Naming_Scheme for the project
7447 ---------------------
7448 -- Recursive_Check --
7449 ---------------------
7451 procedure Recursive_Check
7452 (Project : Project_Id;
7453 Data : in out Tree_Processing_Data)
7454 is
7455 begin
7456 if Verbose_Mode then
7458 Write_Str (Get_Name_String (Project.Name));
7460 end if;
7462 Prj.Nmsc.Check (Project, Data);
7463 end Recursive_Check;
7465 procedure Check_All_Projects is new
7466 For_Every_Project_Imported (Tree_Processing_Data, Recursive_Check);
7468 Data : Tree_Processing_Data;
7470 -- Start of processing for Process_Naming_Scheme
7471 begin
7472 Initialize (Data, Tree => Tree, Flags => Flags);
7473 Check_All_Projects (Root_Project, Data, Imported_First => True);
7474 Free (Data);
7475 end Process_Naming_Scheme;
7477 end Prj.Nmsc;