| blob | ca6a732ac76955075c517b08a11d5886fdb93918 |
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_Run_Path_Origin then
2097 Get_Name_String (Attribute.Value.Value);
2099 if Name_Len = 0 then
2100 Error_Msg
2101 (Data.Flags,
2103 Attribute.Value.Location, Project);
2104 end if;
2106 Project.Config.Run_Path_Origin := Attribute.Value.Value;
2108 elsif Attribute.Name = Name_Library_Install_Name_Option then
2109 Project.Config.Library_Install_Name_Option :=
2110 Attribute.Value.Value;
2112 elsif Attribute.Name = Name_Separate_Run_Path_Options then
2113 declare
2114 pragma Unsuppress (All_Checks);
2115 begin
2116 Project.Config.Separate_Run_Path_Options :=
2117 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2118 exception
2119 when Constraint_Error =>
2120 Error_Msg
2121 (Data.Flags,
2123 Get_Name_String (Attribute.Value.Value) &
2125 Attribute.Value.Location, Project);
2126 end;
2128 elsif Attribute.Name = Name_Library_Support then
2129 declare
2130 pragma Unsuppress (All_Checks);
2131 begin
2132 Project.Config.Lib_Support :=
2133 Library_Support'Value (Get_Name_String
2134 (Attribute.Value.Value));
2135 exception
2136 when Constraint_Error =>
2137 Error_Msg
2138 (Data.Flags,
2140 Get_Name_String (Attribute.Value.Value) &
2142 Attribute.Value.Location, Project);
2143 end;
2145 elsif Attribute.Name = Name_Shared_Library_Prefix then
2146 Project.Config.Shared_Lib_Prefix :=
2147 File_Name_Type (Attribute.Value.Value);
2149 elsif Attribute.Name = Name_Shared_Library_Suffix then
2150 Project.Config.Shared_Lib_Suffix :=
2151 File_Name_Type (Attribute.Value.Value);
2153 elsif Attribute.Name = Name_Symbolic_Link_Supported then
2154 declare
2155 pragma Unsuppress (All_Checks);
2156 begin
2157 Project.Config.Symbolic_Link_Supported :=
2158 Boolean'Value (Get_Name_String
2159 (Attribute.Value.Value));
2160 exception
2161 when Constraint_Error =>
2162 Error_Msg
2163 (Data.Flags,
2165 & Get_Name_String (Attribute.Value.Value)
2167 Attribute.Value.Location, Project);
2168 end;
2170 elsif
2171 Attribute.Name = Name_Library_Major_Minor_Id_Supported
2172 then
2173 declare
2174 pragma Unsuppress (All_Checks);
2175 begin
2176 Project.Config.Lib_Maj_Min_Id_Supported :=
2177 Boolean'Value (Get_Name_String
2178 (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_Library_Auto_Init_Supported then
2190 declare
2191 pragma Unsuppress (All_Checks);
2192 begin
2193 Project.Config.Auto_Init_Supported :=
2194 Boolean'Value (Get_Name_String (Attribute.Value.Value));
2195 exception
2196 when Constraint_Error =>
2197 Error_Msg
2198 (Data.Flags,
2200 & Get_Name_String (Attribute.Value.Value)
2202 Attribute.Value.Location, Project);
2203 end;
2205 elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then
2206 List := Attribute.Value.Values;
2208 if List /= Nil_String then
2209 Put (Into_List => Project.Config.Shared_Lib_Min_Options,
2210 From_List => List,
2211 In_Tree => Data.Tree);
2212 end if;
2214 elsif Attribute.Name = Name_Library_Version_Switches then
2215 List := Attribute.Value.Values;
2217 if List /= Nil_String then
2218 Put (Into_List => Project.Config.Lib_Version_Options,
2219 From_List => List,
2220 In_Tree => Data.Tree);
2221 end if;
2222 end if;
2223 end if;
2225 Attribute_Id := Attribute.Next;
2226 end loop;
2227 end Process_Project_Level_Simple_Attributes;
2229 --------------------------------------------
2230 -- Process_Project_Level_Array_Attributes --
2231 --------------------------------------------
2233 procedure Process_Project_Level_Array_Attributes is
2234 Current_Array_Id : Array_Id;
2235 Current_Array : Array_Data;
2236 Element_Id : Array_Element_Id;
2237 Element : Array_Element;
2238 List : String_List_Id;
2240 begin
2241 -- Process the associative array attributes at project level
2243 Current_Array_Id := Project.Decl.Arrays;
2244 while Current_Array_Id /= No_Array loop
2245 Current_Array := Data.Tree.Arrays.Table (Current_Array_Id);
2247 Element_Id := Current_Array.Value;
2248 while Element_Id /= No_Array_Element loop
2249 Element := Data.Tree.Array_Elements.Table (Element_Id);
2251 -- Get the name of the language
2253 Lang_Index :=
2254 Get_Language_From_Name
2255 (Project, Get_Name_String (Element.Index));
2257 if Lang_Index /= No_Language_Index then
2258 case Current_Array.Name is
2259 when Name_Inherit_Source_Path =>
2260 List := Element.Value.Values;
2262 if List /= Nil_String then
2263 Put
2264 (Into_List =>
2265 Lang_Index.Config.Include_Compatible_Languages,
2266 From_List => List,
2267 In_Tree => Data.Tree,
2268 Lower_Case => True);
2269 end if;
2271 when Name_Toolchain_Description =>
2273 -- Attribute Toolchain_Description (<language>)
2275 Lang_Index.Config.Toolchain_Description :=
2276 Element.Value.Value;
2278 when Name_Toolchain_Version =>
2280 -- Attribute Toolchain_Version (<language>)
2282 Lang_Index.Config.Toolchain_Version :=
2283 Element.Value.Value;
2285 when Name_Runtime_Library_Dir =>
2287 -- Attribute Runtime_Library_Dir (<language>)
2289 Lang_Index.Config.Runtime_Library_Dir :=
2290 Element.Value.Value;
2292 when Name_Runtime_Source_Dir =>
2294 -- Attribute Runtime_Library_Dir (<language>)
2296 Lang_Index.Config.Runtime_Source_Dir :=
2297 Element.Value.Value;
2299 when Name_Object_Generated =>
2300 declare
2301 pragma Unsuppress (All_Checks);
2302 Value : Boolean;
2304 begin
2305 Value :=
2306 Boolean'Value
2307 (Get_Name_String (Element.Value.Value));
2309 Lang_Index.Config.Object_Generated := Value;
2311 -- If no object is generated, no object may be
2312 -- linked.
2314 if not Value then
2315 Lang_Index.Config.Objects_Linked := False;
2316 end if;
2318 exception
2319 when Constraint_Error =>
2320 Error_Msg
2321 (Data.Flags,
2323 & Get_Name_String (Element.Value.Value)
2325 Element.Value.Location, Project);
2326 end;
2328 when Name_Objects_Linked =>
2329 declare
2330 pragma Unsuppress (All_Checks);
2331 Value : Boolean;
2333 begin
2334 Value :=
2335 Boolean'Value
2336 (Get_Name_String (Element.Value.Value));
2338 -- No change if Object_Generated is False, as this
2339 -- forces Objects_Linked to be False too.
2341 if Lang_Index.Config.Object_Generated then
2342 Lang_Index.Config.Objects_Linked := Value;
2343 end if;
2345 exception
2346 when Constraint_Error =>
2347 Error_Msg
2348 (Data.Flags,
2350 & Get_Name_String (Element.Value.Value)
2352 Element.Value.Location, Project);
2353 end;
2354 when others =>
2355 null;
2356 end case;
2357 end if;
2359 Element_Id := Element.Next;
2360 end loop;
2362 Current_Array_Id := Current_Array.Next;
2363 end loop;
2364 end Process_Project_Level_Array_Attributes;
2366 -- Start of processing for Check_Configuration
2368 begin
2369 Process_Project_Level_Simple_Attributes;
2370 Process_Project_Level_Array_Attributes;
2371 Process_Packages;
2373 -- For unit based languages, set Casing, Dot_Replacement and
2374 -- Separate_Suffix in Naming_Data.
2376 Lang_Index := Project.Languages;
2377 while Lang_Index /= No_Language_Index loop
2378 if Lang_Index.Name = Name_Ada then
2379 Lang_Index.Config.Naming_Data.Casing := Casing;
2380 Lang_Index.Config.Naming_Data.Dot_Replacement := Dot_Replacement;
2382 if Separate_Suffix /= No_File then
2383 Lang_Index.Config.Naming_Data.Separate_Suffix :=
2384 Separate_Suffix;
2385 end if;
2387 exit;
2388 end if;
2390 Lang_Index := Lang_Index.Next;
2391 end loop;
2393 -- Give empty names to various prefixes/suffixes, if they have not
2394 -- been specified in the configuration.
2396 if Project.Config.Archive_Suffix = No_File then
2397 Project.Config.Archive_Suffix := Empty_File;
2398 end if;
2400 if Project.Config.Shared_Lib_Prefix = No_File then
2401 Project.Config.Shared_Lib_Prefix := Empty_File;
2402 end if;
2404 if Project.Config.Shared_Lib_Suffix = No_File then
2405 Project.Config.Shared_Lib_Suffix := Empty_File;
2406 end if;
2408 Lang_Index := Project.Languages;
2409 while Lang_Index /= No_Language_Index loop
2411 -- For all languages, Compiler_Driver needs to be specified. This is
2412 -- only needed if we do intend to compile (not in GPS for instance).
2414 if Data.Flags.Compiler_Driver_Mandatory
2415 and then Lang_Index.Config.Compiler_Driver = No_File
2416 then
2417 Error_Msg_Name_1 := Lang_Index.Display_Name;
2418 Error_Msg
2419 (Data.Flags,
2422 No_Location, Project);
2424 if Lang_Index = Project.Languages then
2425 Project.Languages := Lang_Index.Next;
2426 else
2427 Prev_Index.Next := Lang_Index.Next;
2428 end if;
2430 elsif Lang_Index.Name = Name_Ada then
2431 Prev_Index := Lang_Index;
2433 -- For unit based languages, Dot_Replacement, Spec_Suffix and
2434 -- Body_Suffix need to be specified.
2436 if Lang_Index.Config.Naming_Data.Dot_Replacement = No_File then
2437 Error_Msg
2438 (Data.Flags,
2440 No_Location, Project);
2441 end if;
2443 if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then
2444 Error_Msg
2445 (Data.Flags,
2447 No_Location, Project);
2448 end if;
2450 if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then
2451 Error_Msg
2452 (Data.Flags,
2454 No_Location, Project);
2455 end if;
2457 else
2458 Prev_Index := Lang_Index;
2460 -- For file based languages, either Spec_Suffix or Body_Suffix
2461 -- need to be specified.
2463 if Data.Flags.Require_Sources_Other_Lang
2464 and then Lang_Index.Config.Naming_Data.Spec_Suffix = No_File
2465 and then Lang_Index.Config.Naming_Data.Body_Suffix = No_File
2466 then
2467 Error_Msg_Name_1 := Lang_Index.Display_Name;
2468 Error_Msg
2469 (Data.Flags,
2471 No_Location, Project);
2472 end if;
2473 end if;
2475 Lang_Index := Lang_Index.Next;
2476 end loop;
2477 end Check_Configuration;
2479 -------------------------------
2480 -- Check_If_Externally_Built --
2481 -------------------------------
2483 procedure Check_If_Externally_Built
2484 (Project : Project_Id;
2485 Data : in out Tree_Processing_Data)
2486 is
2487 Externally_Built : constant Variable_Value :=
2488 Util.Value_Of
2489 (Name_Externally_Built,
2490 Project.Decl.Attributes, Data.Tree);
2492 begin
2493 if not Externally_Built.Default then
2494 Get_Name_String (Externally_Built.Value);
2495 To_Lower (Name_Buffer (1 .. Name_Len));
2498 Project.Externally_Built := True;
2501 Error_Msg (Data.Flags,
2503 Externally_Built.Location, Project);
2504 end if;
2505 end if;
2507 -- A virtual project extending an externally built project is itself
2508 -- externally built.
2510 if Project.Virtual and then Project.Extends /= No_Project then
2511 Project.Externally_Built := Project.Extends.Externally_Built;
2512 end if;
2514 if Current_Verbosity = High then
2517 if not Project.Externally_Built then
2519 end if;
2522 end if;
2523 end Check_If_Externally_Built;
2525 ----------------------
2526 -- Check_Interfaces --
2527 ----------------------
2529 procedure Check_Interfaces
2530 (Project : Project_Id;
2531 Data : in out Tree_Processing_Data)
2532 is
2533 Interfaces : constant Prj.Variable_Value :=
2534 Prj.Util.Value_Of
2535 (Snames.Name_Interfaces,
2536 Project.Decl.Attributes,
2537 Data.Tree);
2539 Library_Interface : constant Prj.Variable_Value :=
2540 Prj.Util.Value_Of
2541 (Snames.Name_Library_Interface,
2542 Project.Decl.Attributes,
2543 Data.Tree);
2545 List : String_List_Id;
2546 Element : String_Element;
2547 Name : File_Name_Type;
2548 Iter : Source_Iterator;
2549 Source : Source_Id;
2550 Project_2 : Project_Id;
2551 Other : Source_Id;
2553 begin
2554 if not Interfaces.Default then
2556 -- Set In_Interfaces to False for all sources. It will be set to True
2557 -- later for the sources in the Interfaces list.
2559 Project_2 := Project;
2560 while Project_2 /= No_Project loop
2561 Iter := For_Each_Source (Data.Tree, Project_2);
2562 loop
2563 Source := Prj.Element (Iter);
2564 exit when Source = No_Source;
2565 Source.In_Interfaces := False;
2566 Next (Iter);
2567 end loop;
2569 Project_2 := Project_2.Extends;
2570 end loop;
2572 List := Interfaces.Values;
2573 while List /= Nil_String loop
2574 Element := Data.Tree.String_Elements.Table (List);
2575 Name := Canonical_Case_File_Name (Element.Value);
2577 Project_2 := Project;
2578 Big_Loop :
2579 while Project_2 /= No_Project loop
2580 Iter := For_Each_Source (Data.Tree, Project_2);
2582 loop
2583 Source := Prj.Element (Iter);
2584 exit when Source = No_Source;
2586 if Source.File = Name then
2587 if not Source.Locally_Removed then
2588 Source.In_Interfaces := True;
2589 Source.Declared_In_Interfaces := True;
2591 Other := Other_Part (Source);
2593 if Other /= No_Source then
2594 Other.In_Interfaces := True;
2595 Other.Declared_In_Interfaces := True;
2596 end if;
2598 if Current_Verbosity = High then
2600 Write_Line (Get_Name_String (Source.Path.Name));
2601 end if;
2602 end if;
2604 exit Big_Loop;
2605 end if;
2607 Next (Iter);
2608 end loop;
2610 Project_2 := Project_2.Extends;
2611 end loop Big_Loop;
2613 if Source = No_Source then
2614 Error_Msg_File_1 := File_Name_Type (Element.Value);
2615 Error_Msg_Name_1 := Project.Name;
2617 Error_Msg
2618 (Data.Flags,
2621 Element.Location, Project);
2622 end if;
2624 List := Element.Next;
2625 end loop;
2627 Project.Interfaces_Defined := True;
2629 elsif Project.Library and then not Library_Interface.Default then
2631 -- Set In_Interfaces to False for all sources. It will be set to True
2632 -- later for the sources in the Library_Interface list.
2634 Project_2 := Project;
2635 while Project_2 /= No_Project loop
2636 Iter := For_Each_Source (Data.Tree, Project_2);
2637 loop
2638 Source := Prj.Element (Iter);
2639 exit when Source = No_Source;
2640 Source.In_Interfaces := False;
2641 Next (Iter);
2642 end loop;
2644 Project_2 := Project_2.Extends;
2645 end loop;
2647 List := Library_Interface.Values;
2648 while List /= Nil_String loop
2649 Element := Data.Tree.String_Elements.Table (List);
2650 Get_Name_String (Element.Value);
2651 To_Lower (Name_Buffer (1 .. Name_Len));
2652 Name := Name_Find;
2654 Project_2 := Project;
2655 Big_Loop_2 :
2656 while Project_2 /= No_Project loop
2657 Iter := For_Each_Source (Data.Tree, Project_2);
2659 loop
2660 Source := Prj.Element (Iter);
2661 exit when Source = No_Source;
2663 if Source.Unit /= No_Unit_Index and then
2664 Source.Unit.Name = Name_Id (Name)
2665 then
2666 if not Source.Locally_Removed then
2667 Source.In_Interfaces := True;
2668 Source.Declared_In_Interfaces := True;
2670 Other := Other_Part (Source);
2672 if Other /= No_Source then
2673 Other.In_Interfaces := True;
2674 Other.Declared_In_Interfaces := True;
2675 end if;
2677 if Current_Verbosity = High then
2679 Write_Line (Get_Name_String (Source.Path.Name));
2680 end if;
2681 end if;
2683 exit Big_Loop_2;
2684 end if;
2686 Next (Iter);
2687 end loop;
2689 Project_2 := Project_2.Extends;
2690 end loop Big_Loop_2;
2692 List := Element.Next;
2693 end loop;
2695 Project.Interfaces_Defined := True;
2697 elsif Project.Extends /= No_Project
2698 and then Project.Extends.Interfaces_Defined
2699 then
2700 Project.Interfaces_Defined := True;
2702 Iter := For_Each_Source (Data.Tree, Project);
2703 loop
2704 Source := Prj.Element (Iter);
2705 exit when Source = No_Source;
2707 if not Source.Declared_In_Interfaces then
2708 Source.In_Interfaces := False;
2709 end if;
2711 Next (Iter);
2712 end loop;
2713 end if;
2714 end Check_Interfaces;
2716 --------------------------
2717 -- Check_Package_Naming --
2718 --------------------------
2720 procedure Check_Package_Naming
2721 (Project : Project_Id;
2722 Data : in out Tree_Processing_Data;
2723 Bodies : out Array_Element_Id;
2724 Specs : out Array_Element_Id)
2725 is
2726 Naming_Id : constant Package_Id :=
2727 Util.Value_Of
2728 (Name_Naming, Project.Decl.Packages, Data.Tree);
2729 Naming : Package_Element;
2731 Ada_Body_Suffix_Loc : Source_Ptr := No_Location;
2733 procedure Check_Naming;
2734 -- Check the validity of the Naming package (suffixes valid, ...)
2736 procedure Check_Common
2737 (Dot_Replacement : in out File_Name_Type;
2738 Casing : in out Casing_Type;
2739 Casing_Defined : out Boolean;
2740 Separate_Suffix : in out File_Name_Type;
2741 Sep_Suffix_Loc : out Source_Ptr);
2742 -- Check attributes common
2744 procedure Process_Exceptions_File_Based
2745 (Lang_Id : Language_Ptr;
2746 Kind : Source_Kind);
2747 procedure Process_Exceptions_Unit_Based
2748 (Lang_Id : Language_Ptr;
2749 Kind : Source_Kind);
2750 -- Process the naming exceptions for the two types of languages
2752 procedure Initialize_Naming_Data;
2753 -- Initialize internal naming data for the various languages
2755 ------------------
2756 -- Check_Common --
2757 ------------------
2759 procedure Check_Common
2760 (Dot_Replacement : in out File_Name_Type;
2761 Casing : in out Casing_Type;
2762 Casing_Defined : out Boolean;
2763 Separate_Suffix : in out File_Name_Type;
2764 Sep_Suffix_Loc : out Source_Ptr)
2765 is
2766 Dot_Repl : constant Variable_Value :=
2767 Util.Value_Of
2768 (Name_Dot_Replacement,
2769 Naming.Decl.Attributes,
2770 Data.Tree);
2771 Casing_String : constant Variable_Value :=
2772 Util.Value_Of
2773 (Name_Casing,
2774 Naming.Decl.Attributes,
2775 Data.Tree);
2776 Sep_Suffix : constant Variable_Value :=
2777 Util.Value_Of
2778 (Name_Separate_Suffix,
2779 Naming.Decl.Attributes,
2780 Data.Tree);
2781 Dot_Repl_Loc : Source_Ptr;
2783 begin
2784 Sep_Suffix_Loc := No_Location;
2786 if not Dot_Repl.Default then
2787 pragma Assert
2790 if Length_Of_Name (Dot_Repl.Value) = 0 then
2791 Error_Msg
2793 Dot_Repl.Location, Project);
2794 end if;
2796 Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value);
2797 Dot_Repl_Loc := Dot_Repl.Location;
2799 declare
2800 Repl : constant String := Get_Name_String (Dot_Replacement);
2802 begin
2803 -- Dot_Replacement cannot
2804 -- - be empty
2805 -- - start or end with an alphanumeric
2806 -- - be a single '_'
2807 -- - start with an '_' followed by an alphanumeric
2810 if Repl'Length = 0
2811 or else Is_Alphanumeric (Repl (Repl'First))
2812 or else Is_Alphanumeric (Repl (Repl'Last))
2813 or else (Repl (Repl'First) = '_'
2814 and then
2815 (Repl'Length = 1
2816 or else
2817 Is_Alphanumeric (Repl (Repl'First + 1))))
2818 or else (Repl'Length > 1
2819 and then
2821 then
2822 Error_Msg
2823 (Data.Flags,
2825 """ is illegal for Dot_Replacement.",
2826 Dot_Repl_Loc, Project);
2827 end if;
2828 end;
2829 end if;
2831 if Dot_Replacement /= No_File then
2832 Write_Attr
2833 ("Dot_Replacement", Get_Name_String (Dot_Replacement));
2834 end if;
2836 Casing_Defined := False;
2838 if not Casing_String.Default then
2839 pragma Assert
2840 (Casing_String.Kind = Single, "Casing is not a string");
2842 declare
2843 Casing_Image : constant String :=
2844 Get_Name_String (Casing_String.Value);
2846 begin
2847 if Casing_Image'Length = 0 then
2848 Error_Msg
2849 (Data.Flags,
2850 "Casing cannot be an empty string",
2851 Casing_String.Location, Project);
2852 end if;
2854 Casing := Value (Casing_Image);
2855 Casing_Defined := True;
2857 exception
2858 when Constraint_Error =>
2859 Name_Len := Casing_Image'Length;
2860 Name_Buffer (1 .. Name_Len) := Casing_Image;
2861 Err_Vars.Error_Msg_Name_1 := Name_Find;
2862 Error_Msg
2863 (Data.Flags,
2864 "%% is not a correct Casing",
2865 Casing_String.Location, Project);
2866 end;
2867 end if;
2869 Write_Attr ("Casing", Image (Casing));
2871 if not Sep_Suffix.Default then
2872 if Length_Of_Name (Sep_Suffix.Value) = 0 then
2873 Error_Msg
2874 (Data.Flags,
2875 "Separate_Suffix cannot be empty",
2876 Sep_Suffix.Location, Project);
2878 else
2879 Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value);
2880 Sep_Suffix_Loc := Sep_Suffix.Location;
2882 Check_Illegal_Suffix
2883 (Project, Separate_Suffix,
2884 Dot_Replacement, "Separate_Suffix", Sep_Suffix.Location,
2885 Data);
2886 end if;
2887 end if;
2889 if Separate_Suffix /= No_File then
2890 Write_Attr
2891 ("Separate_Suffix", Get_Name_String (Separate_Suffix));
2892 end if;
2893 end Check_Common;
2895 -----------------------------------
2896 -- Process_Exceptions_File_Based --
2897 -----------------------------------
2899 procedure Process_Exceptions_File_Based
2900 (Lang_Id : Language_Ptr;
2901 Kind : Source_Kind)
2902 is
2903 Lang : constant Name_Id := Lang_Id.Name;
2904 Exceptions : Array_Element_Id;
2905 Exception_List : Variable_Value;
2906 Element_Id : String_List_Id;
2907 Element : String_Element;
2908 File_Name : File_Name_Type;
2909 Source : Source_Id;
2910 Iter : Source_Iterator;
2912 begin
2913 case Kind is
2914 when Impl | Sep =>
2915 Exceptions :=
2916 Value_Of
2917 (Name_Implementation_Exceptions,
2918 In_Arrays => Naming.Decl.Arrays,
2919 In_Tree => Data.Tree);
2921 when Spec =>
2922 Exceptions :=
2923 Value_Of
2924 (Name_Specification_Exceptions,
2925 In_Arrays => Naming.Decl.Arrays,
2926 In_Tree => Data.Tree);
2927 end case;
2929 Exception_List := Value_Of
2930 (Index => Lang,
2931 In_Array => Exceptions,
2932 In_Tree => Data.Tree);
2934 if Exception_List /= Nil_Variable_Value then
2935 Element_Id := Exception_List.Values;
2936 while Element_Id /= Nil_String loop
2937 Element := Data.Tree.String_Elements.Table (Element_Id);
2938 File_Name := Canonical_Case_File_Name (Element.Value);
2940 Iter := For_Each_Source (Data.Tree, Project);
2941 loop
2942 Source := Prj.Element (Iter);
2943 exit when Source = No_Source or else Source.File = File_Name;
2944 Next (Iter);
2945 end loop;
2947 if Source = No_Source then
2948 Add_Source
2949 (Id => Source,
2950 Data => Data,
2951 Project => Project,
2952 Source_Dir_Rank => 0,
2953 Lang_Id => Lang_Id,
2954 Kind => Kind,
2955 File_Name => File_Name,
2956 Display_File => File_Name_Type (Element.Value),
2957 Naming_Exception => True);
2959 else
2960 -- Check if the file name is already recorded for another
2961 -- language or another kind.
2963 if Source.Language /= Lang_Id then
2964 Error_Msg
2965 (Data.Flags,
2966 "the same file cannot be a source of two languages",
2967 Element.Location, Project);
2969 elsif Source.Kind /= Kind then
2970 Error_Msg
2971 (Data.Flags,
2972 "the same file cannot be a source and a template",
2973 Element.Location, Project);
2974 end if;
2976 -- If the file is already recorded for the same
2977 -- language and the same kind, it means that the file
2978 -- name appears several times in the *_Exceptions
2979 -- attribute; so there is nothing to do.
2980 end if;
2982 Element_Id := Element.Next;
2983 end loop;
2984 end if;
2985 end Process_Exceptions_File_Based;
2987 -----------------------------------
2988 -- Process_Exceptions_Unit_Based --
2989 -----------------------------------
2991 procedure Process_Exceptions_Unit_Based
2992 (Lang_Id : Language_Ptr;
2993 Kind : Source_Kind)
2994 is
2995 Lang : constant Name_Id := Lang_Id.Name;
2996 Exceptions : Array_Element_Id;
2997 Element : Array_Element;
2998 Unit : Name_Id;
2999 Index : Int;
3000 File_Name : File_Name_Type;
3001 Source : Source_Id;
3003 begin
3004 case Kind is
3005 when Impl | Sep =>
3006 Exceptions :=
3007 Value_Of
3008 (Name_Body,
3009 In_Arrays => Naming.Decl.Arrays,
3010 In_Tree => Data.Tree);
3012 if Exceptions = No_Array_Element then
3013 Exceptions :=
3014 Value_Of
3015 (Name_Implementation,
3016 In_Arrays => Naming.Decl.Arrays,
3017 In_Tree => Data.Tree);
3018 end if;
3020 when Spec =>
3021 Exceptions :=
3022 Value_Of
3023 (Name_Spec,
3024 In_Arrays => Naming.Decl.Arrays,
3025 In_Tree => Data.Tree);
3027 if Exceptions = No_Array_Element then
3028 Exceptions :=
3029 Value_Of
3030 (Name_Spec,
3031 In_Arrays => Naming.Decl.Arrays,
3032 In_Tree => Data.Tree);
3033 end if;
3034 end case;
3036 while Exceptions /= No_Array_Element loop
3037 Element := Data.Tree.Array_Elements.Table (Exceptions);
3038 File_Name := Canonical_Case_File_Name (Element.Value.Value);
3040 Get_Name_String (Element.Index);
3041 To_Lower (Name_Buffer (1 .. Name_Len));
3042 Unit := Name_Find;
3043 Index := Element.Value.Index;
3045 -- For Ada, check if it is a valid unit name
3047 if Lang = Name_Ada then
3048 Get_Name_String (Element.Index);
3049 Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit);
3051 if Unit = No_Name then
3052 Err_Vars.Error_Msg_Name_1 := Element.Index;
3053 Error_Msg
3054 (Data.Flags,
3055 "%% is not a valid unit name.",
3056 Element.Value.Location, Project);
3057 end if;
3058 end if;
3060 if Unit /= No_Name then
3061 Add_Source
3062 (Id => Source,
3063 Data => Data,
3064 Project => Project,
3065 Source_Dir_Rank => 0,
3066 Lang_Id => Lang_Id,
3067 Kind => Kind,
3068 File_Name => File_Name,
3069 Display_File => File_Name_Type (Element.Value.Value),
3070 Unit => Unit,
3071 Index => Index,
3072 Location => Element.Value.Location,
3073 Naming_Exception => True);
3074 end if;
3076 Exceptions := Element.Next;
3077 end loop;
3078 end Process_Exceptions_Unit_Based;
3080 ------------------
3081 -- Check_Naming --
3082 ------------------
3084 procedure Check_Naming is
3085 Dot_Replacement : File_Name_Type :=
3086 File_Name_Type
3088 Separate_Suffix : File_Name_Type := No_File;
3089 Casing : Casing_Type := All_Lower_Case;
3090 Casing_Defined : Boolean;
3091 Lang_Id : Language_Ptr;
3092 Sep_Suffix_Loc : Source_Ptr;
3093 Suffix : Variable_Value;
3094 Lang : Name_Id;
3096 begin
3097 Check_Common
3098 (Dot_Replacement => Dot_Replacement,
3099 Casing => Casing,
3100 Casing_Defined => Casing_Defined,
3101 Separate_Suffix => Separate_Suffix,
3102 Sep_Suffix_Loc => Sep_Suffix_Loc);
3104 -- For all unit based languages, if any, set the specified value
3105 -- of Dot_Replacement, Casing and/or Separate_Suffix. Do not
3106 -- systematically overwrite, since the defaults come from the
3107 -- configuration file.
3109 if Dot_Replacement /= No_File
3110 or else Casing_Defined
3111 or else Separate_Suffix /= No_File
3112 then
3113 Lang_Id := Project.Languages;
3114 while Lang_Id /= No_Language_Index loop
3115 if Lang_Id.Config.Kind = Unit_Based then
3116 if Dot_Replacement /= No_File then
3117 Lang_Id.Config.Naming_Data.Dot_Replacement :=
3118 Dot_Replacement;
3119 end if;
3121 if Casing_Defined then
3122 Lang_Id.Config.Naming_Data.Casing := Casing;
3123 end if;
3124 end if;
3126 Lang_Id := Lang_Id.Next;
3127 end loop;
3128 end if;
3130 -- Next, get the spec and body suffixes
3132 Lang_Id := Project.Languages;
3133 while Lang_Id /= No_Language_Index loop
3134 Lang := Lang_Id.Name;
3136 -- Spec_Suffix
3138 Suffix := Value_Of
3139 (Name => Lang,
3140 Attribute_Or_Array_Name => Name_Spec_Suffix,
3141 In_Package => Naming_Id,
3142 In_Tree => Data.Tree);
3144 if Suffix = Nil_Variable_Value then
3145 Suffix := Value_Of
3146 (Name => Lang,
3147 Attribute_Or_Array_Name => Name_Specification_Suffix,
3148 In_Package => Naming_Id,
3149 In_Tree => Data.Tree);
3150 end if;
3152 if Suffix /= Nil_Variable_Value then
3153 Lang_Id.Config.Naming_Data.Spec_Suffix :=
3154 File_Name_Type (Suffix.Value);
3156 Check_Illegal_Suffix
3157 (Project,
3158 Lang_Id.Config.Naming_Data.Spec_Suffix,
3159 Lang_Id.Config.Naming_Data.Dot_Replacement,
3160 "Spec_Suffix", Suffix.Location, Data);
3162 Write_Attr
3163 ("Spec_Suffix",
3164 Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix));
3165 end if;
3167 -- Body_Suffix
3169 Suffix :=
3170 Value_Of
3171 (Name => Lang,
3172 Attribute_Or_Array_Name => Name_Body_Suffix,
3173 In_Package => Naming_Id,
3174 In_Tree => Data.Tree);
3176 if Suffix = Nil_Variable_Value then
3177 Suffix :=
3178 Value_Of
3179 (Name => Lang,
3180 Attribute_Or_Array_Name => Name_Implementation_Suffix,
3181 In_Package => Naming_Id,
3182 In_Tree => Data.Tree);
3183 end if;
3185 if Suffix /= Nil_Variable_Value then
3186 Lang_Id.Config.Naming_Data.Body_Suffix :=
3187 File_Name_Type (Suffix.Value);
3189 -- The default value of separate suffix should be the same as
3190 -- the body suffix, so we need to compute that first.
3192 if Separate_Suffix = No_File then
3193 Lang_Id.Config.Naming_Data.Separate_Suffix :=
3194 Lang_Id.Config.Naming_Data.Body_Suffix;
3195 Write_Attr
3196 ("Sep_Suffix",
3197 Get_Name_String
3198 (Lang_Id.Config.Naming_Data.Separate_Suffix));
3199 else
3200 Lang_Id.Config.Naming_Data.Separate_Suffix :=
3201 Separate_Suffix;
3202 end if;
3204 Check_Illegal_Suffix
3205 (Project,
3206 Lang_Id.Config.Naming_Data.Body_Suffix,
3207 Lang_Id.Config.Naming_Data.Dot_Replacement,
3208 "Body_Suffix", Suffix.Location, Data);
3210 Write_Attr
3211 ("Body_Suffix",
3212 Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix));
3214 elsif Separate_Suffix /= No_File then
3215 Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix;
3216 end if;
3218 -- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix,
3219 -- since that would cause a clear ambiguity. Note that we do allow
3220 -- a Spec_Suffix to have the same termination as one of these,
3221 -- which causes a potential ambiguity, but we resolve that my
3222 -- matching the longest possible suffix.
3224 if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File
3225 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
3226 Lang_Id.Config.Naming_Data.Body_Suffix
3227 then
3228 Error_Msg
3229 (Data.Flags,
3230 "Body_Suffix ("""
3231 & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)
3232 & """) cannot be the same as Spec_Suffix.",
3233 Ada_Body_Suffix_Loc, Project);
3234 end if;
3236 if Lang_Id.Config.Naming_Data.Body_Suffix /=
3237 Lang_Id.Config.Naming_Data.Separate_Suffix
3238 and then Lang_Id.Config.Naming_Data.Spec_Suffix =
3239 Lang_Id.Config.Naming_Data.Separate_Suffix
3240 then
3241 Error_Msg
3242 (Data.Flags,
3243 "Separate_Suffix ("""
3244 & Get_Name_String
3245 (Lang_Id.Config.Naming_Data.Separate_Suffix)
3246 & """) cannot be the same as Spec_Suffix.",
3247 Sep_Suffix_Loc, Project);
3248 end if;
3250 Lang_Id := Lang_Id.Next;
3251 end loop;
3253 -- Get the naming exceptions for all languages
3255 for Kind in Spec .. Impl loop
3256 Lang_Id := Project.Languages;
3257 while Lang_Id /= No_Language_Index loop
3258 case Lang_Id.Config.Kind is
3259 when File_Based =>
3260 Process_Exceptions_File_Based (Lang_Id, Kind);
3262 when Unit_Based =>
3263 Process_Exceptions_Unit_Based (Lang_Id, Kind);
3264 end case;
3266 Lang_Id := Lang_Id.Next;
3267 end loop;
3268 end loop;
3269 end Check_Naming;
3271 ----------------------------
3272 -- Initialize_Naming_Data --
3273 ----------------------------
3275 procedure Initialize_Naming_Data is
3276 Specs : Array_Element_Id :=
3277 Util.Value_Of
3278 (Name_Spec_Suffix,
3279 Naming.Decl.Arrays,
3280 Data.Tree);
3282 Impls : Array_Element_Id :=
3283 Util.Value_Of
3284 (Name_Body_Suffix,
3285 Naming.Decl.Arrays,
3286 Data.Tree);
3288 Lang : Language_Ptr;
3289 Lang_Name : Name_Id;
3290 Value : Variable_Value;
3291 Extended : Project_Id;
3293 begin
3294 -- At this stage, the project already contains the default extensions
3295 -- for the various languages. We now merge those suffixes read in the
3296 -- user project, and they override the default.
3298 while Specs /= No_Array_Element loop
3299 Lang_Name := Data.Tree.Array_Elements.Table (Specs).Index;
3300 Lang :=
3301 Get_Language_From_Name
3302 (Project, Name => Get_Name_String (Lang_Name));
3304 -- An extending project inherits its parent projects' languages
3305 -- so if needed we should create entries for those languages
3310 Lang := Get_Language_From_Name
3319 Lang.First_Source := null;
3320 Lang.Next := Project.Languages;
3321 Project.Languages := Lang;
3322 end if;
3323 end if;
3325 -- If language was not found in project or the projects it extends
3327 if Lang = null then
3328 if Current_Verbosity = High then
3329 Write_Line
3330 ("Ignoring spec naming data for "
3331 & Get_Name_String (Lang_Name)
3332 & " since language is not defined for this project");
3333 end if;
3335 else
3336 Value := Data.Tree.Array_Elements.Table (Specs).Value;
3338 if Value.Kind = Single then
3339 Lang.Config.Naming_Data.Spec_Suffix :=
3340 Canonical_Case_File_Name (Value.Value);
3341 end if;
3342 end if;
3344 Specs := Data.Tree.Array_Elements.Table (Specs).Next;
3345 end loop;
3347 while Impls /= No_Array_Element loop
3348 Lang_Name := Data.Tree.Array_Elements.Table (Impls).Index;
3349 Lang :=
3350 Get_Language_From_Name
3351 (Project, Name => Get_Name_String (Lang_Name));
3353 if Lang = null then
3354 if Current_Verbosity = High then
3355 Write_Line
3356 ("Ignoring impl naming data for "
3357 & Get_Name_String (Lang_Name)
3358 & " since language is not defined for this project");
3359 end if;
3360 else
3361 Value := Data.Tree.Array_Elements.Table (Impls).Value;
3363 if Lang.Name = Name_Ada then
3364 Ada_Body_Suffix_Loc := Value.Location;
3365 end if;
3367 if Value.Kind = Single then
3368 Lang.Config.Naming_Data.Body_Suffix :=
3369 Canonical_Case_File_Name (Value.Value);
3370 end if;
3371 end if;
3373 Impls := Data.Tree.Array_Elements.Table (Impls).Next;
3374 end loop;
3375 end Initialize_Naming_Data;
3377 -- Start of processing for Check_Naming_Schemes
3379 begin
3380 Specs := No_Array_Element;
3381 Bodies := No_Array_Element;
3383 -- No Naming package or parsing a configuration file? nothing to do
3385 if Naming_Id /= No_Package
3386 and then Project.Qualifier /= Configuration
3387 then
3388 Naming := Data.Tree.Packages.Table (Naming_Id);
3390 if Current_Verbosity = High then
3391 Write_Line ("Checking package Naming for project "
3392 & Get_Name_String (Project.Name));
3393 end if;
3395 Initialize_Naming_Data;
3396 Check_Naming;
3397 end if;
3398 end Check_Package_Naming;
3400 ------------------------------
3401 -- Check_Library_Attributes --
3402 ------------------------------
3404 procedure Check_Library_Attributes
3405 (Project : Project_Id;
3406 Data : in out Tree_Processing_Data)
3407 is
3408 Attributes : constant Prj.Variable_Id := Project.Decl.Attributes;
3410 Lib_Dir : constant Prj.Variable_Value :=
3411 Prj.Util.Value_Of
3412 (Snames.Name_Library_Dir, Attributes, Data.Tree);
3414 Lib_Name : constant Prj.Variable_Value :=
3415 Prj.Util.Value_Of
3416 (Snames.Name_Library_Name, Attributes, Data.Tree);
3418 Lib_Version : constant Prj.Variable_Value :=
3419 Prj.Util.Value_Of
3420 (Snames.Name_Library_Version, Attributes, Data.Tree);
3422 Lib_ALI_Dir : constant Prj.Variable_Value :=
3423 Prj.Util.Value_Of
3424 (Snames.Name_Library_Ali_Dir, Attributes, Data.Tree);
3426 Lib_GCC : constant Prj.Variable_Value :=
3427 Prj.Util.Value_Of
3428 (Snames.Name_Library_GCC, Attributes, Data.Tree);
3430 The_Lib_Kind : constant Prj.Variable_Value :=
3431 Prj.Util.Value_Of
3432 (Snames.Name_Library_Kind, Attributes, Data.Tree);
3434 Imported_Project_List : Project_List;
3436 Continuation : String_Access := No_Continuation_String'Access;
3438 Support_For_Libraries : Library_Support;
3440 Library_Directory_Present : Boolean;
3442 procedure Check_Library (Proj : Project_Id; Extends : Boolean);
3443 -- Check if an imported or extended project if also a library project
3445 -------------------
3446 -- Check_Library --
3447 -------------------
3449 procedure Check_Library (Proj : Project_Id; Extends : Boolean) is
3450 Src_Id : Source_Id;
3451 Iter : Source_Iterator;
3453 begin
3454 if Proj /= No_Project then
3455 if not Proj.Library then
3457 -- The only not library projects that are OK are those that
3458 -- have no sources. However, header files from non-Ada
3459 -- languages are OK, as there is nothing to compile.
3461 Iter := For_Each_Source (Data.Tree, Proj);
3462 loop
3463 Src_Id := Prj.Element (Iter);
3464 exit when Src_Id = No_Source
3465 or else Src_Id.Language.Config.Kind /= File_Based
3466 or else Src_Id.Kind /= Spec;
3467 Next (Iter);
3468 end loop;
3470 if Src_Id /= No_Source then
3471 Error_Msg_Name_1 := Project.Name;
3472 Error_Msg_Name_2 := Proj.Name;
3474 if Extends then
3475 if Project.Library_Kind /= Static then
3476 Error_Msg
3477 (Data.Flags,
3478 Continuation.all &
3479 "shared library project %% cannot extend " &
3480 "project %% that is not a library project",
3481 Project.Location, Project);
3482 Continuation := Continuation_String'Access;
3483 end if;
3485 elsif (not Unchecked_Shared_Lib_Imports)
3486 and then Project.Library_Kind /= Static
3487 then
3488 Error_Msg
3489 (Data.Flags,
3490 Continuation.all &
3491 "shared library project %% cannot import project %% " &
3492 "that is not a shared library project",
3493 Project.Location, Project);
3494 Continuation := Continuation_String'Access;
3495 end if;
3496 end if;
3498 elsif Project.Library_Kind /= Static and then
3499 Proj.Library_Kind = Static
3500 then
3501 Error_Msg_Name_1 := Project.Name;
3502 Error_Msg_Name_2 := Proj.Name;
3504 if Extends then
3505 Error_Msg
3506 (Data.Flags,
3507 Continuation.all &
3508 "shared library project %% cannot extend static " &
3509 "library project %%",
3510 Project.Location, Project);
3511 Continuation := Continuation_String'Access;
3513 elsif not Unchecked_Shared_Lib_Imports then
3514 Error_Msg
3515 (Data.Flags,
3516 Continuation.all &
3517 "shared library project %% cannot import static " &
3518 "library project %%",
3519 Project.Location, Project);
3520 Continuation := Continuation_String'Access;
3521 end if;
3523 end if;
3524 end if;
3525 end Check_Library;
3527 Dir_Exists : Boolean;
3529 -- Start of processing for Check_Library_Attributes
3531 begin
3532 Library_Directory_Present := Lib_Dir.Value /= Empty_String;
3534 -- Special case of extending project
3536 if Project.Extends /= No_Project then
3538 -- If the project extended is a library project, we inherit the
3539 -- library name, if it is not redefined; we check that the library
3540 -- directory is specified.
3542 if Project.Extends.Library then
3543 if Project.Qualifier = Standard then
3544 Error_Msg
3545 (Data.Flags,
3546 "a standard project cannot extend a library project",
3547 Project.Location, Project);
3549 else
3550 if Lib_Name.Default then
3551 Project.Library_Name := Project.Extends.Library_Name;
3552 end if;
3554 if Lib_Dir.Default then
3555 if not Project.Virtual then
3556 Error_Msg
3557 (Data.Flags,
3558 "a project extending a library project must " &
3559 "specify an attribute Library_Dir",
3560 Project.Location, Project);
3562 else
3563 -- For a virtual project extending a library project,
3564 -- inherit library directory.
3566 Project.Library_Dir := Project.Extends.Library_Dir;
3567 Library_Directory_Present := True;
3568 end if;
3569 end if;
3570 end if;
3571 end if;
3572 end if;
3574 pragma Assert (Lib_Name.Kind = Single);
3576 if Lib_Name.Value = Empty_String then
3577 if Current_Verbosity = High
3578 and then Project.Library_Name = No_Name
3579 then
3580 Write_Line ("No library name");
3581 end if;
3583 else
3584 -- There is no restriction on the syntax of library names
3586 Project.Library_Name := Lib_Name.Value;
3587 end if;
3589 if Project.Library_Name /= No_Name then
3590 if Current_Verbosity = High then
3591 Write_Attr
3592 ("Library name", Get_Name_String (Project.Library_Name));
3593 end if;
3595 pragma Assert (Lib_Dir.Kind = Single);
3597 if not Library_Directory_Present then
3598 if Current_Verbosity = High then
3599 Write_Line ("No library directory");
3600 end if;
3602 else
3603 -- Find path name (unless inherited), check that it is a directory
3605 if Project.Library_Dir = No_Path_Information then
3606 Locate_Directory
3607 (Project,
3608 File_Name_Type (Lib_Dir.Value),
3609 Path => Project.Library_Dir,
3610 Dir_Exists => Dir_Exists,
3611 Data => Data,
3612 Create => "library",
3613 Must_Exist => False,
3614 Location => Lib_Dir.Location,
3615 Externally_Built => Project.Externally_Built);
3617 else
3618 Dir_Exists :=
3619 Is_Directory
3620 (Get_Name_String
3621 (Project.Library_Dir.Display_Name));
3622 end if;
3624 if not Dir_Exists then
3626 -- Get the absolute name of the library directory that
3627 -- does not exist, to report an error.
3629 Err_Vars.Error_Msg_File_1 :=
3630 File_Name_Type (Project.Library_Dir.Display_Name);
3631 Error_Msg
3632 (Data.Flags,
3633 "library directory { does not exist",
3634 Lib_Dir.Location, Project);
3636 -- The library directory cannot be the same as the Object
3637 -- directory.
3639 elsif Project.Library_Dir.Name = Project.Object_Directory.Name then
3640 Error_Msg
3641 (Data.Flags,
3642 "library directory cannot be the same " &
3643 "as object directory",
3644 Lib_Dir.Location, Project);
3645 Project.Library_Dir := No_Path_Information;
3647 else
3648 declare
3649 OK : Boolean := True;
3650 Dirs_Id : String_List_Id;
3651 Dir_Elem : String_Element;
3652 Pid : Project_List;
3654 begin
3655 -- The library directory cannot be the same as a source
3656 -- directory of the current project.
3658 Dirs_Id := Project.Source_Dirs;
3659 while Dirs_Id /= Nil_String loop
3660 Dir_Elem := Data.Tree.String_Elements.Table (Dirs_Id);
3661 Dirs_Id := Dir_Elem.Next;
3663 if Project.Library_Dir.Name =
3664 Path_Name_Type (Dir_Elem.Value)
3665 then
3666 Err_Vars.Error_Msg_File_1 :=
3667 File_Name_Type (Dir_Elem.Value);
3668 Error_Msg
3669 (Data.Flags,
3670 "library directory cannot be the same " &
3671 "as source directory {",
3672 Lib_Dir.Location, Project);
3673 OK := False;
3674 exit;
3675 end if;
3676 end loop;
3678 if OK then
3680 -- The library directory cannot be the same as a source
3681 -- directory of another project either.
3683 Pid := Data.Tree.Projects;
3684 Project_Loop : loop
3685 exit Project_Loop when Pid = null;
3687 if Pid.Project /= Project then
3688 Dirs_Id := Pid.Project.Source_Dirs;
3690 Dir_Loop : while Dirs_Id /= Nil_String loop
3691 Dir_Elem :=
3692 Data.Tree.String_Elements.Table (Dirs_Id);
3693 Dirs_Id := Dir_Elem.Next;
3695 if Project.Library_Dir.Name =
3696 Path_Name_Type (Dir_Elem.Value)
3697 then
3698 Err_Vars.Error_Msg_File_1 :=
3699 File_Name_Type (Dir_Elem.Value);
3700 Err_Vars.Error_Msg_Name_1 := Pid.Project.Name;
3702 Error_Msg
3703 (Data.Flags,
3704 "library directory cannot be the same " &
3705 "as source directory { of project %%",
3706 Lib_Dir.Location, Project);
3707 OK := False;
3708 exit Project_Loop;
3709 end if;
3710 end loop Dir_Loop;
3711 end if;
3713 Pid := Pid.Next;
3714 end loop Project_Loop;
3715 end if;
3717 if not OK then
3718 Project.Library_Dir := No_Path_Information;
3720 elsif Current_Verbosity = High then
3722 -- Display the Library directory in high verbosity
3724 Write_Attr
3725 ("Library directory",
3726 Get_Name_String (Project.Library_Dir.Display_Name));
3727 end if;
3728 end;
3729 end if;
3730 end if;
3732 end if;
3734 Project.Library :=
3735 Project.Library_Dir /= No_Path_Information
3736 and then Project.Library_Name /= No_Name;
3738 if Project.Extends = No_Project then
3739 case Project.Qualifier is
3740 when Standard =>
3741 if Project.Library then
3742 Error_Msg
3743 (Data.Flags,
3744 "a standard project cannot be a library project",
3745 Lib_Name.Location, Project);
3746 end if;
3748 when Library =>
3749 if not Project.Library then
3750 if Project.Library_Dir = No_Path_Information then
3751 Error_Msg
3752 (Data.Flags,
3754 Project.Location, Project);
3755 end if;
3757 if Project.Library_Name = No_Name then
3758 Error_Msg
3759 (Data.Flags,
3761 Project.Location, Project);
3762 end if;
3763 end if;
3765 when others =>
3766 null;
3768 end case;
3769 end if;
3771 if Project.Library then
3772 Support_For_Libraries := Project.Config.Lib_Support;
3774 if Support_For_Libraries = Prj.None then
3775 Error_Msg
3776 (Data.Flags,
3777 "?libraries are not supported on this platform",
3778 Lib_Name.Location, Project);
3779 Project.Library := False;
3781 else
3782 if Lib_ALI_Dir.Value = Empty_String then
3783 if Current_Verbosity = High then
3784 Write_Line ("No library ALI directory specified");
3785 end if;
3787 Project.Library_ALI_Dir := Project.Library_Dir;
3789 else
3790 -- Find path name, check that it is a directory
3792 Locate_Directory
3793 (Project,
3794 File_Name_Type (Lib_ALI_Dir.Value),
3795 Path => Project.Library_ALI_Dir,
3796 Create => "library ALI",
3797 Dir_Exists => Dir_Exists,
3798 Data => Data,
3799 Must_Exist => False,
3800 Location => Lib_ALI_Dir.Location,
3801 Externally_Built => Project.Externally_Built);
3803 if not Dir_Exists then
3805 -- Get the absolute name of the library ALI directory that
3806 -- does not exist, to report an error.
3808 Err_Vars.Error_Msg_File_1 :=
3809 File_Name_Type (Project.Library_ALI_Dir.Display_Name);
3810 Error_Msg
3811 (Data.Flags,
3813 Lib_ALI_Dir.Location, Project);
3814 end if;
3816 if Project.Library_ALI_Dir /= Project.Library_Dir then
3818 -- The library ALI directory cannot be the same as the
3819 -- Object directory.
3821 if Project.Library_ALI_Dir = Project.Object_Directory then
3822 Error_Msg
3823 (Data.Flags,
3825 "as object directory",
3826 Lib_ALI_Dir.Location, Project);
3827 Project.Library_ALI_Dir := No_Path_Information;
3829 else
3830 declare
3831 OK : Boolean := True;
3832 Dirs_Id : String_List_Id;
3833 Dir_Elem : String_Element;
3834 Pid : Project_List;
3836 begin
3837 -- The library ALI directory cannot be the same as
3838 -- a source directory of the current project.
3840 Dirs_Id := Project.Source_Dirs;
3841 while Dirs_Id /= Nil_String loop
3842 Dir_Elem :=
3843 Data.Tree.String_Elements.Table (Dirs_Id);
3844 Dirs_Id := Dir_Elem.Next;
3846 if Project.Library_ALI_Dir.Name =
3847 Path_Name_Type (Dir_Elem.Value)
3848 then
3849 Err_Vars.Error_Msg_File_1 :=
3850 File_Name_Type (Dir_Elem.Value);
3851 Error_Msg
3852 (Data.Flags,
3854 "the same as source directory {",
3855 Lib_ALI_Dir.Location, Project);
3856 OK := False;
3857 exit;
3858 end if;
3859 end loop;
3861 if OK then
3863 -- The library ALI directory cannot be the same as
3864 -- a source directory of another project either.
3866 Pid := Data.Tree.Projects;
3867 ALI_Project_Loop : loop
3868 exit ALI_Project_Loop when Pid = null;
3870 if Pid.Project /= Project then
3871 Dirs_Id := Pid.Project.Source_Dirs;
3873 ALI_Dir_Loop :
3874 while Dirs_Id /= Nil_String loop
3875 Dir_Elem :=
3876 Data.Tree.String_Elements.Table
3877 (Dirs_Id);
3878 Dirs_Id := Dir_Elem.Next;
3880 if Project.Library_ALI_Dir.Name =
3881 Path_Name_Type (Dir_Elem.Value)
3882 then
3883 Err_Vars.Error_Msg_File_1 :=
3884 File_Name_Type (Dir_Elem.Value);
3885 Err_Vars.Error_Msg_Name_1 :=
3886 Pid.Project.Name;
3888 Error_Msg
3889 (Data.Flags,
3891 "be the same as source directory " &
3892 "{ of project %%",
3893 Lib_ALI_Dir.Location, Project);
3894 OK := False;
3895 exit ALI_Project_Loop;
3896 end if;
3897 end loop ALI_Dir_Loop;
3898 end if;
3899 Pid := Pid.Next;
3900 end loop ALI_Project_Loop;
3901 end if;
3903 if not OK then
3904 Project.Library_ALI_Dir := No_Path_Information;
3906 elsif Current_Verbosity = High then
3908 -- Display Library ALI directory in high verbosity
3910 Write_Attr
3911 ("Library ALI dir",
3912 Get_Name_String
3913 (Project.Library_ALI_Dir.Display_Name));
3914 end if;
3915 end;
3916 end if;
3917 end if;
3918 end if;
3920 pragma Assert (Lib_Version.Kind = Single);
3922 if Lib_Version.Value = Empty_String then
3923 if Current_Verbosity = High then
3924 Write_Line ("No library version specified");
3925 end if;
3927 else
3928 Project.Lib_Internal_Name := Lib_Version.Value;
3929 end if;
3931 pragma Assert (The_Lib_Kind.Kind = Single);
3933 if The_Lib_Kind.Value = Empty_String then
3934 if Current_Verbosity = High then
3935 Write_Line ("No library kind specified");
3936 end if;
3938 else
3939 Get_Name_String (The_Lib_Kind.Value);
3941 declare
3942 Kind_Name : constant String :=
3943 To_Lower (Name_Buffer (1 .. Name_Len));
3945 OK : Boolean := True;
3947 begin
3948 if Kind_Name = "static" then
3949 Project.Library_Kind := Static;
3951 elsif Kind_Name = "dynamic" then
3952 Project.Library_Kind := Dynamic;
3954 elsif Kind_Name = "relocatable" then
3955 Project.Library_Kind := Relocatable;
3957 else
3958 Error_Msg
3959 (Data.Flags,
3960 "illegal value for Library_Kind",
3961 The_Lib_Kind.Location, Project);
3962 OK := False;
3963 end if;
3965 if Current_Verbosity = High and then OK then
3966 Write_Attr ("Library kind", Kind_Name);
3967 end if;
3969 if Project.Library_Kind /= Static then
3970 if Support_For_Libraries = Prj.Static_Only then
3971 Error_Msg
3972 (Data.Flags,
3973 "only static libraries are supported " &
3974 "on this platform",
3975 The_Lib_Kind.Location, Project);
3976 Project.Library := False;
3978 else
3979 -- Check if (obsolescent) attribute Library_GCC or
3980 -- Linker'Driver is declared.
3982 if Lib_GCC.Value /= Empty_String then
3983 Error_Msg
3984 (Data.Flags,
3987 Lib_GCC.Location, Project);
3988 Project.Config.Shared_Lib_Driver :=
3989 File_Name_Type (Lib_GCC.Value);
3991 else
3992 declare
3993 Linker : constant Package_Id :=
3994 Value_Of
3995 (Name_Linker,
3996 Project.Decl.Packages,
3997 Data.Tree);
3998 Driver : constant Variable_Value :=
3999 Value_Of
4000 (Name => No_Name,
4001 Attribute_Or_Array_Name =>
4002 Name_Driver,
4003 In_Package => Linker,
4004 In_Tree => Data.Tree);
4006 begin
4007 if Driver /= Nil_Variable_Value
4008 and then Driver.Value /= Empty_String
4009 then
4010 Project.Config.Shared_Lib_Driver :=
4011 File_Name_Type (Driver.Value);
4012 end if;
4013 end;
4014 end if;
4015 end if;
4016 end if;
4017 end;
4018 end if;
4020 if Project.Library then
4021 if Current_Verbosity = High then
4023 end if;
4025 Check_Library (Project.Extends, Extends => True);
4027 Imported_Project_List := Project.Imported_Projects;
4028 while Imported_Project_List /= null loop
4029 Check_Library
4030 (Imported_Project_List.Project,
4031 Extends => False);
4032 Imported_Project_List := Imported_Project_List.Next;
4033 end loop;
4034 end if;
4036 end if;
4037 end if;
4039 -- Check if Linker'Switches or Linker'Default_Switches are declared.
4040 -- Warn if they are declared, as it is a common error to think that
4043 if Project.Library then
4044 declare
4045 Linker_Package_Id : constant Package_Id :=
4046 Util.Value_Of
4047 (Name_Linker,
4048 Project.Decl.Packages, Data.Tree);
4049 Linker_Package : Package_Element;
4050 Switches : Array_Element_Id := No_Array_Element;
4052 begin
4053 if Linker_Package_Id /= No_Package then
4054 Linker_Package := Data.Tree.Packages.Table (Linker_Package_Id);
4056 Switches :=
4057 Value_Of
4058 (Name => Name_Switches,
4059 In_Arrays => Linker_Package.Decl.Arrays,
4060 In_Tree => Data.Tree);
4062 if Switches = No_Array_Element then
4063 Switches :=
4064 Value_Of
4065 (Name => Name_Default_Switches,
4066 In_Arrays => Linker_Package.Decl.Arrays,
4067 In_Tree => Data.Tree);
4068 end if;
4070 if Switches /= No_Array_Element then
4071 Error_Msg
4072 (Data.Flags,
4075 No_Location, Project);
4076 end if;
4077 end if;
4078 end;
4079 end if;
4081 if Project.Extends /= No_Project then
4082 Project.Extends.Library := False;
4083 end if;
4084 end Check_Library_Attributes;
4086 ---------------------------------
4087 -- Check_Programming_Languages --
4088 ---------------------------------
4090 procedure Check_Programming_Languages
4091 (Project : Project_Id;
4092 Data : in out Tree_Processing_Data)
4093 is
4094 Languages : Variable_Value := Nil_Variable_Value;
4095 Def_Lang : Variable_Value := Nil_Variable_Value;
4096 Def_Lang_Id : Name_Id;
4098 procedure Add_Language (Name, Display_Name : Name_Id);
4099 -- Add a new language to the list of languages for the project.
4100 -- Nothing is done if the language has already been defined
4102 ------------------
4103 -- Add_Language --
4104 ------------------
4106 procedure Add_Language (Name, Display_Name : Name_Id) is
4107 Lang : Language_Ptr;
4109 begin
4110 Lang := Project.Languages;
4111 while Lang /= No_Language_Index loop
4112 if Name = Lang.Name then
4113 return;
4114 end if;
4116 Lang := Lang.Next;
4117 end loop;
4119 Lang := new Language_Data'(No_Language_Data);
4120 Lang.Next := Project.Languages;
4121 Project.Languages := Lang;
4122 Lang.Name := Name;
4123 Lang.Display_Name := Display_Name;
4125 if Name = Name_Ada then
4126 Lang.Config.Kind := Unit_Based;
4127 Lang.Config.Dependency_Kind := ALI_File;
4128 else
4129 Lang.Config.Kind := File_Based;
4130 end if;
4131 end Add_Language;
4133 -- Start of processing for Check_Programming_Languages
4135 begin
4136 Project.Languages := null;
4137 Languages :=
4138 Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, Data.Tree);
4139 Def_Lang :=
4140 Prj.Util.Value_Of
4141 (Name_Default_Language, Project.Decl.Attributes, Data.Tree);
4143 if Project.Source_Dirs /= Nil_String then
4145 -- Check if languages are specified in this project
4147 if Languages.Default then
4149 -- Fail if there is no default language defined
4151 if Def_Lang.Default then
4152 Error_Msg
4153 (Data.Flags,
4155 Project.Location, Project);
4156 Def_Lang_Id := No_Name;
4158 else
4159 Get_Name_String (Def_Lang.Value);
4160 To_Lower (Name_Buffer (1 .. Name_Len));
4161 Def_Lang_Id := Name_Find;
4162 end if;
4164 if Def_Lang_Id /= No_Name then
4165 Get_Name_String (Def_Lang_Id);
4166 Name_Buffer (1) := GNAT.Case_Util.To_Upper (Name_Buffer (1));
4167 Add_Language
4168 (Name => Def_Lang_Id,
4169 Display_Name => Name_Find);
4170 end if;
4172 else
4173 declare
4174 Current : String_List_Id := Languages.Values;
4175 Element : String_Element;
4177 begin
4178 -- If there are no languages declared, there are no sources
4180 if Current = Nil_String then
4181 Project.Source_Dirs := Nil_String;
4183 if Project.Qualifier = Standard then
4184 Error_Msg
4185 (Data.Flags,
4187 Languages.Location, Project);
4188 end if;
4190 else
4191 -- Look through all the languages specified in attribute
4192 -- Languages.
4194 while Current /= Nil_String loop
4195 Element := Data.Tree.String_Elements.Table (Current);
4196 Get_Name_String (Element.Value);
4197 To_Lower (Name_Buffer (1 .. Name_Len));
4199 Add_Language
4200 (Name => Name_Find,
4201 Display_Name => Element.Value);
4203 Current := Element.Next;
4204 end loop;
4205 end if;
4206 end;
4207 end if;
4208 end if;
4209 end Check_Programming_Languages;
4211 -------------------------------
4212 -- Check_Stand_Alone_Library --
4213 -------------------------------
4215 procedure Check_Stand_Alone_Library
4216 (Project : Project_Id;
4217 Data : in out Tree_Processing_Data)
4218 is
4219 Lib_Interfaces : constant Prj.Variable_Value :=
4220 Prj.Util.Value_Of
4221 (Snames.Name_Library_Interface,
4222 Project.Decl.Attributes,
4223 Data.Tree);
4225 Lib_Auto_Init : constant Prj.Variable_Value :=
4226 Prj.Util.Value_Of
4227 (Snames.Name_Library_Auto_Init,
4228 Project.Decl.Attributes,
4229 Data.Tree);
4231 Lib_Src_Dir : constant Prj.Variable_Value :=
4232 Prj.Util.Value_Of
4233 (Snames.Name_Library_Src_Dir,
4234 Project.Decl.Attributes,
4235 Data.Tree);
4237 Lib_Symbol_File : constant Prj.Variable_Value :=
4238 Prj.Util.Value_Of
4239 (Snames.Name_Library_Symbol_File,
4240 Project.Decl.Attributes,
4241 Data.Tree);
4243 Lib_Symbol_Policy : constant Prj.Variable_Value :=
4244 Prj.Util.Value_Of
4245 (Snames.Name_Library_Symbol_Policy,
4246 Project.Decl.Attributes,
4247 Data.Tree);
4249 Lib_Ref_Symbol_File : constant Prj.Variable_Value :=
4250 Prj.Util.Value_Of
4251 (Snames.Name_Library_Reference_Symbol_File,
4252 Project.Decl.Attributes,
4253 Data.Tree);
4255 Auto_Init_Supported : Boolean;
4256 OK : Boolean := True;
4257 Source : Source_Id;
4258 Next_Proj : Project_Id;
4259 Iter : Source_Iterator;
4261 begin
4262 Auto_Init_Supported := Project.Config.Auto_Init_Supported;
4264 pragma Assert (Lib_Interfaces.Kind = List);
4266 -- It is a stand-alone library project file if attribute
4267 -- Library_Interface is defined.
4269 if not Lib_Interfaces.Default then
4270 declare
4271 Interfaces : String_List_Id := Lib_Interfaces.Values;
4272 Interface_ALIs : String_List_Id := Nil_String;
4273 Unit : Name_Id;
4275 begin
4276 Project.Standalone_Library := True;
4278 -- Library_Interface cannot be an empty list
4280 if Interfaces = Nil_String then
4281 Error_Msg
4282 (Data.Flags,
4284 Lib_Interfaces.Location, Project);
4285 end if;
4287 -- Process each unit name specified in the attribute
4288 -- Library_Interface.
4290 while Interfaces /= Nil_String loop
4291 Get_Name_String
4292 (Data.Tree.String_Elements.Table (Interfaces).Value);
4293 To_Lower (Name_Buffer (1 .. Name_Len));
4295 if Name_Len = 0 then
4296 Error_Msg
4297 (Data.Flags,
4299 Data.Tree.String_Elements.Table (Interfaces).Location,
4300 Project);
4302 else
4303 Unit := Name_Find;
4304 Error_Msg_Name_1 := Unit;
4306 Next_Proj := Project.Extends;
4307 Iter := For_Each_Source (Data.Tree, Project);
4308 loop
4309 while Prj.Element (Iter) /= No_Source
4310 and then
4311 (Prj.Element (Iter).Unit = null
4312 or else Prj.Element (Iter).Unit.Name /= Unit)
4313 loop
4314 Next (Iter);
4315 end loop;
4317 Source := Prj.Element (Iter);
4318 exit when Source /= No_Source
4319 or else Next_Proj = No_Project;
4321 Iter := For_Each_Source (Data.Tree, Next_Proj);
4322 Next_Proj := Next_Proj.Extends;
4323 end loop;
4325 if Source /= No_Source then
4326 if Source.Kind = Sep then
4327 Source := No_Source;
4329 elsif Source.Kind = Spec
4330 and then Other_Part (Source) /= No_Source
4331 then
4332 Source := Other_Part (Source);
4333 end if;
4334 end if;
4336 if Source /= No_Source then
4337 if Source.Project /= Project
4338 and then not Is_Extending (Project, Source.Project)
4339 then
4340 Source := No_Source;
4341 end if;
4342 end if;
4344 if Source = No_Source then
4345 Error_Msg
4346 (Data.Flags,
4348 Data.Tree.String_Elements.Table
4349 (Interfaces).Location, Project);
4351 else
4352 if Source.Kind = Spec
4353 and then Other_Part (Source) /= No_Source
4354 then
4355 Source := Other_Part (Source);
4356 end if;
4358 String_Element_Table.Increment_Last
4359 (Data.Tree.String_Elements);
4361 Data.Tree.String_Elements.Table
4362 (String_Element_Table.Last
4363 (Data.Tree.String_Elements)) :=
4364 (Value => Name_Id (Source.Dep_Name),
4365 Index => 0,
4366 Display_Value => Name_Id (Source.Dep_Name),
4367 Location =>
4368 Data.Tree.String_Elements.Table
4369 (Interfaces).Location,
4370 Flag => False,
4371 Next => Interface_ALIs);
4373 Interface_ALIs :=
4374 String_Element_Table.Last
4375 (Data.Tree.String_Elements);
4376 end if;
4377 end if;
4379 Interfaces := Data.Tree.String_Elements.Table (Interfaces).Next;
4380 end loop;
4382 -- Put the list of Interface ALIs in the project data
4384 Project.Lib_Interface_ALIs := Interface_ALIs;
4386 -- Check value of attribute Library_Auto_Init and set
4387 -- Lib_Auto_Init accordingly.
4389 if Lib_Auto_Init.Default then
4391 -- If no attribute Library_Auto_Init is declared, then set auto
4392 -- init only if it is supported.
4394 Project.Lib_Auto_Init := Auto_Init_Supported;
4396 else
4397 Get_Name_String (Lib_Auto_Init.Value);
4398 To_Lower (Name_Buffer (1 .. Name_Len));
4401 Project.Lib_Auto_Init := False;
4404 if Auto_Init_Supported then
4405 Project.Lib_Auto_Init := True;
4407 else
4409 -- supported.
4411 Error_Msg
4412 (Data.Flags,
4415 Lib_Auto_Init.Location, Project);
4416 end if;
4418 else
4419 Error_Msg
4420 (Data.Flags,
4422 Lib_Auto_Init.Location, Project);
4423 end if;
4424 end if;
4425 end;
4427 -- If attribute Library_Src_Dir is defined and not the empty string,
4428 -- check if the directory exist and is not the object directory or
4429 -- one of the source directories. This is the directory where copies
4430 -- of the interface sources will be copied. Note that this directory
4431 -- may be the library directory.
4433 if Lib_Src_Dir.Value /= Empty_String then
4434 declare
4435 Dir_Id : constant File_Name_Type :=
4436 File_Name_Type (Lib_Src_Dir.Value);
4437 Dir_Exists : Boolean;
4439 begin
4440 Locate_Directory
4441 (Project,
4442 Dir_Id,
4443 Path => Project.Library_Src_Dir,
4444 Dir_Exists => Dir_Exists,
4445 Data => Data,
4446 Must_Exist => False,
4448 Location => Lib_Src_Dir.Location,
4449 Externally_Built => Project.Externally_Built);
4451 -- If directory does not exist, report an error
4453 if not Dir_Exists then
4455 -- Get the absolute name of the library directory that does
4456 -- not exist, to report an error.
4458 Err_Vars.Error_Msg_File_1 :=
4459 File_Name_Type (Project.Library_Src_Dir.Display_Name);
4460 Error_Msg
4461 (Data.Flags,
4463 Lib_Src_Dir.Location, Project);
4465 -- Report error if it is the same as the object directory
4467 elsif Project.Library_Src_Dir = Project.Object_Directory then
4468 Error_Msg
4469 (Data.Flags,
4472 Lib_Src_Dir.Location, Project);
4473 Project.Library_Src_Dir := No_Path_Information;
4475 else
4476 declare
4477 Src_Dirs : String_List_Id;
4478 Src_Dir : String_Element;
4479 Pid : Project_List;
4481 begin
4482 -- Interface copy directory cannot be one of the source
4483 -- directory of the current project.
4485 Src_Dirs := Project.Source_Dirs;
4486 while Src_Dirs /= Nil_String loop
4487 Src_Dir := Data.Tree.String_Elements.Table (Src_Dirs);
4489 -- Report error if it is one of the source directories
4491 if Project.Library_Src_Dir.Name =
4492 Path_Name_Type (Src_Dir.Value)
4493 then
4494 Error_Msg
4495 (Data.Flags,
4498 Lib_Src_Dir.Location, Project);
4499 Project.Library_Src_Dir := No_Path_Information;
4500 exit;
4501 end if;
4503 Src_Dirs := Src_Dir.Next;
4504 end loop;
4506 if Project.Library_Src_Dir /= No_Path_Information then
4508 -- It cannot be a source directory of any other
4509 -- project either.
4511 Pid := Data.Tree.Projects;
4512 Project_Loop : loop
4513 exit Project_Loop when Pid = null;
4515 Src_Dirs := Pid.Project.Source_Dirs;
4516 Dir_Loop : while Src_Dirs /= Nil_String loop
4517 Src_Dir :=
4518 Data.Tree.String_Elements.Table (Src_Dirs);
4520 -- Report error if it is one of the source
4521 -- directories.
4523 if Project.Library_Src_Dir.Name =
4524 Path_Name_Type (Src_Dir.Value)
4525 then
4526 Error_Msg_File_1 :=
4527 File_Name_Type (Src_Dir.Value);
4528 Error_Msg_Name_1 := Pid.Project.Name;
4529 Error_Msg
4530 (Data.Flags,
4534 Lib_Src_Dir.Location, Project);
4535 Project.Library_Src_Dir :=
4536 No_Path_Information;
4537 exit Project_Loop;
4538 end if;
4540 Src_Dirs := Src_Dir.Next;
4541 end loop Dir_Loop;
4543 Pid := Pid.Next;
4544 end loop Project_Loop;
4545 end if;
4546 end;
4548 -- In high verbosity, if there is a valid Library_Src_Dir,
4549 -- display its path name.
4551 if Project.Library_Src_Dir /= No_Path_Information
4552 and then Current_Verbosity = High
4553 then
4554 Write_Attr
4556 Get_Name_String (Project.Library_Src_Dir.Name));
4557 end if;
4558 end if;
4559 end;
4560 end if;
4562 -- Check the symbol related attributes
4564 -- First, the symbol policy
4566 if not Lib_Symbol_Policy.Default then
4567 declare
4568 Value : constant String :=
4569 To_Lower
4570 (Get_Name_String (Lib_Symbol_Policy.Value));
4572 begin
4573 -- Symbol policy must hove one of a limited number of values
4576 Project.Symbol_Data.Symbol_Policy := Autonomous;
4579 Project.Symbol_Data.Symbol_Policy := Compliant;
4582 Project.Symbol_Data.Symbol_Policy := Controlled;
4585 Project.Symbol_Data.Symbol_Policy := Restricted;
4588 Project.Symbol_Data.Symbol_Policy := Direct;
4590 else
4591 Error_Msg
4592 (Data.Flags,
4594 Lib_Symbol_Policy.Location, Project);
4595 end if;
4596 end;
4597 end if;
4599 -- If attribute Library_Symbol_File is not specified, symbol policy
4600 -- cannot be Restricted.
4602 if Lib_Symbol_File.Default then
4603 if Project.Symbol_Data.Symbol_Policy = Restricted then
4604 Error_Msg
4605 (Data.Flags,
4608 Lib_Symbol_Policy.Location, Project);
4609 end if;
4611 else
4612 -- Library_Symbol_File is defined
4614 Project.Symbol_Data.Symbol_File :=
4615 Path_Name_Type (Lib_Symbol_File.Value);
4617 Get_Name_String (Lib_Symbol_File.Value);
4619 if Name_Len = 0 then
4620 Error_Msg
4621 (Data.Flags,
4623 Lib_Symbol_File.Location, Project);
4625 else
4626 OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
4628 if OK then
4629 for J in 1 .. Name_Len loop
4630 if Name_Buffer (J) = '/'
4631 or else Name_Buffer (J) = Directory_Separator
4632 then
4633 OK := False;
4634 exit;
4635 end if;
4636 end loop;
4637 end if;
4639 if not OK then
4640 Error_Msg_File_1 := File_Name_Type (Lib_Symbol_File.Value);
4641 Error_Msg
4642 (Data.Flags,
4645 Lib_Symbol_File.Location, Project);
4646 end if;
4647 end if;
4648 end if;
4650 -- If attribute Library_Reference_Symbol_File is not defined,
4651 -- symbol policy cannot be Compliant or Controlled.
4653 if Lib_Ref_Symbol_File.Default then
4654 if Project.Symbol_Data.Symbol_Policy = Compliant
4655 or else Project.Symbol_Data.Symbol_Policy = Controlled
4656 then
4657 Error_Msg
4658 (Data.Flags,
4660 Lib_Symbol_Policy.Location, Project);
4661 end if;
4663 else
4664 -- Library_Reference_Symbol_File is defined, check file exists
4666 Project.Symbol_Data.Reference :=
4667 Path_Name_Type (Lib_Ref_Symbol_File.Value);
4669 Get_Name_String (Lib_Ref_Symbol_File.Value);
4671 if Name_Len = 0 then
4672 Error_Msg
4673 (Data.Flags,
4675 Lib_Symbol_File.Location, Project);
4677 else
4678 if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then
4679 Name_Len := 0;
4680 Add_Str_To_Name_Buffer
4681 (Get_Name_String (Project.Directory.Name));
4682 Add_Str_To_Name_Buffer
4683 (Get_Name_String (Lib_Ref_Symbol_File.Value));
4684 Project.Symbol_Data.Reference := Name_Find;
4685 end if;
4687 if not Is_Regular_File
4688 (Get_Name_String (Project.Symbol_Data.Reference))
4689 then
4690 Error_Msg_File_1 :=
4691 File_Name_Type (Lib_Ref_Symbol_File.Value);
4693 -- For controlled and direct symbol policies, it is an error
4694 -- if the reference symbol file does not exist. For other
4695 -- symbol policies, this is just a warning
4697 Error_Msg_Warn :=
4698 Project.Symbol_Data.Symbol_Policy /= Controlled
4699 and then Project.Symbol_Data.Symbol_Policy /= Direct;
4701 Error_Msg
4702 (Data.Flags,
4704 Lib_Ref_Symbol_File.Location, Project);
4706 -- In addition in the non-controlled case, if symbol policy
4707 -- is Compliant, it is changed to Autonomous, because there
4708 -- is no reference to check against, and we don't want to
4709 -- fail in this case.
4711 if Project.Symbol_Data.Symbol_Policy /= Controlled then
4712 if Project.Symbol_Data.Symbol_Policy = Compliant then
4713 Project.Symbol_Data.Symbol_Policy := Autonomous;
4714 end if;
4715 end if;
4716 end if;
4718 -- If both the reference symbol file and the symbol file are
4719 -- defined, then check that they are not the same file.
4721 if Project.Symbol_Data.Symbol_File /= No_Path then
4722 Get_Name_String (Project.Symbol_Data.Symbol_File);
4724 if Name_Len > 0 then
4725 declare
4726 -- We do not need to pass a Directory to
4727 -- Normalize_Pathname, since the path_information
4728 -- already contains absolute information.
4730 Symb_Path : constant String :=
4731 Normalize_Pathname
4732 (Get_Name_String
4733 (Project.Object_Directory.Name) &
4734 Name_Buffer (1 .. Name_Len),
4736 Resolve_Links =>
4737 Opt.Follow_Links_For_Files);
4738 Ref_Path : constant String :=
4739 Normalize_Pathname
4740 (Get_Name_String
4741 (Project.Symbol_Data.Reference),
4743 Resolve_Links =>
4744 Opt.Follow_Links_For_Files);
4745 begin
4746 if Symb_Path = Ref_Path then
4747 Error_Msg
4748 (Data.Flags,
4751 Lib_Ref_Symbol_File.Location, Project);
4752 end if;
4753 end;
4754 end if;
4755 end if;
4756 end if;
4757 end if;
4758 end if;
4759 end Check_Stand_Alone_Library;
4761 ----------------------------
4762 -- Compute_Directory_Last --
4763 ----------------------------
4765 function Compute_Directory_Last (Dir : String) return Natural is
4766 begin
4767 if Dir'Length > 1
4768 and then (Dir (Dir'Last - 1) = Directory_Separator
4769 or else
4770 Dir (Dir'Last - 1) = '/')
4771 then
4772 return Dir'Last - 1;
4773 else
4774 return Dir'Last;
4775 end if;
4776 end Compute_Directory_Last;
4778 ---------------------
4779 -- Get_Directories --
4780 ---------------------
4782 procedure Get_Directories
4783 (Project : Project_Id;
4784 Data : in out Tree_Processing_Data)
4785 is
4786 package Recursive_Dirs is new GNAT.Dynamic_HTables.Simple_HTable
4787 (Header_Num => Header_Num,
4788 Element => Boolean,
4789 No_Element => False,
4790 Key => Name_Id,
4791 Hash => Hash,
4793 -- Hash table stores recursive source directories, to avoid looking
4794 -- several times, and to avoid cycles that may be introduced by symbolic
4795 -- links.
4797 Visited : Recursive_Dirs.Instance;
4799 Object_Dir : constant Variable_Value :=
4800 Util.Value_Of
4801 (Name_Object_Dir, Project.Decl.Attributes, Data.Tree);
4803 Exec_Dir : constant Variable_Value :=
4804 Util.Value_Of
4805 (Name_Exec_Dir, Project.Decl.Attributes, Data.Tree);
4807 Source_Dirs : constant Variable_Value :=
4808 Util.Value_Of
4809 (Name_Source_Dirs, Project.Decl.Attributes, Data.Tree);
4811 Excluded_Source_Dirs : constant Variable_Value :=
4812 Util.Value_Of
4813 (Name_Excluded_Source_Dirs,
4814 Project.Decl.Attributes,
4815 Data.Tree);
4817 Source_Files : constant Variable_Value :=
4818 Util.Value_Of
4819 (Name_Source_Files,
4820 Project.Decl.Attributes, Data.Tree);
4822 Last_Source_Dir : String_List_Id := Nil_String;
4823 Last_Src_Dir_Rank : Number_List_Index := No_Number_List;
4825 Languages : constant Variable_Value :=
4826 Prj.Util.Value_Of
4827 (Name_Languages, Project.Decl.Attributes, Data.Tree);
4829 procedure Find_Source_Dirs
4830 (From : File_Name_Type;
4831 Location : Source_Ptr;
4832 Rank : Natural;
4833 Removed : Boolean := False);
4834 -- Find one or several source directories, and add (or remove, if
4835 -- Removed is True) them to list of source directories of the project.
4837 ----------------------
4838 -- Find_Source_Dirs --
4839 ----------------------
4841 procedure Find_Source_Dirs
4842 (From : File_Name_Type;
4843 Location : Source_Ptr;
4844 Rank : Natural;
4845 Removed : Boolean := False)
4846 is
4847 Directory : constant String := Get_Name_String (From);
4849 procedure Add_To_Or_Remove_From_List
4850 (Path_Id : Name_Id;
4851 Display_Path_Id : Name_Id);
4852 -- When Removed = False, the directory Path_Id to the list of
4853 -- source_dirs if not already in the list. When Removed = True,
4854 -- removed directory Path_Id if in the list.
4856 procedure Recursive_Find_Dirs (Path : Name_Id);
4857 -- Find all the subdirectories (recursively) of Path and add them
4858 -- to the list of source directories of the project.
4860 --------------------------------
4861 -- Add_To_Or_Remove_From_List --
4862 --------------------------------
4864 procedure Add_To_Or_Remove_From_List
4865 (Path_Id : Name_Id;
4866 Display_Path_Id : Name_Id)
4867 is
4868 List : String_List_Id;
4869 Prev : String_List_Id;
4870 Rank_List : Number_List_Index;
4871 Prev_Rank : Number_List_Index;
4872 Element : String_Element;
4874 begin
4875 Prev := Nil_String;
4876 Prev_Rank := No_Number_List;
4877 List := Project.Source_Dirs;
4878 Rank_List := Project.Source_Dir_Ranks;
4879 while List /= Nil_String loop
4880 Element := Data.Tree.String_Elements.Table (List);
4881 exit when Element.Value = Path_Id;
4882 Prev := List;
4883 List := Element.Next;
4884 Prev_Rank := Rank_List;
4885 Rank_List := Data.Tree.Number_Lists.Table (Prev_Rank).Next;
4886 end loop;
4888 -- The directory is in the list if List is not Nil_String
4890 if not Removed and then List = Nil_String then
4891 if Current_Verbosity = High then
4893 Write_Line (Get_Name_String (Path_Id));
4894 end if;
4896 String_Element_Table.Increment_Last (Data.Tree.String_Elements);
4897 Element :=
4898 (Value => Path_Id,
4899 Index => 0,
4900 Display_Value => Display_Path_Id,
4901 Location => No_Location,
4902 Flag => False,
4903 Next => Nil_String);
4905 Number_List_Table.Increment_Last (Data.Tree.Number_Lists);
4907 if Last_Source_Dir = Nil_String then
4909 -- This is the first source directory
4911 Project.Source_Dirs :=
4912 String_Element_Table.Last (Data.Tree.String_Elements);
4913 Project.Source_Dir_Ranks :=
4914 Number_List_Table.Last (Data.Tree.Number_Lists);
4916 else
4917 -- We already have source directories, link the previous
4918 -- last to the new one.
4920 Data.Tree.String_Elements.Table (Last_Source_Dir).Next :=
4921 String_Element_Table.Last (Data.Tree.String_Elements);
4922 Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank).Next :=
4923 Number_List_Table.Last (Data.Tree.Number_Lists);
4924 end if;
4926 -- And register this source directory as the new last
4928 Last_Source_Dir :=
4929 String_Element_Table.Last (Data.Tree.String_Elements);
4930 Data.Tree.String_Elements.Table (Last_Source_Dir) := Element;
4931 Last_Src_Dir_Rank :=
4932 Number_List_Table.Last (Data.Tree.Number_Lists);
4933 Data.Tree.Number_Lists.Table (Last_Src_Dir_Rank) :=
4934 (Number => Rank, Next => No_Number_List);
4936 elsif Removed and then List /= Nil_String then
4938 -- Remove source dir, if present
4940 if Prev = Nil_String then
4941 Project.Source_Dirs :=
4942 Data.Tree.String_Elements.Table (List).Next;
4943 Project.Source_Dir_Ranks :=
4944 Data.Tree.Number_Lists.Table (Rank_List).Next;
4946 else
4947 Data.Tree.String_Elements.Table (Prev).Next :=
4948 Data.Tree.String_Elements.Table (List).Next;
4949 Data.Tree.Number_Lists.Table (Prev_Rank).Next :=
4950 Data.Tree.Number_Lists.Table (Rank_List).Next;
4951 end if;
4952 end if;
4953 end Add_To_Or_Remove_From_List;
4955 -------------------------
4956 -- Recursive_Find_Dirs --
4957 -------------------------
4959 procedure Recursive_Find_Dirs (Path : Name_Id) is
4960 Dir : Dir_Type;
4961 Name : String (1 .. 250);
4962 Last : Natural;
4964 Non_Canonical_Path : Name_Id := No_Name;
4965 Canonical_Path : Name_Id := No_Name;
4967 The_Path : constant String :=
4968 Normalize_Pathname
4969 (Get_Name_String (Path),
4970 Directory =>
4971 Get_Name_String (Project.Directory.Display_Name),
4972 Resolve_Links => Opt.Follow_Links_For_Dirs) &
4973 Directory_Separator;
4975 The_Path_Last : constant Natural :=
4976 Compute_Directory_Last (The_Path);
4978 begin
4979 Name_Len := The_Path_Last - The_Path'First + 1;
4980 Name_Buffer (1 .. Name_Len) :=
4981 The_Path (The_Path'First .. The_Path_Last);
4982 Non_Canonical_Path := Name_Find;
4983 Canonical_Path :=
4984 Name_Id (Canonical_Case_File_Name (Non_Canonical_Path));
4986 -- To avoid processing the same directory several times, check
4987 -- if the directory is already in Recursive_Dirs. If it is, then
4988 -- there is nothing to do, just return. If it is not, put it there
4989 -- and continue recursive processing.
4991 if not Removed then
4992 if Recursive_Dirs.Get (Visited, Canonical_Path) then
4993 return;
4994 else
4995 Recursive_Dirs.Set (Visited, Canonical_Path, True);
4996 end if;
4997 end if;
4999 Add_To_Or_Remove_From_List
5000 (Path_Id => Canonical_Path,
5001 Display_Path_Id => Non_Canonical_Path);
5003 -- Now look for subdirectories. Do that even when this directory
5004 -- is already in the list, because some of its subdirectories may
5005 -- not be in the list yet.
5007 Open (Dir, The_Path (The_Path'First .. The_Path_Last));
5009 loop
5010 Read (Dir, Name, Last);
5011 exit when Last = 0;
5015 then
5016 -- Avoid . and .. directories
5018 if Current_Verbosity = High then
5020 Write_Line (Name (1 .. Last));
5021 end if;
5023 declare
5024 Path_Name : constant String :=
5025 Normalize_Pathname
5026 (Name => Name (1 .. Last),
5027 Directory =>
5028 The_Path
5029 (The_Path'First .. The_Path_Last),
5030 Resolve_Links =>
5031 Opt.Follow_Links_For_Dirs,
5032 Case_Sensitive => True);
5034 begin
5035 if Is_Directory (Path_Name) then
5037 -- We have found a new subdirectory, call self
5039 Name_Len := Path_Name'Length;
5040 Name_Buffer (1 .. Name_Len) := Path_Name;
5041 Recursive_Find_Dirs (Name_Find);
5042 end if;
5043 end;
5044 end if;
5045 end loop;
5047 Close (Dir);
5049 exception
5050 when Directory_Error =>
5051 null;
5052 end Recursive_Find_Dirs;
5054 -- Start of processing for Find_Source_Dirs
5056 begin
5057 if Current_Verbosity = High and then not Removed then
5059 Write_Str (Directory);
5061 Write_Str (Rank'Img);
5063 end if;
5065 -- First, check if we are looking for a directory tree, indicated
5068 if Directory'Length >= 3
5070 and then (Directory (Directory'Last - 2) = '/'
5071 or else
5072 Directory (Directory'Last - 2) = Directory_Separator)
5073 then
5074 Name_Len := Directory'Length - 3;
5076 if Name_Len = 0 then
5080 Name_Len := 1;
5081 Name_Buffer (1) := Directory (Directory'First);
5083 else
5084 Name_Buffer (1 .. Name_Len) :=
5085 Directory (Directory'First .. Directory'Last - 3);
5086 end if;
5088 if Current_Verbosity = High then
5090 Write_Str (Name_Buffer (1 .. Name_Len));
5092 end if;
5094 declare
5095 Base_Dir : constant File_Name_Type := Name_Find;
5096 Root_Dir : constant String :=
5097 Normalize_Pathname
5098 (Name => Get_Name_String (Base_Dir),
5099 Directory =>
5100 Get_Name_String
5101 (Project.Directory.Display_Name),
5102 Resolve_Links =>
5103 Opt.Follow_Links_For_Dirs,
5104 Case_Sensitive => True);
5106 begin
5107 if Root_Dir'Length = 0 then
5108 Err_Vars.Error_Msg_File_1 := Base_Dir;
5110 if Location = No_Location then
5111 Error_Msg
5112 (Data.Flags,
5114 Project.Location, Project);
5115 else
5116 Error_Msg
5117 (Data.Flags,
5119 Location, Project);
5120 end if;
5122 else
5123 -- We have an existing directory, we register it and all of
5124 -- its subdirectories.
5126 if Current_Verbosity = High then
5128 end if;
5130 Name_Len := Root_Dir'Length;
5131 Name_Buffer (1 .. Name_Len) := Root_Dir;
5132 Recursive_Find_Dirs (Name_Find);
5134 if Current_Verbosity = High then
5136 end if;
5137 end if;
5138 end;
5140 -- We have a single directory
5142 else
5143 declare
5144 Path_Name : Path_Information;
5145 Dir_Exists : Boolean;
5147 begin
5148 Locate_Directory
5149 (Project => Project,
5150 Name => From,
5151 Path => Path_Name,
5152 Dir_Exists => Dir_Exists,
5153 Data => Data,
5154 Must_Exist => False);
5156 if not Dir_Exists then
5157 Err_Vars.Error_Msg_File_1 := From;
5159 if Location = No_Location then
5160 Error_Msg
5161 (Data.Flags,
5163 Project.Location, Project);
5164 else
5165 Error_Msg
5166 (Data.Flags,
5168 Location, Project);
5169 end if;
5171 else
5172 declare
5173 Path : constant String :=
5174 Normalize_Pathname
5175 (Name =>
5176 Get_Name_String (Path_Name.Name),
5177 Directory =>
5178 Get_Name_String (Project.Directory.Name),
5179 Resolve_Links => Opt.Follow_Links_For_Dirs,
5180 Case_Sensitive => True) &
5181 Directory_Separator;
5183 Last_Path : constant Natural :=
5184 Compute_Directory_Last (Path);
5185 Path_Id : Name_Id;
5186 Display_Path : constant String :=
5187 Get_Name_String
5188 (Path_Name.Display_Name);
5189 Last_Display_Path : constant Natural :=
5190 Compute_Directory_Last
5191 (Display_Path);
5192 Display_Path_Id : Name_Id;
5194 begin
5195 Name_Len := 0;
5196 Add_Str_To_Name_Buffer (Path (Path'First .. Last_Path));
5197 Path_Id := Name_Find;
5199 Name_Len := 0;
5200 Add_Str_To_Name_Buffer
5201 (Display_Path
5202 (Display_Path'First .. Last_Display_Path));
5203 Display_Path_Id := Name_Find;
5205 Add_To_Or_Remove_From_List
5206 (Path_Id => Path_Id,
5207 Display_Path_Id => Display_Path_Id);
5208 end;
5209 end if;
5210 end;
5211 end if;
5213 Recursive_Dirs.Reset (Visited);
5214 end Find_Source_Dirs;
5216 -- Start of processing for Get_Directories
5218 Dir_Exists : Boolean;
5220 begin
5221 if Current_Verbosity = High then
5223 end if;
5225 -- Set the object directory to its default which may be nil, if there
5226 -- is no sources in the project.
5228 if (((not Source_Files.Default)
5229 and then Source_Files.Values = Nil_String)
5230 or else
5231 ((not Source_Dirs.Default) and then Source_Dirs.Values = Nil_String)
5232 or else
5233 ((not Languages.Default) and then Languages.Values = Nil_String))
5234 and then Project.Extends = No_Project
5235 then
5236 Project.Object_Directory := No_Path_Information;
5237 else
5238 Project.Object_Directory := Project.Directory;
5239 end if;
5241 -- Check the object directory
5243 if Object_Dir.Value /= Empty_String then
5244 Get_Name_String (Object_Dir.Value);
5246 if Name_Len = 0 then
5247 Error_Msg
5248 (Data.Flags,
5250 Object_Dir.Location, Project);
5252 else
5253 -- We check that the specified object directory does exist.
5254 -- However, even when it doesn't exist, we set it to a default
5255 -- value. This is for the benefit of tools that recover from
5256 -- errors; for example, these tools could create the non existent
5257 -- directory. We always return an absolute directory name though.
5259 Locate_Directory
5260 (Project,
5261 File_Name_Type (Object_Dir.Value),
5262 Path => Project.Object_Directory,
5264 Dir_Exists => Dir_Exists,
5265 Data => Data,
5266 Location => Object_Dir.Location,
5267 Must_Exist => False,
5268 Externally_Built => Project.Externally_Built);
5270 if not Dir_Exists
5271 and then not Project.Externally_Built
5272 then
5273 -- The object directory does not exist, report an error if
5274 -- the project is not externally built.
5276 Err_Vars.Error_Msg_File_1 :=
5277 File_Name_Type (Object_Dir.Value);
5279 case Data.Flags.Require_Obj_Dirs is
5280 when Error =>
5281 Error_Msg
5282 (Data.Flags,
5284 Project.Location, Project);
5285 when Warning =>
5286 Error_Msg
5287 (Data.Flags,
5289 Project.Location, Project);
5290 when Silent =>
5291 null;
5292 end case;
5293 end if;
5294 end if;
5296 elsif Project.Object_Directory /= No_Path_Information
5297 and then Subdirs /= null
5298 then
5299 Name_Len := 1;
5300 Name_Buffer (1) := '.';
5301 Locate_Directory
5302 (Project,
5303 Name_Find,
5304 Path => Project.Object_Directory,
5306 Dir_Exists => Dir_Exists,
5307 Data => Data,
5308 Location => Object_Dir.Location,
5309 Externally_Built => Project.Externally_Built);
5310 end if;
5312 if Current_Verbosity = High then
5313 if Project.Object_Directory = No_Path_Information then
5315 else
5316 Write_Attr
5318 Get_Name_String (Project.Object_Directory.Display_Name));
5319 end if;
5320 end if;
5322 -- Check the exec directory
5324 -- We set the object directory to its default
5326 Project.Exec_Directory := Project.Object_Directory;
5328 if Exec_Dir.Value /= Empty_String then
5329 Get_Name_String (Exec_Dir.Value);
5331 if Name_Len = 0 then
5332 Error_Msg
5333 (Data.Flags,
5335 Exec_Dir.Location, Project);
5337 else
5338 -- We check that the specified exec directory does exist
5340 Locate_Directory
5341 (Project,
5342 File_Name_Type (Exec_Dir.Value),
5343 Path => Project.Exec_Directory,
5344 Dir_Exists => Dir_Exists,
5345 Data => Data,
5347 Location => Exec_Dir.Location,
5348 Externally_Built => Project.Externally_Built);
5350 if not Dir_Exists then
5351 Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value);
5352 Error_Msg
5353 (Data.Flags,
5355 Project.Location, Project);
5356 end if;
5357 end if;
5358 end if;
5360 if Current_Verbosity = High then
5361 if Project.Exec_Directory = No_Path_Information then
5363 else
5365 Write_Str (Get_Name_String (Project.Exec_Directory.Display_Name));
5367 end if;
5368 end if;
5370 -- Look for the source directories
5372 if Current_Verbosity = High then
5374 end if;
5378 if (not Source_Files.Default)
5379 and then Source_Files.Values = Nil_String
5380 then
5381 Project.Source_Dirs := Nil_String;
5383 if Project.Qualifier = Standard then
5384 Error_Msg
5385 (Data.Flags,
5387 Source_Files.Location, Project);
5388 end if;
5390 elsif Source_Dirs.Default then
5392 -- No Source_Dirs specified: the single source directory is the one
5393 -- containing the project file.
5395 String_Element_Table.Append (Data.Tree.String_Elements,
5396 (Value => Name_Id (Project.Directory.Name),
5397 Display_Value => Name_Id (Project.Directory.Display_Name),
5398 Location => No_Location,
5399 Flag => False,
5400 Next => Nil_String,
5401 Index => 0));
5403 Project.Source_Dirs :=
5404 String_Element_Table.Last (Data.Tree.String_Elements);
5406 Number_List_Table.Append
5407 (Data.Tree.Number_Lists,
5408 (Number => 1, Next => No_Number_List));
5410 Project.Source_Dir_Ranks :=
5411 Number_List_Table.Last (Data.Tree.Number_Lists);
5413 if Current_Verbosity = High then
5414 Write_Attr
5416 Get_Name_String (Project.Directory.Display_Name));
5417 end if;
5419 elsif Source_Dirs.Values = Nil_String then
5420 if Project.Qualifier = Standard then
5421 Error_Msg
5422 (Data.Flags,
5424 Source_Dirs.Location, Project);
5425 end if;
5427 Project.Source_Dirs := Nil_String;
5429 else
5430 declare
5431 Source_Dir : String_List_Id;
5432 Element : String_Element;
5433 Rank : Natural;
5434 begin
5435 -- Process the source directories for each element of the list
5437 Source_Dir := Source_Dirs.Values;
5438 Rank := 0;
5439 while Source_Dir /= Nil_String loop
5440 Element := Data.Tree.String_Elements.Table (Source_Dir);
5441 Rank := Rank + 1;
5442 Find_Source_Dirs
5443 (File_Name_Type (Element.Value), Element.Location, Rank);
5444 Source_Dir := Element.Next;
5445 end loop;
5446 end;
5447 end if;
5449 if not Excluded_Source_Dirs.Default
5450 and then Excluded_Source_Dirs.Values /= Nil_String
5451 then
5452 declare
5453 Source_Dir : String_List_Id;
5454 Element : String_Element;
5456 begin
5457 -- Process the source directories for each element of the list
5459 Source_Dir := Excluded_Source_Dirs.Values;
5460 while Source_Dir /= Nil_String loop
5461 Element := Data.Tree.String_Elements.Table (Source_Dir);
5462 Find_Source_Dirs
5463 (File_Name_Type (Element.Value),
5464 Element.Location,
5465 0,
5466 Removed => True);
5467 Source_Dir := Element.Next;
5468 end loop;
5469 end;
5470 end if;
5472 if Current_Verbosity = High then
5474 end if;
5476 declare
5477 Current : String_List_Id := Project.Source_Dirs;
5478 Element : String_Element;
5480 begin
5481 while Current /= Nil_String loop
5482 Element := Data.Tree.String_Elements.Table (Current);
5483 if Element.Value /= No_Name then
5484 Element.Value :=
5485 Name_Id (Canonical_Case_File_Name (Name_Id (Element.Value)));
5486 Data.Tree.String_Elements.Table (Current) := Element;
5487 end if;
5489 Current := Element.Next;
5490 end loop;
5491 end;
5492 end Get_Directories;
5494 ---------------
5495 -- Get_Mains --
5496 ---------------
5498 procedure Get_Mains
5499 (Project : Project_Id;
5500 Data : in out Tree_Processing_Data)
5501 is
5502 Mains : constant Variable_Value :=
5503 Prj.Util.Value_Of
5504 (Name_Main, Project.Decl.Attributes, Data.Tree);
5505 List : String_List_Id;
5506 Elem : String_Element;
5508 begin
5509 Project.Mains := Mains.Values;
5511 -- If no Mains were specified, and if we are an extending project,
5512 -- inherit the Mains from the project we are extending.
5514 if Mains.Default then
5515 if not Project.Library and then Project.Extends /= No_Project then
5516 Project.Mains := Project.Extends.Mains;
5517 end if;
5519 -- In a library project file, Main cannot be specified
5521 elsif Project.Library then
5522 Error_Msg
5523 (Data.Flags,
5525 Mains.Location, Project);
5527 else
5528 List := Mains.Values;
5529 while List /= Nil_String loop
5530 Elem := Data.Tree.String_Elements.Table (List);
5532 if Length_Of_Name (Elem.Value) = 0 then
5533 Error_Msg
5534 (Data.Flags,
5536 Elem.Location, Project);
5537 exit;
5538 end if;
5540 List := Elem.Next;
5541 end loop;
5542 end if;
5543 end Get_Mains;
5545 ---------------------------
5546 -- Get_Sources_From_File --
5547 ---------------------------
5549 procedure Get_Sources_From_File
5550 (Path : String;
5551 Location : Source_Ptr;
5552 Project : in out Project_Processing_Data;
5553 Data : in out Tree_Processing_Data)
5554 is
5555 File : Prj.Util.Text_File;
5556 Line : String (1 .. 250);
5557 Last : Natural;
5558 Source_Name : File_Name_Type;
5559 Name_Loc : Name_Location;
5561 begin
5562 if Current_Verbosity = High then
5564 Write_Str (Path);
5566 end if;
5568 -- Open the file
5570 Prj.Util.Open (File, Path);
5572 if not Prj.Util.Is_Valid (File) then
5573 Error_Msg
5576 else
5577 -- Read the lines one by one
5579 while not Prj.Util.End_Of_File (File) loop
5580 Prj.Util.Get_Line (File, Line, Last);
5582 -- A non empty, non comment line should contain a file name
5584 if Last /= 0
5586 then
5592 -- Check that there is no directory information
5597 Error_Msg
5609 Name_Loc :=
5616 Source_Names_Htable.Set
5626 -----------------------
5627 -- Compute_Unit_Name --
5628 -----------------------
5630 procedure Compute_Unit_Name
5637 is
5647 begin
5654 then
5670 -- Choose the longest suffix that matches. If there are several matches,
5671 -- give priority to specs, then bodies, then separates.
5675 then
5682 then
5689 then
5702 -- Check that the casing matches
5710 then
5723 then
5737 -- If Dot_Replacement is not a single dot, then there should not
5738 -- be any dot in the name.
5740 declare
5744 begin
5756 Replace_Into_Name_Buffer
5759 else
5762 Fixed.Translate
5768 -- In the standard GNAT naming scheme, check for special cases: children
5769 -- or separates of A, G, I or S, and run time sources.
5773 then
5774 declare
5779 begin
5784 then
5785 -- Children or separates of packages A, G, I or S. These names
5786 -- are x__ ... or x~... (where x is a, g, i, or s). Both
5787 -- versions (x__... and x~...) are allowed in all platforms,
5788 -- because it is not possible to know the platform before
5789 -- processing of the project files.
5802 -- If it is potentially a run time source
5810 -- Name_Buffer contains the name of the the unit in lower-cases. Check
5811 -- that this is a valid unit name
5815 -- If there is a naming exception for the same unit, the file is not
5816 -- a source for the unit.
5819 Unit_Except :=
5824 and then
5826 else
5828 and then
5839 else
5853 then
5864 --------------------------
5865 -- Check_Illegal_Suffix --
5866 --------------------------
5868 procedure Check_Illegal_Suffix
5875 is
5878 begin
5881 -- Always valid
5887 Error_Msg
5894 -- Case of dot replacement is a single dot, and first character of
5895 -- suffix is also a dot.
5900 then
5903 -- If there are multiple dots in the name
5907 -- It is illegal to have a letter following the initial dot
5911 Error_Msg
5923 ----------------------
5924 -- Locate_Directory --
5925 ----------------------
5927 procedure Locate_Directory
5937 is
5947 begin
5950 -- Add Subdirs.all if it is a directory that may be created and
5951 -- Subdirs is not null;
5961 -- Convert '/' to directory separator (for Windows)
5985 else
5987 Add_Str_To_Name_Buffer
5993 declare
5997 begin
5998 if (Setup_Projects or else Subdirs /= null)
5999 and then Create'Length > 0
6000 then
6001 if not Is_Directory (Full_Path_Name.all) then
6003 -- If project is externally built, do not create a subdir,
6004 -- use the specified directory, without the subdir.
6006 if Externally_Built then
6007 if Is_Absolute_Path (Get_Name_String (Name)) then
6008 Get_Name_String (Name);
6010 else
6011 Name_Len := 0;
6012 Add_Str_To_Name_Buffer
6013 (The_Parent (The_Parent'First .. The_Parent_Last));
6014 Add_Str_To_Name_Buffer (Get_Name_String (Name));
6015 end if;
6019 else
6020 begin
6031 exception
6033 Error_Msg
6046 declare
6048 Normalize_Pathname
6050 Directory =>
6056 Normalize_Pathname
6058 Directory =>
6059 The_Parent
6061 Resolve_Links =>
6065 begin
6069 -- Directories should always end with a directory separator
6092 ---------------------------
6093 -- Find_Excluded_Sources --
6094 ---------------------------
6096 procedure Find_Excluded_Sources
6099 is
6101 Util.Value_Of
6119 begin
6120 -- If Excluded_Source_Files is not declared, check Locally_Removed_Files
6124 Excluded_Sources :=
6125 Util.Value_Of
6130 -- If there are excluded sources, put them in the table
6135 Error_Msg
6140 else
6141 Error_Msg
6154 -- If the element has no location, then use the location of
6155 -- Excluded_Sources to report possible errors.
6159 else
6163 Excluded_Sources_Htable.Set
6171 declare
6173 Path_Name_Of
6174 (File_Name_Type
6178 begin
6182 Error_Msg
6187 else
6188 -- Open the file
6193 Error_Msg
6196 else
6197 -- Read the lines one by one
6202 -- Non empty, non comment line should contain a file name
6206 then
6212 -- Check that there is no directory information
6217 then
6219 Error_Msg
6228 Excluded_Sources_Htable.Set
6240 ------------------
6241 -- Find_Sources --
6242 ------------------
6244 procedure Find_Sources
6247 is
6249 Util.Value_Of
6255 Util.Value_Of
6263 begin
6265 pragma Assert
6271 -- If the user has specified a Source_Files attribute
6275 Error_Msg
6282 -- Sources is a list of file names
6284 declare
6290 begin
6294 -- This project contains no source. For projects that don't
6295 -- extend other projects, this also means that there is no
6296 -- need for an object directory, if not specified.
6301 then
6311 -- If the element has no location, then use the location of
6312 -- Sources to report possible errors.
6316 else
6320 -- Check that there is no directory information
6325 then
6327 Error_Msg
6336 -- Check whether the file is already there: the same file name
6337 -- may be in the list. If the source is missing, the error will
6338 -- be on the first mention of the source file name.
6344 Name_Loc :=
6349 Source_Names_Htable.Set
6359 -- If we have no Source_Files attribute, check the Source_List_File
6360 -- attribute.
6364 -- Source_List_File is the name of the file that contains the source
6365 -- file names.
6367 declare
6369 Path_Name_Of
6373 begin
6379 Error_Msg
6384 else
6385 Get_Sources_From_File
6391 else
6392 -- Neither Source_Files nor Source_List_File has been specified. Find
6393 -- all the files that satisfy the naming scheme in all the source
6394 -- directories.
6399 Search_Directories
6404 -- Check if all exceptions have been found
6406 declare
6410 begin
6412 loop
6418 then
6421 -- For multi-unit source files, source_id gets duplicated
6422 -- once for every unit. Only the first source_id got its
6423 -- full path set. So if it isn't set for that first one,
6424 -- the file wasn't found. Otherwise we need to update for
6425 -- units after the first one.
6429 then
6432 Error_Msg
6437 else
6462 -- It is an error if a source file name in a source list or in a source
6463 -- list file is not found.
6466 declare
6470 begin
6478 Error_Msg
6484 else
6485 Error_Msg
6498 ----------------
6499 -- Initialize --
6500 ----------------
6502 procedure Initialize
6506 is
6507 begin
6513 ----------
6514 -- Free --
6515 ----------
6518 begin
6522 ----------------
6523 -- Initialize --
6524 ----------------
6526 procedure Initialize
6529 is
6530 begin
6534 ----------
6535 -- Free --
6536 ----------
6539 begin
6545 -------------------------------
6546 -- Check_File_Naming_Schemes --
6547 -------------------------------
6549 procedure Check_File_Naming_Schemes
6559 is
6565 -- True if we found at least one language for which the file is a header
6566 -- In such a case, we search for all possible languages where this is
6567 -- also a header (C and C++ for instance), since the file might be used
6568 -- for several such languages.
6571 -- Does the naming scheme test for file-based languages. For those,
6572 -- there is no Unit. Just check if the file name has the implementation
6573 -- or, if it is specified, the template suffix of the language.
6574 --
6575 -- Returns True if the file belongs to the current language and we
6576 -- should stop searching for matching languages. Not that a given header
6577 -- file could belong to several languages (C and C++ for instance). Thus
6578 -- if we found a header we'll check whether it matches other languages.
6580 ---------------------------
6581 -- Check_File_Based_Lang --
6582 ---------------------------
6585 begin
6586 if not Header_File
6588 then
6606 (Language => Language,
6607 Next => Alternate_Languages);
6609 else
6610 Header_File := True;
6611 Kind := Spec;
6612 Unit := No_Name;
6613 Language := Tmp_Lang;
6614 end if;
6615 end if;
6616 end Check_File_Based_Lang;
6618 -- Start of processing for Check_File_Naming_Schemes
6620 begin
6621 Language := No_Language_Index;
6622 Alternate_Languages := null;
6623 Display_Language_Name := No_Name;
6624 Unit := No_Name;
6625 Lang_Kind := File_Based;
6626 Kind := Spec;
6628 Tmp_Lang := Project.Project.Languages;
6629 while Tmp_Lang /= No_Language_Index loop
6630 if Current_Verbosity = High then
6631 Write_Line
6632 (" Testing language "
6633 & Get_Name_String (Tmp_Lang.Name)
6634 & " Header_File=" & Header_File'Img);
6635 end if;
6637 Display_Language_Name := Tmp_Lang.Display_Name;
6638 Config := Tmp_Lang.Config;
6639 Lang_Kind := Config.Kind;
6641 case Config.Kind is
6642 when File_Based =>
6643 Check_File_Based_Lang;
6644 exit when Kind = Impl;
6646 when Unit_Based =>
6648 -- We know it belongs to a least a file_based language, no
6649 -- need to check unit-based ones.
6651 if not Header_File then
6652 Compute_Unit_Name
6653 (File_Name => File_Name,
6654 Naming => Config.Naming_Data,
6655 Kind => Kind,
6656 Unit => Unit,
6657 Project => Project,
6658 In_Tree => In_Tree);
6660 if Unit /= No_Name then
6661 Language := Tmp_Lang;
6662 exit;
6663 end if;
6664 end if;
6665 end case;
6667 Tmp_Lang := Tmp_Lang.Next;
6668 end loop;
6670 if Language = No_Language_Index
6671 and then Current_Verbosity = High
6672 then
6673 Write_Line (" not a source of any language");
6674 end if;
6675 end Check_File_Naming_Schemes;
6677 -------------------
6678 -- Override_Kind --
6679 -------------------
6681 procedure Override_Kind (Source : Source_Id; Kind : Source_Kind) is
6682 begin
6683 -- If the file was previously already associated with a unit, change it
6685 if Source.Unit /= null
6686 and then Source.Kind in Spec_Or_Body
6687 and then Source.Unit.File_Names (Source.Kind) /= null
6688 then
6689 -- If we had another file referencing the same unit (for instance it
6690 -- was in an extended project), that source file is in fact invisible
6691 -- from now on, and in particular doesn't belong to the same unit.
6693 if Source.Unit.File_Names (Source.Kind) /= Source then
6694 Source.Unit.File_Names (Source.Kind).Unit := No_Unit_Index;
6695 end if;
6697 Source.Unit.File_Names (Source.Kind) := null;
6698 end if;
6700 Source.Kind := Kind;
6702 if Current_Verbosity = High
6703 and then Source.File /= No_File
6704 then
6705 Write_Line ("Override kind for "
6706 & Get_Name_String (Source.File)
6707 & " kind=" & Source.Kind'Img);
6708 end if;
6710 if Source.Kind in Spec_Or_Body and then Source.Unit /= null then
6711 Source.Unit.File_Names (Source.Kind) := Source;
6712 end if;
6713 end Override_Kind;
6715 ----------------
6716 -- Check_File --
6717 ----------------
6719 procedure Check_File
6720 (Project : in out Project_Processing_Data;
6721 Data : in out Tree_Processing_Data;
6722 Source_Dir_Rank : Natural;
6723 Path : Path_Name_Type;
6724 File_Name : File_Name_Type;
6725 Display_File_Name : File_Name_Type;
6726 Locally_Removed : Boolean;
6727 For_All_Sources : Boolean)
6728 is
6729 Canonical_Path : constant Path_Name_Type :=
6730 Path_Name_Type
6731 (Canonical_Case_File_Name (Name_Id (Path)));
6733 Name_Loc : Name_Location :=
6734 Source_Names_Htable.Get
6735 (Project.Source_Names, File_Name);
6736 Check_Name : Boolean := False;
6737 Alternate_Languages : Language_List;
6738 Language : Language_Ptr;
6739 Source : Source_Id;
6740 Src_Ind : Source_File_Index;
6741 Unit : Name_Id;
6742 Display_Language_Name : Name_Id;
6743 Lang_Kind : Language_Kind;
6744 Kind : Source_Kind := Spec;
6746 begin
6747 if Current_Verbosity = High then
6748 Write_Line ("Checking file:");
6749 Write_Str (" Path = ");
6750 Write_Line (Get_Name_String (Path));
6751 Write_Str (" Rank =");
6752 Write_Line (Source_Dir_Rank'Img);
6753 end if;
6755 if Name_Loc = No_Name_Location then
6756 Check_Name := For_All_Sources;
6758 else
6759 if Name_Loc.Found then
6761 -- Check if it is OK to have the same file name in several
6762 -- source directories.
6764 if Source_Dir_Rank = Name_Loc.Source.Source_Dir_Rank then
6765 Error_Msg_File_1 := File_Name;
6766 Error_Msg
6767 (Data.Flags,
6768 "{ is found in several source directories",
6769 Name_Loc.Location, Project.Project);
6770 end if;
6772 else
6773 Name_Loc.Found := True;
6775 Source_Names_Htable.Set
6776 (Project.Source_Names, File_Name, Name_Loc);
6778 if Name_Loc.Source = No_Source then
6779 Check_Name := True;
6781 else
6782 Name_Loc.Source.Path := (Canonical_Path, Path);
6784 Source_Paths_Htable.Set
6785 (Data.Tree.Source_Paths_HT,
6786 Canonical_Path,
6787 Name_Loc.Source);
6789 -- Check if this is a subunit
6791 if Name_Loc.Source.Unit /= No_Unit_Index
6792 and then Name_Loc.Source.Kind = Impl
6793 then
6794 Src_Ind := Sinput.P.Load_Project_File
6795 (Get_Name_String (Canonical_Path));
6797 if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
6798 Override_Kind (Name_Loc.Source, Sep);
6799 end if;
6800 end if;
6802 Files_Htable.Set
6803 (Data.File_To_Source, File_Name, Name_Loc.Source);
6804 end if;
6805 end if;
6806 end if;
6808 if Check_Name then
6809 Check_File_Naming_Schemes
6810 (In_Tree => Data.Tree,
6811 Project => Project,
6812 File_Name => File_Name,
6813 Alternate_Languages => Alternate_Languages,
6814 Language => Language,
6815 Display_Language_Name => Display_Language_Name,
6816 Unit => Unit,
6817 Lang_Kind => Lang_Kind,
6818 Kind => Kind);
6820 if Language = No_Language_Index then
6822 -- A file name in a list must be a source of a language
6824 if Data.Flags.Error_On_Unknown_Language
6825 and then Name_Loc.Found
6826 then
6827 Error_Msg_File_1 := File_Name;
6828 Error_Msg
6829 (Data.Flags,
6830 "language unknown for {",
6831 Name_Loc.Location, Project.Project);
6832 end if;
6834 else
6835 Add_Source
6836 (Id => Source,
6837 Project => Project.Project,
6838 Source_Dir_Rank => Source_Dir_Rank,
6839 Lang_Id => Language,
6840 Kind => Kind,
6841 Data => Data,
6842 Alternate_Languages => Alternate_Languages,
6843 File_Name => File_Name,
6844 Display_File => Display_File_Name,
6845 Unit => Unit,
6846 Locally_Removed => Locally_Removed,
6847 Path => (Canonical_Path, Path));
6849 -- If it is a source specified in a list, update the entry in
6850 -- the Source_Names table.
6852 if Name_Loc.Found and then Name_Loc.Source = No_Source then
6853 Name_Loc.Source := Source;
6854 Source_Names_Htable.Set
6855 (Project.Source_Names, File_Name, Name_Loc);
6856 end if;
6857 end if;
6858 end if;
6859 end Check_File;
6861 ------------------------
6862 -- Search_Directories --
6863 ------------------------
6865 procedure Search_Directories
6866 (Project : in out Project_Processing_Data;
6867 Data : in out Tree_Processing_Data;
6868 For_All_Sources : Boolean)
6869 is
6870 Source_Dir : String_List_Id;
6871 Element : String_Element;
6872 Src_Dir_Rank : Number_List_Index;
6873 Num_Nod : Number_Node;
6874 Dir : Dir_Type;
6875 Name : String (1 .. 1_000);
6876 Last : Natural;
6877 File_Name : File_Name_Type;
6878 Display_File_Name : File_Name_Type;
6880 begin
6881 if Current_Verbosity = High then
6882 Write_Line ("Looking for sources:");
6883 end if;
6885 -- Loop through subdirectories
6887 Source_Dir := Project.Project.Source_Dirs;
6888 Src_Dir_Rank := Project.Project.Source_Dir_Ranks;
6889 while Source_Dir /= Nil_String loop
6890 begin
6891 Num_Nod := Data.Tree.Number_Lists.Table (Src_Dir_Rank);
6892 Element := Data.Tree.String_Elements.Table (Source_Dir);
6894 if Element.Value /= No_Name then
6895 Get_Name_String (Element.Display_Value);
6897 if Current_Verbosity = High then
6898 Write_Str ("Directory: ");
6899 Write_Str (Name_Buffer (1 .. Name_Len));
6900 Write_Line (Num_Nod.Number'Img);
6901 end if;
6903 declare
6904 Source_Directory : constant String :=
6905 Name_Buffer (1 .. Name_Len) &
6906 Directory_Separator;
6908 Dir_Last : constant Natural :=
6909 Compute_Directory_Last
6910 (Source_Directory);
6912 begin
6913 if Current_Verbosity = High then
6914 Write_Attr ("Source_Dir", Source_Directory);
6915 end if;
6917 -- We look to every entry in the source directory
6919 Open (Dir, Source_Directory);
6921 loop
6922 Read (Dir, Name, Last);
6924 exit when Last = 0;
6926 -- In fast project loading mode (without -eL), the user
6927 -- guarantees that no directory has a name which is a
6928 -- valid source name, so we can avoid doing a system call
6929 -- here. This provides a very significant speed up on
6930 -- slow file systems (remote files for instance).
6932 if not Opt.Follow_Links_For_Files
6933 or else Is_Regular_File
6934 (Source_Directory & Name (1 .. Last))
6935 then
6936 if Current_Verbosity = High then
6937 Write_Str (" Checking ");
6938 Write_Line (Name (1 .. Last));
6939 end if;
6941 Name_Len := Last;
6942 Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
6943 Display_File_Name := Name_Find;
6945 if Osint.File_Names_Case_Sensitive then
6946 File_Name := Display_File_Name;
6947 else
6948 Canonical_Case_File_Name
6949 (Name_Buffer (1 .. Name_Len));
6950 File_Name := Name_Find;
6951 end if;
6953 declare
6954 Path_Name : constant String :=
6955 Normalize_Pathname
6956 (Name (1 .. Last),
6957 Directory =>
6958 Source_Directory
6959 (Source_Directory'First ..
6960 Dir_Last),
6961 Resolve_Links =>
6962 Opt.Follow_Links_For_Files,
6963 Case_Sensitive => True);
6964 -- Case_Sensitive set True (no folding)
6966 Path : Path_Name_Type;
6967 FF : File_Found := Excluded_Sources_Htable.Get
6968 (Project.Excluded, File_Name);
6969 To_Remove : Boolean := False;
6971 begin
6972 Name_Len := Path_Name'Length;
6973 Name_Buffer (1 .. Name_Len) := Path_Name;
6974 Path := Name_Find;
6976 if FF /= No_File_Found then
6977 if not FF.Found then
6978 FF.Found := True;
6979 Excluded_Sources_Htable.Set
6980 (Project.Excluded, File_Name, FF);
6982 if Current_Verbosity = High then
6983 Write_Str (" excluded source """);
6984 Write_Str (Get_Name_String (File_Name));
6985 Write_Line ("""");
6986 end if;
6988 -- Will mark the file as removed, but we
6989 -- still need to add it to the list: if we
6990 -- don't, the file will not appear in the
6991 -- mapping file and will cause the compiler
6992 -- to fail.
6994 To_Remove := True;
6995 end if;
6996 end if;
6998 Check_File
6999 (Project => Project,
7000 Source_Dir_Rank => Num_Nod.Number,
7001 Data => Data,
7002 Path => Path,
7003 File_Name => File_Name,
7004 Locally_Removed => To_Remove,
7005 Display_File_Name => Display_File_Name,
7006 For_All_Sources => For_All_Sources);
7007 end;
7008 end if;
7009 end loop;
7011 Close (Dir);
7012 end;
7013 end if;
7015 exception
7016 when Directory_Error =>
7017 null;
7018 end;
7020 Source_Dir := Element.Next;
7021 Src_Dir_Rank := Num_Nod.Next;
7022 end loop;
7024 if Current_Verbosity = High then
7025 Write_Line ("end Looking for sources.");
7026 end if;
7027 end Search_Directories;
7029 ----------------------------
7030 -- Load_Naming_Exceptions --
7031 ----------------------------
7033 procedure Load_Naming_Exceptions
7034 (Project : in out Project_Processing_Data;
7035 Data : in out Tree_Processing_Data)
7036 is
7037 Source : Source_Id;
7038 Iter : Source_Iterator;
7040 begin
7041 Iter := For_Each_Source (Data.Tree, Project.Project);
7042 loop
7043 Source := Prj.Element (Iter);
7044 exit when Source = No_Source;
7046 -- An excluded file cannot also be an exception file name
7048 if Excluded_Sources_Htable.Get (Project.Excluded, Source.File) /=
7049 No_File_Found
7050 then
7051 Error_Msg_File_1 := Source.File;
7052 Error_Msg
7053 (Data.Flags,
7054 "{ cannot be both excluded and an exception file name",
7055 No_Location, Project.Project);
7056 end if;
7058 if Current_Verbosity = High then
7059 Write_Str ("Naming exception: Putting source file ");
7060 Write_Str (Get_Name_String (Source.File));
7061 Write_Line (" in Source_Names");
7062 end if;
7064 Source_Names_Htable.Set
7065 (Project.Source_Names,
7066 K => Source.File,
7067 E => Name_Location'
7073 -- If this is an Ada exception, record in table Unit_Exceptions
7076 declare
7078 Unit_Exceptions_Htable.Get
7081 begin
7086 else
7090 Unit_Exceptions_Htable.Set
7099 ----------------------
7100 -- Look_For_Sources --
7101 ----------------------
7103 procedure Look_For_Sources
7106 is
7112 -- Check if object file name of Src is already used in the project tree,
7113 -- and report an error if so.
7116 -- Check that no two sources of this project have the same object file
7119 -- Mark as such the sources that are declared as excluded
7121 ------------------
7122 -- Check_Object --
7123 ------------------
7128 begin
7131 -- We cannot just check on "Source /= Src", since we might have
7132 -- two different entries for the same file (and since that's
7133 -- the same file it is expected that it has the same object)
7137 then
7140 Error_Msg
7145 else
7150 ---------------------------
7151 -- Mark_Excluded_Sources --
7152 ---------------------------
7159 begin
7160 -- Minor optimization: if there are no excluded files, no need to
7161 -- traverse the list of sources. We cannot however also check whether
7162 -- the existing exceptions have ".Found" set to True (indicating we
7163 -- found them before) because we need to do some final processing on
7164 -- them in any case.
7167 No_File_Found
7168 then
7183 Write_Line
7188 Excluded_Sources_Htable.Remove
7199 -- If we have any excluded element left, that means we did not find
7200 -- the source file
7206 -- Check if the file belongs to another imported project to
7207 -- provide a better error message.
7209 Src := Find_Source
7218 Error_Msg
7221 else
7222 Error_Msg
7233 ------------------------
7234 -- Check_Object_Files --
7235 ------------------------
7242 begin
7244 loop
7251 then
7257 else
7271 else
7272 -- Check if it is a subunit
7274 Src_Ind :=
7280 else
7292 -- Start of processing for Look_For_Sources
7294 begin
7300 Mark_Excluded_Sources;
7301 Check_Object_Files;
7307 ------------------
7308 -- Path_Name_Of --
7309 ------------------
7311 function Path_Name_Of
7314 is
7318 begin
7320 Result :=
7321 Locate_Regular_File
7327 else
7328 declare
7330 begin
7338 -------------------
7339 -- Remove_Source --
7340 -------------------
7342 procedure Remove_Source
7345 is
7348 begin
7357 Write_Eol;
7368 -- ??? Should we remove the source from the unit ? The file is not used,
7369 -- so probably should not be referenced from the unit. On the other hand
7370 -- it might give useful additional info
7371 -- if Id.Unit /= null then
7372 -- Id.Unit.File_Names (Id.Kind) := null;
7373 -- end if;
7380 else
7389 -----------------------
7390 -- Report_No_Sources --
7391 -----------------------
7393 procedure Report_No_Sources
7399 is
7400 begin
7406 declare
7409 Lang_Name &
7412 begin
7417 else
7418 Error_Msg (Data.Flags, Msg, Location, Project);
7419 end if;
7420 end;
7421 end case;
7422 end Report_No_Sources;
7424 ----------------------
7425 -- Show_Source_Dirs --
7426 ----------------------
7428 procedure Show_Source_Dirs
7429 (Project : Project_Id;
7430 In_Tree : Project_Tree_Ref)
7431 is
7432 Current : String_List_Id;
7433 Element : String_Element;
7435 begin
7438 Current := Project.Source_Dirs;
7439 while Current /= Nil_String loop
7440 Element := In_Tree.String_Elements.Table (Current);
7442 Write_Line (Get_Name_String (Element.Value));
7443 Current := Element.Next;
7444 end loop;
7447 end Show_Source_Dirs;
7449 ---------------------------
7450 -- Process_Naming_Scheme --
7451 ---------------------------
7453 procedure Process_Naming_Scheme
7454 (Tree : Project_Tree_Ref;
7455 Root_Project : Project_Id;
7456 Flags : Processing_Flags)
7457 is
7458 procedure Recursive_Check
7459 (Project : Project_Id;
7460 Data : in out Tree_Processing_Data);
7461 -- Check_Naming_Scheme for the project
7463 ---------------------
7464 -- Recursive_Check --
7465 ---------------------
7467 procedure Recursive_Check
7468 (Project : Project_Id;
7469 Data : in out Tree_Processing_Data)
7470 is
7471 begin
7472 if Verbose_Mode then
7474 Write_Str (Get_Name_String (Project.Name));
7476 end if;
7478 Prj.Nmsc.Check (Project, Data);
7479 end Recursive_Check;
7481 procedure Check_All_Projects is new
7482 For_Every_Project_Imported (Tree_Processing_Data, Recursive_Check);
7484 Data : Tree_Processing_Data;
7486 -- Start of processing for Process_Naming_Scheme
7487 begin
7488 Initialize (Data, Tree => Tree, Flags => Flags);
7489 Check_All_Projects (Root_Project, Data, Imported_First => True);
7490 Free (Data);
7491 end Process_Naming_Scheme;
7493 end Prj.Nmsc;