1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2006, Free Software Foundation, Inc. --
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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Err_Vars
; use Err_Vars
;
30 with MLib
.Tgt
; use MLib
.Tgt
;
31 with Namet
; use Namet
;
32 with Osint
; use Osint
;
33 with Output
; use Output
;
34 with Prj
.Env
; use Prj
.Env
;
36 with Prj
.Util
; use Prj
.Util
;
38 with Snames
; use Snames
;
39 with Table
; use Table
;
40 with Targparm
; use Targparm
;
42 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
43 with Ada
.Strings
; use Ada
.Strings
;
44 with Ada
.Strings
.Fixed
; use Ada
.Strings
.Fixed
;
45 with Ada
.Strings
.Maps
.Constants
; use Ada
.Strings
.Maps
.Constants
;
47 with GNAT
.Case_Util
; use GNAT
.Case_Util
;
48 with GNAT
.Directory_Operations
; use GNAT
.Directory_Operations
;
51 package body Prj
.Nmsc
is
53 Error_Report
: Put_Line_Access
:= null;
54 -- Set to point to error reporting procedure
56 When_No_Sources
: Error_Warning
:= Error
;
57 -- Indicates what should be done when there is no Ada sources in a non
58 -- extending Ada project.
60 ALI_Suffix
: constant String := ".ali";
61 -- File suffix for ali files
63 Object_Suffix
: constant String := Get_Target_Object_Suffix
.all;
64 -- File suffix for object files
66 type Name_Location
is record
68 Location
: Source_Ptr
;
69 Found
: Boolean := False;
71 -- Information about file names found in string list attribute
72 -- Source_Files or in a source list file, stored in hash table
73 -- Source_Names, used by procedure Get_Path_Names_And_Record_Sources.
75 No_Name_Location
: constant Name_Location
:=
76 (Name
=> No_Name
, Location
=> No_Location
, Found
=> False);
78 package Source_Names
is new GNAT
.HTable
.Simple_HTable
79 (Header_Num
=> Header_Num
,
80 Element
=> Name_Location
,
81 No_Element
=> No_Name_Location
,
85 -- Hash table to store file names found in string list attribute
86 -- Source_Files or in a source list file, stored in hash table
87 -- Source_Names, used by procedure Get_Path_Names_And_Record_Sources.
89 package Recursive_Dirs
is new GNAT
.HTable
.Simple_HTable
90 (Header_Num
=> Header_Num
,
96 -- Hash table to store recursive source directories, to avoid looking
97 -- several times, and to avoid cycles that may be introduced by symbolic
100 type Ada_Naming_Exception_Id
is new Nat
;
101 No_Ada_Naming_Exception
: constant Ada_Naming_Exception_Id
:= 0;
103 type Unit_Info
is record
106 Next
: Ada_Naming_Exception_Id
:= No_Ada_Naming_Exception
;
108 -- No_Unit : constant Unit_Info :=
109 -- (Specification, No_Name, No_Ada_Naming_Exception);
111 package Ada_Naming_Exception_Table
is new Table
.Table
112 (Table_Component_Type
=> Unit_Info
,
113 Table_Index_Type
=> Ada_Naming_Exception_Id
,
114 Table_Low_Bound
=> 1,
116 Table_Increment
=> 100,
117 Table_Name
=> "Prj.Nmsc.Ada_Naming_Exception_Table");
119 package Ada_Naming_Exceptions
is new GNAT
.HTable
.Simple_HTable
120 (Header_Num
=> Header_Num
,
121 Element
=> Ada_Naming_Exception_Id
,
122 No_Element
=> No_Ada_Naming_Exception
,
126 -- A hash table to store naming exceptions for Ada. For each file name
127 -- there is one or several unit in table Ada_Naming_Exception_Table.
129 function Hash
(Unit
: Unit_Info
) return Header_Num
;
131 type Name_And_Index
is record
132 Name
: Name_Id
:= No_Name
;
135 No_Name_And_Index
: constant Name_And_Index
:=
136 (Name
=> No_Name
, Index
=> 0);
138 package Reverse_Ada_Naming_Exceptions
is new GNAT
.HTable
.Simple_HTable
139 (Header_Num
=> Header_Num
,
140 Element
=> Name_And_Index
,
141 No_Element
=> No_Name_And_Index
,
145 -- A table to check if a unit with an exceptional name will hide
146 -- a source with a file name following the naming convention.
148 function ALI_File_Name
(Source
: String) return String;
149 -- Return the ALI file name corresponding to a source
151 procedure Check_Ada_Name
(Name
: String; Unit
: out Name_Id
);
152 -- Check that a name is a valid Ada unit name
154 procedure Check_Naming_Scheme
155 (Data
: in out Project_Data
;
156 Project
: Project_Id
;
157 In_Tree
: Project_Tree_Ref
);
158 -- Check the naming scheme part of Data
160 procedure Check_Ada_Naming_Scheme_Validity
161 (Project
: Project_Id
;
162 In_Tree
: Project_Tree_Ref
;
163 Naming
: Naming_Data
);
164 -- Check that the package Naming is correct
166 procedure Check_For_Source
167 (File_Name
: Name_Id
;
169 Project
: Project_Id
;
170 In_Tree
: Project_Tree_Ref
;
171 Data
: in out Project_Data
;
172 Location
: Source_Ptr
;
173 Language
: Language_Index
;
175 Naming_Exception
: Boolean);
176 -- Check if a file, with name File_Name and path Path_Name, in a source
177 -- directory is a source for language Language in project Project of
178 -- project tree In_Tree. ???
180 procedure Check_If_Externally_Built
181 (Project
: Project_Id
;
182 In_Tree
: Project_Tree_Ref
;
183 Data
: in out Project_Data
);
184 -- Check attribute Externally_Built of project Project in project tree
185 -- In_Tree and modify its data Data if it has the value "true".
187 procedure Check_Library_Attributes
188 (Project
: Project_Id
;
189 In_Tree
: Project_Tree_Ref
;
190 Data
: in out Project_Data
);
191 -- Check the library attributes of project Project in project tree In_Tree
192 -- and modify its data Data accordingly.
194 procedure Check_Package_Naming
195 (Project
: Project_Id
;
196 In_Tree
: Project_Tree_Ref
;
197 Data
: in out Project_Data
);
198 -- Check package Naming of project Project in project tree In_Tree and
199 -- modify its data Data accordingly.
201 procedure Check_Programming_Languages
202 (In_Tree
: Project_Tree_Ref
; Data
: in out Project_Data
);
203 -- Check attribute Languages for the project with data Data in project
204 -- tree In_Tree and set the components of Data for all the programming
205 -- languages indicated in attribute Languages, if any.
207 function Check_Project
209 Root_Project
: Project_Id
;
210 In_Tree
: Project_Tree_Ref
;
211 Extending
: Boolean) return Boolean;
212 -- Returns True if P is Root_Project or, if Extending is True, a project
213 -- extended by Root_Project.
215 procedure Check_Stand_Alone_Library
216 (Project
: Project_Id
;
217 In_Tree
: Project_Tree_Ref
;
218 Data
: in out Project_Data
;
219 Extending
: Boolean);
220 -- Check if project Project in project tree In_Tree is a Stand-Alone
221 -- Library project, and modify its data Data accordingly if it is one.
223 function Compute_Directory_Last
(Dir
: String) return Natural;
224 -- Return the index of the last significant character in Dir. This is used
225 -- to avoid duplicates '/' at the end of directory names
227 function Body_Suffix_Of
228 (Language
: Language_Index
;
229 In_Project
: Project_Data
;
230 In_Tree
: Project_Tree_Ref
)
232 -- Returns the suffix of sources of language Language in project In_Project
233 -- in project tree In_Tree.
236 (Project
: Project_Id
;
237 In_Tree
: Project_Tree_Ref
;
239 Flag_Location
: Source_Ptr
);
240 -- Output an error message. If Error_Report is null, simply call
241 -- Prj.Err.Error_Msg. Otherwise, disregard Flag_Location and use
244 procedure Find_Sources
245 (Project
: Project_Id
;
246 In_Tree
: Project_Tree_Ref
;
247 Data
: in out Project_Data
;
248 For_Language
: Language_Index
;
249 Follow_Links
: Boolean := False);
250 -- Find all the sources in all of the source directories of a project for
251 -- a specified language.
253 procedure Free_Ada_Naming_Exceptions
;
254 -- Free the internal hash tables used for checking naming exceptions
256 procedure Get_Directories
257 (Project
: Project_Id
;
258 In_Tree
: Project_Tree_Ref
;
259 Data
: in out Project_Data
);
260 -- Get the object directory, the exec directory and the source directories
264 (Project
: Project_Id
;
265 In_Tree
: Project_Tree_Ref
;
266 Data
: in out Project_Data
);
267 -- Get the mains of a project from attribute Main, if it exists, and put
268 -- them in the project data.
270 procedure Get_Sources_From_File
272 Location
: Source_Ptr
;
273 Project
: Project_Id
;
274 In_Tree
: Project_Tree_Ref
);
275 -- Get the list of sources from a text file and put them in hash table
279 (Canonical_File_Name
: Name_Id
;
280 Naming
: Naming_Data
;
281 Exception_Id
: out Ada_Naming_Exception_Id
;
282 Unit_Name
: out Name_Id
;
283 Unit_Kind
: out Spec_Or_Body
;
284 Needs_Pragma
: out Boolean);
285 -- Find out, from a file name, the unit name, the unit kind and if a
286 -- specific SFN pragma is needed. If the file name corresponds to no
287 -- unit, then Unit_Name will be No_Name. If the file is a multi-unit source
288 -- or an exception to the naming scheme, then Exception_Id is set to
289 -- the unit or units that the source contains.
291 function Is_Illegal_Suffix
293 Dot_Replacement_Is_A_Single_Dot
: Boolean) return Boolean;
294 -- Returns True if the string Suffix cannot be used as
295 -- a spec suffix, a body suffix or a separate suffix.
297 procedure Locate_Directory
301 Display
: out Name_Id
);
302 -- Locate a directory (returns No_Name for Dir and Display if directory
303 -- does not exist). Name is the directory name. Parent is the root
304 -- directory, if Name is a relative path name. Dir is the canonical case
305 -- path name of the directory, Display is the directory path name for
308 procedure Look_For_Sources
309 (Project
: Project_Id
;
310 In_Tree
: Project_Tree_Ref
;
311 Data
: in out Project_Data
;
312 Follow_Links
: Boolean);
313 -- Find all the sources of a project
315 function Path_Name_Of
316 (File_Name
: Name_Id
;
317 Directory
: Name_Id
) return String;
318 -- Returns the path name of a (non project) file.
319 -- Returns an empty string if file cannot be found.
321 procedure Prepare_Ada_Naming_Exceptions
322 (List
: Array_Element_Id
;
323 In_Tree
: Project_Tree_Ref
;
324 Kind
: Spec_Or_Body
);
325 -- Prepare the internal hash tables used for checking naming exceptions
326 -- for Ada. Insert all elements of List in the tables.
328 function Project_Extends
329 (Extending
: Project_Id
;
330 Extended
: Project_Id
;
331 In_Tree
: Project_Tree_Ref
) return Boolean;
332 -- Returns True if Extending is extending Extended either directly or
335 procedure Record_Ada_Source
336 (File_Name
: Name_Id
;
338 Project
: Project_Id
;
339 In_Tree
: Project_Tree_Ref
;
340 Data
: in out Project_Data
;
341 Location
: Source_Ptr
;
342 Current_Source
: in out String_List_Id
;
343 Source_Recorded
: in out Boolean;
344 Follow_Links
: Boolean);
345 -- Put a unit in the list of units of a project, if the file name
346 -- corresponds to a valid unit name.
348 procedure Record_Other_Sources
349 (Project
: Project_Id
;
350 In_Tree
: Project_Tree_Ref
;
351 Data
: in out Project_Data
;
352 Language
: Language_Index
;
353 Naming_Exceptions
: Boolean);
354 -- Record the sources of a language in a project.
355 -- When Naming_Exceptions is True, mark the found sources as such, to
356 -- later remove those that are not named in a list of sources.
358 procedure Report_No_Ada_Sources
359 (Project
: Project_Id
;
360 In_Tree
: Project_Tree_Ref
;
361 Location
: Source_Ptr
);
362 -- Report an error or a warning depending on the value of When_No_Sources
364 procedure Show_Source_Dirs
365 (Project
: Project_Id
; In_Tree
: Project_Tree_Ref
);
366 -- List all the source directories of a project
369 (Language
: Language_Index
;
370 Naming
: Naming_Data
;
371 In_Tree
: Project_Tree_Ref
) return Name_Id
;
372 -- Get the suffix for the source of a language from a package naming.
373 -- If not specified, return the default for the language.
375 procedure Warn_If_Not_Sources
376 (Project
: Project_Id
;
377 In_Tree
: Project_Tree_Ref
;
378 Conventions
: Array_Element_Id
;
380 Extending
: Boolean);
381 -- Check that individual naming conventions apply to immediate
382 -- sources of the project; if not, issue a warning.
388 function ALI_File_Name
(Source
: String) return String is
390 -- If the source name has an extension, then replace it with
393 for Index
in reverse Source
'First + 1 .. Source
'Last loop
394 if Source
(Index
) = '.' then
395 return Source
(Source
'First .. Index
- 1) & ALI_Suffix
;
399 -- If there is no dot, or if it is the first character, just add the
402 return Source
& ALI_Suffix
;
410 (Project
: Project_Id
;
411 In_Tree
: Project_Tree_Ref
;
412 Report_Error
: Put_Line_Access
;
413 Follow_Links
: Boolean;
414 When_No_Sources
: Error_Warning
)
416 Data
: Project_Data
:= In_Tree
.Projects
.Table
(Project
);
417 Extending
: Boolean := False;
420 Nmsc
.When_No_Sources
:= When_No_Sources
;
421 Error_Report
:= Report_Error
;
423 Recursive_Dirs
.Reset
;
425 -- Object, exec and source directories
427 Get_Directories
(Project
, In_Tree
, Data
);
429 -- Get the programming languages
431 Check_Programming_Languages
(In_Tree
, Data
);
433 -- Library attributes
435 Check_Library_Attributes
(Project
, In_Tree
, Data
);
437 Check_If_Externally_Built
(Project
, In_Tree
, Data
);
439 if Current_Verbosity
= High
then
440 Show_Source_Dirs
(Project
, In_Tree
);
443 Check_Package_Naming
(Project
, In_Tree
, Data
);
445 Extending
:= Data
.Extends
/= No_Project
;
447 Check_Naming_Scheme
(Data
, Project
, In_Tree
);
449 Prepare_Ada_Naming_Exceptions
450 (Data
.Naming
.Bodies
, In_Tree
, Body_Part
);
451 Prepare_Ada_Naming_Exceptions
452 (Data
.Naming
.Specs
, In_Tree
, Specification
);
456 if Data
.Source_Dirs
/= Nil_String
then
457 Look_For_Sources
(Project
, In_Tree
, Data
, Follow_Links
);
460 if Data
.Ada_Sources_Present
then
462 -- Check that all individual naming conventions apply to sources of
463 -- this project file.
466 (Project
, In_Tree
, Data
.Naming
.Bodies
,
468 Extending
=> Extending
);
470 (Project
, In_Tree
, Data
.Naming
.Specs
,
472 Extending
=> Extending
);
475 -- If it is a library project file, check if it is a standalone library
478 Check_Stand_Alone_Library
(Project
, In_Tree
, Data
, Extending
);
481 -- Put the list of Mains, if any, in the project data
483 Get_Mains
(Project
, In_Tree
, Data
);
485 -- Update the project data in the Projects table
487 In_Tree
.Projects
.Table
(Project
) := Data
;
489 Free_Ada_Naming_Exceptions
;
496 procedure Check_Ada_Name
(Name
: String; Unit
: out Name_Id
) is
497 The_Name
: String := Name
;
499 Need_Letter
: Boolean := True;
500 Last_Underscore
: Boolean := False;
501 OK
: Boolean := The_Name
'Length > 0;
506 Name_Len
:= The_Name
'Length;
507 Name_Buffer
(1 .. Name_Len
) := The_Name
;
508 Real_Name
:= Name_Find
;
510 -- Check first that the given name is not an Ada reserved word
512 if Get_Name_Table_Byte
(Real_Name
) /= 0
513 and then Real_Name
/= Name_Project
514 and then Real_Name
/= Name_Extends
515 and then Real_Name
/= Name_External
519 if Current_Verbosity
= High
then
520 Write_Str
(The_Name
);
521 Write_Line
(" is an Ada reserved word.");
527 for Index
in The_Name
'Range loop
530 -- We need a letter (at the beginning, and following a dot),
531 -- but we don't have one.
533 if Is_Letter
(The_Name
(Index
)) then
534 Need_Letter
:= False;
539 if Current_Verbosity
= High
then
540 Write_Int
(Types
.Int
(Index
));
542 Write_Char
(The_Name
(Index
));
543 Write_Line
("' is not a letter.");
549 elsif Last_Underscore
550 and then (The_Name
(Index
) = '_' or else The_Name
(Index
) = '.')
552 -- Two underscores are illegal, and a dot cannot follow
557 if Current_Verbosity
= High
then
558 Write_Int
(Types
.Int
(Index
));
560 Write_Char
(The_Name
(Index
));
561 Write_Line
("' is illegal here.");
566 elsif The_Name
(Index
) = '.' then
568 -- We need a letter after a dot
572 elsif The_Name
(Index
) = '_' then
573 Last_Underscore
:= True;
576 -- We need an letter or a digit
578 Last_Underscore
:= False;
580 if not Is_Alphanumeric
(The_Name
(Index
)) then
583 if Current_Verbosity
= High
then
584 Write_Int
(Types
.Int
(Index
));
586 Write_Char
(The_Name
(Index
));
587 Write_Line
("' is not alphanumeric.");
595 -- Cannot end with an underscore or a dot
597 OK
:= OK
and then not Need_Letter
and then not Last_Underscore
;
603 -- Signal a problem with No_Name
609 --------------------------------------
610 -- Check_Ada_Naming_Scheme_Validity --
611 --------------------------------------
613 procedure Check_Ada_Naming_Scheme_Validity
614 (Project
: Project_Id
;
615 In_Tree
: Project_Tree_Ref
;
616 Naming
: Naming_Data
)
619 -- Only check if we are not using the Default naming scheme
621 if Naming
/= In_Tree
.Private_Part
.Default_Naming
then
623 Dot_Replacement
: constant String :=
625 (Naming
.Dot_Replacement
);
627 Spec_Suffix
: constant String :=
629 (Naming
.Ada_Spec_Suffix
);
631 Body_Suffix
: constant String :=
633 (Naming
.Ada_Body_Suffix
);
635 Separate_Suffix
: constant String :=
637 (Naming
.Separate_Suffix
);
640 -- Dot_Replacement cannot
642 -- - start or end with an alphanumeric
644 -- - start with an '_' followed by an alphanumeric
645 -- - contain a '.' except if it is "."
647 if Dot_Replacement
'Length = 0
648 or else Is_Alphanumeric
649 (Dot_Replacement
(Dot_Replacement
'First))
650 or else Is_Alphanumeric
651 (Dot_Replacement
(Dot_Replacement
'Last))
652 or else (Dot_Replacement
(Dot_Replacement
'First) = '_'
654 (Dot_Replacement
'Length = 1
657 (Dot_Replacement
(Dot_Replacement
'First + 1))))
658 or else (Dot_Replacement
'Length > 1
660 Index
(Source
=> Dot_Replacement
,
661 Pattern
=> ".") /= 0)
665 '"' & Dot_Replacement
&
666 """ is illegal for Dot_Replacement.",
667 Naming
.Dot_Repl_Loc
);
674 (Spec_Suffix
, Dot_Replacement
= ".")
676 Err_Vars
.Error_Msg_Name_1
:= Naming
.Ada_Spec_Suffix
;
679 "{ is illegal for Spec_Suffix",
680 Naming
.Spec_Suffix_Loc
);
684 (Body_Suffix
, Dot_Replacement
= ".")
686 Err_Vars
.Error_Msg_Name_1
:= Naming
.Ada_Body_Suffix
;
689 "{ is illegal for Body_Suffix",
690 Naming
.Body_Suffix_Loc
);
693 if Body_Suffix
/= Separate_Suffix
then
695 (Separate_Suffix
, Dot_Replacement
= ".")
697 Err_Vars
.Error_Msg_Name_1
:= Naming
.Separate_Suffix
;
700 "{ is illegal for Separate_Suffix",
701 Naming
.Sep_Suffix_Loc
);
705 -- Spec_Suffix cannot have the same termination as
706 -- Body_Suffix or Separate_Suffix
708 if Spec_Suffix
'Length <= Body_Suffix
'Length
710 Body_Suffix
(Body_Suffix
'Last -
711 Spec_Suffix
'Length + 1 ..
712 Body_Suffix
'Last) = Spec_Suffix
718 """) cannot end with" &
720 Spec_Suffix
& """).",
721 Naming
.Body_Suffix_Loc
);
724 if Body_Suffix
/= Separate_Suffix
725 and then Spec_Suffix
'Length <= Separate_Suffix
'Length
728 (Separate_Suffix
'Last - Spec_Suffix
'Length + 1
730 Separate_Suffix
'Last) = Spec_Suffix
734 "Separate_Suffix (""" &
736 """) cannot end with" &
738 Spec_Suffix
& """).",
739 Naming
.Sep_Suffix_Loc
);
743 end Check_Ada_Naming_Scheme_Validity
;
745 ----------------------
746 -- Check_For_Source --
747 ----------------------
749 procedure Check_For_Source
750 (File_Name
: Name_Id
;
752 Project
: Project_Id
;
753 In_Tree
: Project_Tree_Ref
;
754 Data
: in out Project_Data
;
755 Location
: Source_Ptr
;
756 Language
: Language_Index
;
758 Naming_Exception
: Boolean)
760 Name
: String := Get_Name_String
(File_Name
);
761 Real_Location
: Source_Ptr
:= Location
;
764 Canonical_Case_File_Name
(Name
);
766 -- A file is a source of a language if Naming_Exception is True (case
767 -- of naming exceptions) or if its file name ends with the suffix.
769 if Naming_Exception
or else
770 (Name
'Length > Suffix
'Length and then
771 Name
(Name
'Last - Suffix
'Length + 1 .. Name
'Last) = Suffix
)
773 if Real_Location
= No_Location
then
774 Real_Location
:= Data
.Location
;
778 Path
: String := Get_Name_String
(Path_Name
);
781 -- The path name id (in canonical case)
784 -- The file name id (in canonical case)
787 -- The object file name
789 Obj_Path_Id
: Name_Id
;
790 -- The object path name
793 -- The dependency file name
795 Dep_Path_Id
: Name_Id
;
796 -- The dependency path name
798 Dot_Pos
: Natural := 0;
799 -- Position of the last dot in Name
801 Source
: Other_Source
;
802 Source_Id
: Other_Source_Id
:= Data
.First_Other_Source
;
805 Canonical_Case_File_Name
(Path
);
807 -- Get the file name id
809 Name_Len
:= Name
'Length;
810 Name_Buffer
(1 .. Name_Len
) := Name
;
811 File_Id
:= Name_Find
;
813 -- Get the path name id
815 Name_Len
:= Path
'Length;
816 Name_Buffer
(1 .. Name_Len
) := Path
;
817 Path_Id
:= Name_Find
;
819 -- Find the position of the last dot
821 for J
in reverse Name
'Range loop
822 if Name
(J
) = '.' then
828 if Dot_Pos
<= Name
'First then
829 Dot_Pos
:= Name
'Last + 1;
832 -- Compute the object file name
834 Get_Name_String
(File_Id
);
835 Name_Len
:= Dot_Pos
- Name
'First;
837 for J
in Object_Suffix
'Range loop
838 Name_Len
:= Name_Len
+ 1;
839 Name_Buffer
(Name_Len
) := Object_Suffix
(J
);
844 -- Compute the object path name
846 Get_Name_String
(Data
.Object_Directory
);
848 if Name_Buffer
(Name_Len
) /= Directory_Separator
and then
849 Name_Buffer
(Name_Len
) /= '/'
851 Name_Len
:= Name_Len
+ 1;
852 Name_Buffer
(Name_Len
) := Directory_Separator
;
855 Add_Str_To_Name_Buffer
(Get_Name_String
(Obj_Id
));
856 Obj_Path_Id
:= Name_Find
;
858 -- Compute the dependency file name
860 Get_Name_String
(File_Id
);
861 Name_Len
:= Dot_Pos
- Name
'First + 1;
862 Name_Buffer
(Name_Len
) := '.';
863 Name_Len
:= Name_Len
+ 1;
864 Name_Buffer
(Name_Len
) := 'd';
867 -- Compute the dependency path name
869 Get_Name_String
(Data
.Object_Directory
);
871 if Name_Buffer
(Name_Len
) /= Directory_Separator
and then
872 Name_Buffer
(Name_Len
) /= '/'
874 Name_Len
:= Name_Len
+ 1;
875 Name_Buffer
(Name_Len
) := Directory_Separator
;
878 Add_Str_To_Name_Buffer
(Get_Name_String
(Dep_Id
));
879 Dep_Path_Id
:= Name_Find
;
881 -- Check if source is already in the list of source for this
882 -- project: it may have already been specified as a naming
883 -- exception for the same language or an other language, or
884 -- they may be two identical file names in different source
887 while Source_Id
/= No_Other_Source
loop
888 Source
:= In_Tree
.Other_Sources
.Table
(Source_Id
);
890 if Source
.File_Name
= File_Id
then
892 -- Two sources of different languages cannot have the same
895 if Source
.Language
/= Language
then
896 Error_Msg_Name_1
:= File_Name
;
899 "{ cannot be a source of several languages",
903 -- No problem if a file has already been specified as
904 -- a naming exception of this language.
906 elsif Source
.Path_Name
= Path_Id
then
908 -- Reset the naming exception flag, if this is not a
911 if not Naming_Exception
then
912 In_Tree
.Other_Sources
.Table
913 (Source_Id
).Naming_Exception
:= False;
918 -- There are several files with the same names, but the
919 -- order of the source directories is known (no /**):
920 -- only the first one encountered is kept, the other ones
923 elsif Data
.Known_Order_Of_Source_Dirs
then
926 -- But it is an error if the order of the source directories
930 Error_Msg_Name_1
:= File_Name
;
933 "{ is found in several source directories",
938 -- Two sources with different file names cannot have the same
941 elsif Source
.Object_Name
= Obj_Id
then
942 Error_Msg_Name_1
:= File_Id
;
943 Error_Msg_Name_2
:= Source
.File_Name
;
944 Error_Msg_Name_3
:= Obj_Id
;
947 "{ and { have the same object file {",
952 Source_Id
:= Source
.Next
;
955 if Current_Verbosity
= High
then
956 Write_Str
(" found ");
957 Display_Language_Name
(Language
);
958 Write_Str
(" source """);
959 Write_Str
(Get_Name_String
(File_Name
));
961 Write_Str
(" object path = ");
962 Write_Line
(Get_Name_String
(Obj_Path_Id
));
965 -- Create the Other_Source record
968 (Language
=> Language
,
969 File_Name
=> File_Id
,
970 Path_Name
=> Path_Id
,
971 Source_TS
=> File_Stamp
(Path_Id
),
972 Object_Name
=> Obj_Id
,
973 Object_Path
=> Obj_Path_Id
,
974 Object_TS
=> File_Stamp
(Obj_Path_Id
),
976 Dep_Path
=> Dep_Path_Id
,
977 Dep_TS
=> File_Stamp
(Dep_Path_Id
),
978 Naming_Exception
=> Naming_Exception
,
979 Next
=> No_Other_Source
);
981 -- And add it to the Other_Sources table
983 Other_Source_Table
.Increment_Last
984 (In_Tree
.Other_Sources
);
985 In_Tree
.Other_Sources
.Table
986 (Other_Source_Table
.Last
(In_Tree
.Other_Sources
)) :=
989 -- There are sources of languages other than Ada in this project
991 Data
.Other_Sources_Present
:= True;
993 -- And there are sources of this language in this project
995 Set
(Language
, True, Data
, In_Tree
);
997 -- Add this source to the list of sources of languages other than
998 -- Ada of the project.
1000 if Data
.First_Other_Source
= No_Other_Source
then
1001 Data
.First_Other_Source
:=
1002 Other_Source_Table
.Last
(In_Tree
.Other_Sources
);
1005 In_Tree
.Other_Sources
.Table
(Data
.Last_Other_Source
).Next
:=
1006 Other_Source_Table
.Last
(In_Tree
.Other_Sources
);
1009 Data
.Last_Other_Source
:=
1010 Other_Source_Table
.Last
(In_Tree
.Other_Sources
);
1013 end Check_For_Source
;
1015 -------------------------------
1016 -- Check_If_Externally_Built --
1017 -------------------------------
1019 procedure Check_If_Externally_Built
1020 (Project
: Project_Id
;
1021 In_Tree
: Project_Tree_Ref
;
1022 Data
: in out Project_Data
)
1024 Externally_Built
: constant Variable_Value
:=
1026 (Name_Externally_Built
,
1027 Data
.Decl
.Attributes
, In_Tree
);
1030 if not Externally_Built
.Default
then
1031 Get_Name_String
(Externally_Built
.Value
);
1032 To_Lower
(Name_Buffer
(1 .. Name_Len
));
1034 if Name_Buffer
(1 .. Name_Len
) = "true" then
1035 Data
.Externally_Built
:= True;
1037 elsif Name_Buffer
(1 .. Name_Len
) /= "false" then
1038 Error_Msg
(Project
, In_Tree
,
1039 "Externally_Built may only be true or false",
1040 Externally_Built
.Location
);
1044 if Current_Verbosity
= High
then
1045 Write_Str
("Project is ");
1047 if not Data
.Externally_Built
then
1051 Write_Line
("externally built.");
1053 end Check_If_Externally_Built
;
1055 -----------------------------
1056 -- Check_Naming_Scheme --
1057 -----------------------------
1059 procedure Check_Naming_Scheme
1060 (Data
: in out Project_Data
;
1061 Project
: Project_Id
;
1062 In_Tree
: Project_Tree_Ref
)
1064 Naming_Id
: constant Package_Id
:=
1065 Util
.Value_Of
(Name_Naming
, Data
.Decl
.Packages
, In_Tree
);
1067 Naming
: Package_Element
;
1069 procedure Check_Unit_Names
(List
: Array_Element_Id
);
1070 -- Check that a list of unit names contains only valid names
1072 ----------------------
1073 -- Check_Unit_Names --
1074 ----------------------
1076 procedure Check_Unit_Names
(List
: Array_Element_Id
) is
1077 Current
: Array_Element_Id
:= List
;
1078 Element
: Array_Element
;
1079 Unit_Name
: Name_Id
;
1082 -- Loop through elements of the string list
1084 while Current
/= No_Array_Element
loop
1085 Element
:= In_Tree
.Array_Elements
.Table
(Current
);
1087 -- Put file name in canonical case
1089 Get_Name_String
(Element
.Value
.Value
);
1090 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
1091 Element
.Value
.Value
:= Name_Find
;
1093 -- Check that it contains a valid unit name
1095 Get_Name_String
(Element
.Index
);
1096 Check_Ada_Name
(Name_Buffer
(1 .. Name_Len
), Unit_Name
);
1098 if Unit_Name
= No_Name
then
1099 Err_Vars
.Error_Msg_Name_1
:= Element
.Index
;
1102 "{ is not a valid unit name.",
1103 Element
.Value
.Location
);
1106 if Current_Verbosity
= High
then
1107 Write_Str
(" Unit (""");
1108 Write_Str
(Get_Name_String
(Unit_Name
));
1112 Element
.Index
:= Unit_Name
;
1113 In_Tree
.Array_Elements
.Table
(Current
) := Element
;
1116 Current
:= Element
.Next
;
1118 end Check_Unit_Names
;
1120 -- Start of processing for Check_Naming_Scheme
1123 -- If there is a package Naming, we will put in Data.Naming what is in
1124 -- this package Naming.
1126 if Naming_Id
/= No_Package
then
1127 Naming
:= In_Tree
.Packages
.Table
(Naming_Id
);
1129 if Current_Verbosity
= High
then
1130 Write_Line
("Checking ""Naming"" for Ada.");
1134 Bodies
: constant Array_Element_Id
:=
1135 Util
.Value_Of
(Name_Body
, Naming
.Decl
.Arrays
, In_Tree
);
1137 Specs
: constant Array_Element_Id
:=
1138 Util
.Value_Of
(Name_Spec
, Naming
.Decl
.Arrays
, In_Tree
);
1141 if Bodies
/= No_Array_Element
then
1143 -- We have elements in the array Body_Part
1145 if Current_Verbosity
= High
then
1146 Write_Line
("Found Bodies.");
1149 Data
.Naming
.Bodies
:= Bodies
;
1150 Check_Unit_Names
(Bodies
);
1153 if Current_Verbosity
= High
then
1154 Write_Line
("No Bodies.");
1158 if Specs
/= No_Array_Element
then
1160 -- We have elements in the array Specs
1162 if Current_Verbosity
= High
then
1163 Write_Line
("Found Specs.");
1166 Data
.Naming
.Specs
:= Specs
;
1167 Check_Unit_Names
(Specs
);
1170 if Current_Verbosity
= High
then
1171 Write_Line
("No Specs.");
1176 -- We are now checking if variables Dot_Replacement, Casing,
1177 -- Spec_Suffix, Body_Suffix and/or Separate_Suffix
1180 -- For each variable, if it does not exist, we do nothing,
1181 -- because we already have the default.
1183 -- Check Dot_Replacement
1186 Dot_Replacement
: constant Variable_Value
:=
1188 (Name_Dot_Replacement
,
1189 Naming
.Decl
.Attributes
, In_Tree
);
1192 pragma Assert
(Dot_Replacement
.Kind
= Single
,
1193 "Dot_Replacement is not a single string");
1195 if not Dot_Replacement
.Default
then
1196 Get_Name_String
(Dot_Replacement
.Value
);
1198 if Name_Len
= 0 then
1201 "Dot_Replacement cannot be empty",
1202 Dot_Replacement
.Location
);
1205 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
1206 Data
.Naming
.Dot_Replacement
:= Name_Find
;
1207 Data
.Naming
.Dot_Repl_Loc
:= Dot_Replacement
.Location
;
1212 if Current_Verbosity
= High
then
1213 Write_Str
(" Dot_Replacement = """);
1214 Write_Str
(Get_Name_String
(Data
.Naming
.Dot_Replacement
));
1222 Casing_String
: constant Variable_Value
:=
1224 (Name_Casing
, Naming
.Decl
.Attributes
, In_Tree
);
1227 pragma Assert
(Casing_String
.Kind
= Single
,
1228 "Casing is not a single string");
1230 if not Casing_String
.Default
then
1232 Casing_Image
: constant String :=
1233 Get_Name_String
(Casing_String
.Value
);
1236 Casing_Value
: constant Casing_Type
:=
1237 Value
(Casing_Image
);
1239 Data
.Naming
.Casing
:= Casing_Value
;
1243 when Constraint_Error
=>
1244 if Casing_Image
'Length = 0 then
1247 "Casing cannot be an empty string",
1248 Casing_String
.Location
);
1251 Name_Len
:= Casing_Image
'Length;
1252 Name_Buffer
(1 .. Name_Len
) := Casing_Image
;
1253 Err_Vars
.Error_Msg_Name_1
:= Name_Find
;
1256 "{ is not a correct Casing",
1257 Casing_String
.Location
);
1263 if Current_Verbosity
= High
then
1264 Write_Str
(" Casing = ");
1265 Write_Str
(Image
(Data
.Naming
.Casing
));
1270 -- Check Spec_Suffix
1273 Ada_Spec_Suffix
: constant Variable_Value
:=
1277 In_Array
=> Data
.Naming
.Spec_Suffix
,
1278 In_Tree
=> In_Tree
);
1281 if Ada_Spec_Suffix
.Kind
= Single
1282 and then Get_Name_String
(Ada_Spec_Suffix
.Value
) /= ""
1284 Get_Name_String
(Ada_Spec_Suffix
.Value
);
1285 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
1286 Data
.Naming
.Ada_Spec_Suffix
:= Name_Find
;
1287 Data
.Naming
.Spec_Suffix_Loc
:= Ada_Spec_Suffix
.Location
;
1290 Data
.Naming
.Ada_Spec_Suffix
:= Default_Ada_Spec_Suffix
;
1294 if Current_Verbosity
= High
then
1295 Write_Str
(" Spec_Suffix = """);
1296 Write_Str
(Get_Name_String
(Data
.Naming
.Ada_Spec_Suffix
));
1301 -- Check Body_Suffix
1304 Ada_Body_Suffix
: constant Variable_Value
:=
1308 In_Array
=> Data
.Naming
.Body_Suffix
,
1309 In_Tree
=> In_Tree
);
1312 if Ada_Body_Suffix
.Kind
= Single
1313 and then Get_Name_String
(Ada_Body_Suffix
.Value
) /= ""
1315 Get_Name_String
(Ada_Body_Suffix
.Value
);
1316 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
1317 Data
.Naming
.Ada_Body_Suffix
:= Name_Find
;
1318 Data
.Naming
.Body_Suffix_Loc
:= Ada_Body_Suffix
.Location
;
1321 Data
.Naming
.Ada_Body_Suffix
:= Default_Ada_Body_Suffix
;
1325 if Current_Verbosity
= High
then
1326 Write_Str
(" Body_Suffix = """);
1327 Write_Str
(Get_Name_String
(Data
.Naming
.Ada_Body_Suffix
));
1332 -- Check Separate_Suffix
1335 Ada_Sep_Suffix
: constant Variable_Value
:=
1337 (Variable_Name
=> Name_Separate_Suffix
,
1338 In_Variables
=> Naming
.Decl
.Attributes
,
1339 In_Tree
=> In_Tree
);
1342 if Ada_Sep_Suffix
.Default
then
1343 Data
.Naming
.Separate_Suffix
:=
1344 Data
.Naming
.Ada_Body_Suffix
;
1347 Get_Name_String
(Ada_Sep_Suffix
.Value
);
1349 if Name_Len
= 0 then
1352 "Separate_Suffix cannot be empty",
1353 Ada_Sep_Suffix
.Location
);
1356 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
1357 Data
.Naming
.Separate_Suffix
:= Name_Find
;
1358 Data
.Naming
.Sep_Suffix_Loc
:= Ada_Sep_Suffix
.Location
;
1363 if Current_Verbosity
= High
then
1364 Write_Str
(" Separate_Suffix = """);
1365 Write_Str
(Get_Name_String
(Data
.Naming
.Separate_Suffix
));
1370 -- Check if Data.Naming is valid
1372 Check_Ada_Naming_Scheme_Validity
(Project
, In_Tree
, Data
.Naming
);
1375 Data
.Naming
.Ada_Spec_Suffix
:= Default_Ada_Spec_Suffix
;
1376 Data
.Naming
.Ada_Body_Suffix
:= Default_Ada_Body_Suffix
;
1377 Data
.Naming
.Separate_Suffix
:= Default_Ada_Body_Suffix
;
1379 end Check_Naming_Scheme
;
1381 ------------------------------
1382 -- Check_Library_Attributes --
1383 ------------------------------
1385 procedure Check_Library_Attributes
1386 (Project
: Project_Id
;
1387 In_Tree
: Project_Tree_Ref
;
1388 Data
: in out Project_Data
)
1390 Attributes
: constant Prj
.Variable_Id
:= Data
.Decl
.Attributes
;
1392 Lib_Dir
: constant Prj
.Variable_Value
:=
1394 (Snames
.Name_Library_Dir
, Attributes
, In_Tree
);
1396 Lib_Name
: constant Prj
.Variable_Value
:=
1398 (Snames
.Name_Library_Name
, Attributes
, In_Tree
);
1400 Lib_Version
: constant Prj
.Variable_Value
:=
1402 (Snames
.Name_Library_Version
, Attributes
, In_Tree
);
1404 Lib_ALI_Dir
: constant Prj
.Variable_Value
:=
1406 (Snames
.Name_Library_Ali_Dir
, Attributes
, In_Tree
);
1408 The_Lib_Kind
: constant Prj
.Variable_Value
:=
1410 (Snames
.Name_Library_Kind
, Attributes
, In_Tree
);
1413 -- Special case of extending project
1415 if Data
.Extends
/= No_Project
then
1417 Extended_Data
: constant Project_Data
:=
1418 In_Tree
.Projects
.Table
(Data
.Extends
);
1421 -- If the project extended is a library project, we inherit
1422 -- the library name, if it is not redefined; we check that
1423 -- the library directory is specified; and we reset the
1424 -- library flag for the extended project.
1426 if Extended_Data
.Library
then
1427 if Lib_Name
.Default
then
1428 Data
.Library_Name
:= Extended_Data
.Library_Name
;
1431 if Lib_Dir
.Default
then
1432 if not Data
.Virtual
then
1435 "a project extending a library project must " &
1436 "specify an attribute Library_Dir",
1441 In_Tree
.Projects
.Table
(Data
.Extends
).Library
:=
1447 pragma Assert
(Lib_Dir
.Kind
= Single
);
1449 if Lib_Dir
.Value
= Empty_String
then
1450 if Current_Verbosity
= High
then
1451 Write_Line
("No library directory");
1455 -- Find path name, check that it is a directory
1458 (Lib_Dir
.Value
, Data
.Display_Directory
,
1459 Data
.Library_Dir
, Data
.Display_Library_Dir
);
1461 if Data
.Library_Dir
= No_Name
then
1463 -- Get the absolute name of the library directory that
1464 -- does not exist, to report an error.
1467 Dir_Name
: constant String := Get_Name_String
(Lib_Dir
.Value
);
1470 if Is_Absolute_Path
(Dir_Name
) then
1471 Err_Vars
.Error_Msg_Name_1
:= Lib_Dir
.Value
;
1474 Get_Name_String
(Data
.Display_Directory
);
1476 if Name_Buffer
(Name_Len
) /= Directory_Separator
then
1477 Name_Len
:= Name_Len
+ 1;
1478 Name_Buffer
(Name_Len
) := Directory_Separator
;
1482 (Name_Len
+ 1 .. Name_Len
+ Dir_Name
'Length) :=
1484 Name_Len
:= Name_Len
+ Dir_Name
'Length;
1485 Err_Vars
.Error_Msg_Name_1
:= Name_Find
;
1492 "library directory { does not exist",
1496 -- The library directory cannot be the same as the Object directory
1498 elsif Data
.Library_Dir
= Data
.Object_Directory
then
1501 "library directory cannot be the same " &
1502 "as object directory",
1504 Data
.Library_Dir
:= No_Name
;
1505 Data
.Display_Library_Dir
:= No_Name
;
1509 OK
: Boolean := True;
1510 Dirs_Id
: String_List_Id
;
1511 Dir_Elem
: String_Element
;
1514 -- The library directory cannot be the same as a source
1515 -- directory of the current project.
1517 Dirs_Id
:= Data
.Source_Dirs
;
1518 while Dirs_Id
/= Nil_String
loop
1519 Dir_Elem
:= In_Tree
.String_Elements
.Table
(Dirs_Id
);
1520 Dirs_Id
:= Dir_Elem
.Next
;
1522 if Data
.Library_Dir
= Dir_Elem
.Value
then
1523 Err_Vars
.Error_Msg_Name_1
:= Dir_Elem
.Value
;
1526 "library directory cannot be the same " &
1527 "as source directory {",
1536 -- The library directory cannot be the same as a source
1537 -- directory of another project either.
1540 for Pid
in 1 .. Project_Table
.Last
(In_Tree
.Projects
) loop
1541 if Pid
/= Project
then
1542 Dirs_Id
:= In_Tree
.Projects
.Table
(Pid
).Source_Dirs
;
1544 Dir_Loop
: while Dirs_Id
/= Nil_String
loop
1545 Dir_Elem
:= In_Tree
.String_Elements
.Table
(Dirs_Id
);
1546 Dirs_Id
:= Dir_Elem
.Next
;
1548 if Data
.Library_Dir
= Dir_Elem
.Value
then
1549 Err_Vars
.Error_Msg_Name_1
:= Dir_Elem
.Value
;
1550 Err_Vars
.Error_Msg_Name_2
:=
1551 In_Tree
.Projects
.Table
(Pid
).Name
;
1555 "library directory cannot be the same " &
1556 "as source directory { of project {",
1563 end loop Project_Loop
;
1567 Data
.Library_Dir
:= No_Name
;
1568 Data
.Display_Library_Dir
:= No_Name
;
1570 elsif Current_Verbosity
= High
then
1572 -- Display the Library directory in high verbosity
1574 Write_Str
("Library directory =""");
1575 Write_Str
(Get_Name_String
(Data
.Display_Library_Dir
));
1582 pragma Assert
(Lib_Name
.Kind
= Single
);
1584 if Lib_Name
.Value
= Empty_String
then
1585 if Current_Verbosity
= High
1586 and then Data
.Library_Name
= No_Name
1588 Write_Line
("No library name");
1592 -- There is no restriction on the syntax of library names
1594 Data
.Library_Name
:= Lib_Name
.Value
;
1597 if Data
.Library_Name
/= No_Name
1598 and then Current_Verbosity
= High
1600 Write_Str
("Library name = """);
1601 Write_Str
(Get_Name_String
(Data
.Library_Name
));
1606 Data
.Library_Dir
/= No_Name
1608 Data
.Library_Name
/= No_Name
;
1610 if Data
.Library
then
1611 if MLib
.Tgt
.Support_For_Libraries
= MLib
.Tgt
.None
then
1614 "?libraries are not supported on this platform",
1616 Data
.Library
:= False;
1619 if Lib_ALI_Dir
.Value
= Empty_String
then
1620 if Current_Verbosity
= High
then
1621 Write_Line
("No library 'A'L'I directory specified");
1623 Data
.Library_ALI_Dir
:= Data
.Library_Dir
;
1624 Data
.Display_Library_ALI_Dir
:= Data
.Display_Library_Dir
;
1627 -- Find path name, check that it is a directory
1630 (Lib_ALI_Dir
.Value
, Data
.Display_Directory
,
1631 Data
.Library_ALI_Dir
, Data
.Display_Library_ALI_Dir
);
1633 if Data
.Library_ALI_Dir
= No_Name
then
1635 -- Get the absolute name of the library ALI directory that
1636 -- does not exist, to report an error.
1639 Dir_Name
: constant String :=
1640 Get_Name_String
(Lib_ALI_Dir
.Value
);
1643 if Is_Absolute_Path
(Dir_Name
) then
1644 Err_Vars
.Error_Msg_Name_1
:= Lib_Dir
.Value
;
1647 Get_Name_String
(Data
.Display_Directory
);
1649 if Name_Buffer
(Name_Len
) /= Directory_Separator
then
1650 Name_Len
:= Name_Len
+ 1;
1651 Name_Buffer
(Name_Len
) := Directory_Separator
;
1655 (Name_Len
+ 1 .. Name_Len
+ Dir_Name
'Length) :=
1657 Name_Len
:= Name_Len
+ Dir_Name
'Length;
1658 Err_Vars
.Error_Msg_Name_1
:= Name_Find
;
1665 "library 'A'L'I directory { does not exist",
1666 Lib_ALI_Dir
.Location
);
1670 if Data
.Library_ALI_Dir
/= Data
.Library_Dir
then
1672 -- The library ALI directory cannot be the same as the
1673 -- Object directory.
1675 if Data
.Library_ALI_Dir
= Data
.Object_Directory
then
1678 "library 'A'L'I directory cannot be the same " &
1679 "as object directory",
1680 Lib_ALI_Dir
.Location
);
1681 Data
.Library_ALI_Dir
:= No_Name
;
1682 Data
.Display_Library_ALI_Dir
:= No_Name
;
1686 OK
: Boolean := True;
1687 Dirs_Id
: String_List_Id
;
1688 Dir_Elem
: String_Element
;
1691 -- The library ALI directory cannot be the same as
1692 -- a source directory of the current project.
1694 Dirs_Id
:= Data
.Source_Dirs
;
1695 while Dirs_Id
/= Nil_String
loop
1696 Dir_Elem
:= In_Tree
.String_Elements
.Table
(Dirs_Id
);
1697 Dirs_Id
:= Dir_Elem
.Next
;
1699 if Data
.Library_ALI_Dir
= Dir_Elem
.Value
then
1700 Err_Vars
.Error_Msg_Name_1
:= Dir_Elem
.Value
;
1703 "library 'A'L'I directory cannot be " &
1704 "the same as source directory {",
1705 Lib_ALI_Dir
.Location
);
1713 -- The library ALI directory cannot be the same as
1714 -- a source directory of another project either.
1718 Pid
in 1 .. Project_Table
.Last
(In_Tree
.Projects
)
1720 if Pid
/= Project
then
1722 In_Tree
.Projects
.Table
(Pid
).Source_Dirs
;
1725 while Dirs_Id
/= Nil_String
loop
1727 In_Tree
.String_Elements
.Table
(Dirs_Id
);
1728 Dirs_Id
:= Dir_Elem
.Next
;
1731 Data
.Library_ALI_Dir
= Dir_Elem
.Value
1733 Err_Vars
.Error_Msg_Name_1
:=
1735 Err_Vars
.Error_Msg_Name_2
:=
1736 In_Tree
.Projects
.Table
(Pid
).Name
;
1740 "library 'A'L'I directory cannot " &
1741 "be the same as source directory " &
1743 Lib_ALI_Dir
.Location
);
1745 exit ALI_Project_Loop
;
1747 end loop ALI_Dir_Loop
;
1749 end loop ALI_Project_Loop
;
1753 Data
.Library_ALI_Dir
:= No_Name
;
1754 Data
.Display_Library_ALI_Dir
:= No_Name
;
1756 elsif Current_Verbosity
= High
then
1758 -- Display the Library ALI directory in high
1761 Write_Str
("Library ALI directory =""");
1763 (Get_Name_String
(Data
.Display_Library_ALI_Dir
));
1771 pragma Assert
(Lib_Version
.Kind
= Single
);
1773 if Lib_Version
.Value
= Empty_String
then
1774 if Current_Verbosity
= High
then
1775 Write_Line
("No library version specified");
1779 Data
.Lib_Internal_Name
:= Lib_Version
.Value
;
1782 pragma Assert
(The_Lib_Kind
.Kind
= Single
);
1784 if The_Lib_Kind
.Value
= Empty_String
then
1785 if Current_Verbosity
= High
then
1786 Write_Line
("No library kind specified");
1790 Get_Name_String
(The_Lib_Kind
.Value
);
1793 Kind_Name
: constant String :=
1794 To_Lower
(Name_Buffer
(1 .. Name_Len
));
1796 OK
: Boolean := True;
1799 if Kind_Name
= "static" then
1800 Data
.Library_Kind
:= Static
;
1802 elsif Kind_Name
= "dynamic" then
1803 Data
.Library_Kind
:= Dynamic
;
1805 elsif Kind_Name
= "relocatable" then
1806 Data
.Library_Kind
:= Relocatable
;
1811 "illegal value for Library_Kind",
1812 The_Lib_Kind
.Location
);
1816 if Current_Verbosity
= High
and then OK
then
1817 Write_Str
("Library kind = ");
1818 Write_Line
(Kind_Name
);
1821 if Data
.Library_Kind
/= Static
and then
1822 MLib
.Tgt
.Support_For_Libraries
= MLib
.Tgt
.Static_Only
1826 "only static libraries are supported " &
1828 The_Lib_Kind
.Location
);
1829 Data
.Library
:= False;
1834 if Data
.Library
and then Current_Verbosity
= High
then
1835 Write_Line
("This is a library project file");
1840 end Check_Library_Attributes
;
1842 --------------------------
1843 -- Check_Package_Naming --
1844 --------------------------
1846 procedure Check_Package_Naming
1847 (Project
: Project_Id
;
1848 In_Tree
: Project_Tree_Ref
;
1849 Data
: in out Project_Data
)
1851 Naming_Id
: constant Package_Id
:=
1852 Util
.Value_Of
(Name_Naming
, Data
.Decl
.Packages
, In_Tree
);
1854 Naming
: Package_Element
;
1857 -- If there is a package Naming, we will put in Data.Naming
1858 -- what is in this package Naming.
1860 if Naming_Id
/= No_Package
then
1861 Naming
:= In_Tree
.Packages
.Table
(Naming_Id
);
1863 if Current_Verbosity
= High
then
1864 Write_Line
("Checking ""Naming"".");
1867 -- Check Spec_Suffix
1870 Spec_Suffixs
: Array_Element_Id
:=
1876 Suffix
: Array_Element_Id
;
1877 Element
: Array_Element
;
1878 Suffix2
: Array_Element_Id
;
1881 -- If some suffixs have been specified, we make sure that
1882 -- for each language for which a default suffix has been
1883 -- specified, there is a suffix specified, either the one
1884 -- in the project file or if there were none, the default.
1886 if Spec_Suffixs
/= No_Array_Element
then
1887 Suffix
:= Data
.Naming
.Spec_Suffix
;
1889 while Suffix
/= No_Array_Element
loop
1891 In_Tree
.Array_Elements
.Table
(Suffix
);
1892 Suffix2
:= Spec_Suffixs
;
1894 while Suffix2
/= No_Array_Element
loop
1895 exit when In_Tree
.Array_Elements
.Table
1896 (Suffix2
).Index
= Element
.Index
;
1897 Suffix2
:= In_Tree
.Array_Elements
.Table
1901 -- There is a registered default suffix, but no
1902 -- suffix specified in the project file.
1903 -- Add the default to the array.
1905 if Suffix2
= No_Array_Element
then
1906 Array_Element_Table
.Increment_Last
1907 (In_Tree
.Array_Elements
);
1908 In_Tree
.Array_Elements
.Table
1909 (Array_Element_Table
.Last
1910 (In_Tree
.Array_Elements
)) :=
1911 (Index
=> Element
.Index
,
1912 Src_Index
=> Element
.Src_Index
,
1913 Index_Case_Sensitive
=> False,
1914 Value
=> Element
.Value
,
1915 Next
=> Spec_Suffixs
);
1916 Spec_Suffixs
:= Array_Element_Table
.Last
1917 (In_Tree
.Array_Elements
);
1920 Suffix
:= Element
.Next
;
1923 -- Put the resulting array as the specification suffixs
1925 Data
.Naming
.Spec_Suffix
:= Spec_Suffixs
;
1930 Current
: Array_Element_Id
:= Data
.Naming
.Spec_Suffix
;
1931 Element
: Array_Element
;
1934 while Current
/= No_Array_Element
loop
1935 Element
:= In_Tree
.Array_Elements
.Table
(Current
);
1936 Get_Name_String
(Element
.Value
.Value
);
1938 if Name_Len
= 0 then
1941 "Spec_Suffix cannot be empty",
1942 Element
.Value
.Location
);
1945 In_Tree
.Array_Elements
.Table
(Current
) := Element
;
1946 Current
:= Element
.Next
;
1950 -- Check Body_Suffix
1953 Impl_Suffixs
: Array_Element_Id
:=
1959 Suffix
: Array_Element_Id
;
1960 Element
: Array_Element
;
1961 Suffix2
: Array_Element_Id
;
1964 -- If some suffixes have been specified, we make sure that
1965 -- for each language for which a default suffix has been
1966 -- specified, there is a suffix specified, either the one
1967 -- in the project file or if there were noe, the default.
1969 if Impl_Suffixs
/= No_Array_Element
then
1970 Suffix
:= Data
.Naming
.Body_Suffix
;
1972 while Suffix
/= No_Array_Element
loop
1974 In_Tree
.Array_Elements
.Table
(Suffix
);
1975 Suffix2
:= Impl_Suffixs
;
1977 while Suffix2
/= No_Array_Element
loop
1978 exit when In_Tree
.Array_Elements
.Table
1979 (Suffix2
).Index
= Element
.Index
;
1980 Suffix2
:= In_Tree
.Array_Elements
.Table
1984 -- There is a registered default suffix, but no suffix was
1985 -- specified in the project file. Add the default to the
1988 if Suffix2
= No_Array_Element
then
1989 Array_Element_Table
.Increment_Last
1990 (In_Tree
.Array_Elements
);
1991 In_Tree
.Array_Elements
.Table
1992 (Array_Element_Table
.Last
1993 (In_Tree
.Array_Elements
)) :=
1994 (Index
=> Element
.Index
,
1995 Src_Index
=> Element
.Src_Index
,
1996 Index_Case_Sensitive
=> False,
1997 Value
=> Element
.Value
,
1998 Next
=> Impl_Suffixs
);
1999 Impl_Suffixs
:= Array_Element_Table
.Last
2000 (In_Tree
.Array_Elements
);
2003 Suffix
:= Element
.Next
;
2006 -- Put the resulting array as the implementation suffixs
2008 Data
.Naming
.Body_Suffix
:= Impl_Suffixs
;
2013 Current
: Array_Element_Id
:= Data
.Naming
.Body_Suffix
;
2014 Element
: Array_Element
;
2017 while Current
/= No_Array_Element
loop
2018 Element
:= In_Tree
.Array_Elements
.Table
(Current
);
2019 Get_Name_String
(Element
.Value
.Value
);
2021 if Name_Len
= 0 then
2024 "Body_Suffix cannot be empty",
2025 Element
.Value
.Location
);
2028 In_Tree
.Array_Elements
.Table
(Current
) := Element
;
2029 Current
:= Element
.Next
;
2033 -- Get the exceptions, if any
2035 Data
.Naming
.Specification_Exceptions
:=
2037 (Name_Specification_Exceptions
,
2038 In_Arrays
=> Naming
.Decl
.Arrays
,
2039 In_Tree
=> In_Tree
);
2041 Data
.Naming
.Implementation_Exceptions
:=
2043 (Name_Implementation_Exceptions
,
2044 In_Arrays
=> Naming
.Decl
.Arrays
,
2045 In_Tree
=> In_Tree
);
2047 end Check_Package_Naming
;
2049 ---------------------------------
2050 -- Check_Programming_Languages --
2051 ---------------------------------
2053 procedure Check_Programming_Languages
2054 (In_Tree
: Project_Tree_Ref
;
2055 Data
: in out Project_Data
)
2057 Languages
: Variable_Value
:= Nil_Variable_Value
;
2061 Prj
.Util
.Value_Of
(Name_Languages
, Data
.Decl
.Attributes
, In_Tree
);
2062 Data
.Ada_Sources_Present
:= Data
.Source_Dirs
/= Nil_String
;
2063 Data
.Other_Sources_Present
:= Data
.Source_Dirs
/= Nil_String
;
2065 if Data
.Source_Dirs
/= Nil_String
then
2067 -- Check if languages are specified in this project
2069 if Languages
.Default
then
2071 -- Attribute Languages is not specified. So, it defaults to
2072 -- a project of language Ada only.
2074 Data
.Languages
(Ada_Language_Index
) := True;
2076 -- No sources of languages other than Ada
2078 Data
.Other_Sources_Present
:= False;
2082 Current
: String_List_Id
:= Languages
.Values
;
2083 Element
: String_Element
;
2084 Lang_Name
: Name_Id
;
2085 Index
: Language_Index
;
2088 -- Assume that there is no language specified yet
2090 Data
.Other_Sources_Present
:= False;
2091 Data
.Ada_Sources_Present
:= False;
2093 -- Look through all the languages specified in attribute
2094 -- Languages, if any
2096 while Current
/= Nil_String
loop
2098 In_Tree
.String_Elements
.Table
(Current
);
2099 Get_Name_String
(Element
.Value
);
2100 To_Lower
(Name_Buffer
(1 .. Name_Len
));
2101 Lang_Name
:= Name_Find
;
2102 Index
:= Language_Indexes
.Get
(Lang_Name
);
2104 if Index
= No_Language_Index
then
2105 Add_Language_Name
(Lang_Name
);
2106 Index
:= Last_Language_Index
;
2109 Set
(Index
, True, Data
, In_Tree
);
2110 Set
(Language_Processing
=> Default_Language_Processing_Data
,
2111 For_Language
=> Index
,
2113 In_Tree
=> In_Tree
);
2115 if Index
= Ada_Language_Index
then
2116 Data
.Ada_Sources_Present
:= True;
2119 Data
.Other_Sources_Present
:= True;
2122 Current
:= Element
.Next
;
2127 end Check_Programming_Languages
;
2133 function Check_Project
2135 Root_Project
: Project_Id
;
2136 In_Tree
: Project_Tree_Ref
;
2137 Extending
: Boolean) return Boolean
2140 if P
= Root_Project
then
2143 elsif Extending
then
2145 Data
: Project_Data
:= In_Tree
.Projects
.Table
(Root_Project
);
2148 while Data
.Extends
/= No_Project
loop
2149 if P
= Data
.Extends
then
2153 Data
:= In_Tree
.Projects
.Table
(Data
.Extends
);
2161 -------------------------------
2162 -- Check_Stand_Alone_Library --
2163 -------------------------------
2165 procedure Check_Stand_Alone_Library
2166 (Project
: Project_Id
;
2167 In_Tree
: Project_Tree_Ref
;
2168 Data
: in out Project_Data
;
2169 Extending
: Boolean)
2171 Lib_Interfaces
: constant Prj
.Variable_Value
:=
2173 (Snames
.Name_Library_Interface
,
2174 Data
.Decl
.Attributes
,
2177 Lib_Auto_Init
: constant Prj
.Variable_Value
:=
2179 (Snames
.Name_Library_Auto_Init
,
2180 Data
.Decl
.Attributes
,
2183 Lib_Src_Dir
: constant Prj
.Variable_Value
:=
2185 (Snames
.Name_Library_Src_Dir
,
2186 Data
.Decl
.Attributes
,
2189 Lib_Symbol_File
: constant Prj
.Variable_Value
:=
2191 (Snames
.Name_Library_Symbol_File
,
2192 Data
.Decl
.Attributes
,
2195 Lib_Symbol_Policy
: constant Prj
.Variable_Value
:=
2197 (Snames
.Name_Library_Symbol_Policy
,
2198 Data
.Decl
.Attributes
,
2201 Lib_Ref_Symbol_File
: constant Prj
.Variable_Value
:=
2203 (Snames
.Name_Library_Reference_Symbol_File
,
2204 Data
.Decl
.Attributes
,
2207 Auto_Init_Supported
: constant Boolean :=
2209 Standalone_Library_Auto_Init_Is_Supported
;
2211 OK
: Boolean := True;
2214 pragma Assert
(Lib_Interfaces
.Kind
= List
);
2216 -- It is a stand-alone library project file if attribute
2217 -- Library_Interface is defined.
2219 if not Lib_Interfaces
.Default
then
2220 SAL_Library
: declare
2221 Interfaces
: String_List_Id
:= Lib_Interfaces
.Values
;
2222 Interface_ALIs
: String_List_Id
:= Nil_String
;
2224 The_Unit_Id
: Unit_Id
;
2225 The_Unit_Data
: Unit_Data
;
2227 procedure Add_ALI_For
(Source
: Name_Id
);
2228 -- Add an ALI file name to the list of Interface ALIs
2234 procedure Add_ALI_For
(Source
: Name_Id
) is
2236 Get_Name_String
(Source
);
2239 ALI
: constant String :=
2240 ALI_File_Name
(Name_Buffer
(1 .. Name_Len
));
2241 ALI_Name_Id
: Name_Id
;
2243 Name_Len
:= ALI
'Length;
2244 Name_Buffer
(1 .. Name_Len
) := ALI
;
2245 ALI_Name_Id
:= Name_Find
;
2247 String_Element_Table
.Increment_Last
2248 (In_Tree
.String_Elements
);
2249 In_Tree
.String_Elements
.Table
2250 (String_Element_Table
.Last
2251 (In_Tree
.String_Elements
)) :=
2252 (Value
=> ALI_Name_Id
,
2254 Display_Value
=> ALI_Name_Id
,
2256 In_Tree
.String_Elements
.Table
2257 (Interfaces
).Location
,
2259 Next
=> Interface_ALIs
);
2260 Interface_ALIs
:= String_Element_Table
.Last
2261 (In_Tree
.String_Elements
);
2265 -- Start of processing for SAL_Library
2268 Data
.Standalone_Library
:= True;
2270 -- Library_Interface cannot be an empty list
2272 if Interfaces
= Nil_String
then
2275 "Library_Interface cannot be an empty list",
2276 Lib_Interfaces
.Location
);
2279 -- Process each unit name specified in the attribute
2280 -- Library_Interface.
2282 while Interfaces
/= Nil_String
loop
2284 (In_Tree
.String_Elements
.Table
2285 (Interfaces
).Value
);
2286 To_Lower
(Name_Buffer
(1 .. Name_Len
));
2288 if Name_Len
= 0 then
2291 "an interface cannot be an empty string",
2292 In_Tree
.String_Elements
.Table
2293 (Interfaces
).Location
);
2297 Error_Msg_Name_1
:= Unit
;
2299 Units_Htable
.Get
(In_Tree
.Units_HT
, Unit
);
2301 if The_Unit_Id
= No_Unit
then
2305 In_Tree
.String_Elements
.Table
2306 (Interfaces
).Location
);
2309 -- Check that the unit is part of the project
2312 In_Tree
.Units
.Table
(The_Unit_Id
);
2314 if The_Unit_Data
.File_Names
(Body_Part
).Name
/= No_Name
2315 and then The_Unit_Data
.File_Names
(Body_Part
).Path
/=
2319 (The_Unit_Data
.File_Names
(Body_Part
).Project
,
2320 Project
, In_Tree
, Extending
)
2322 -- There is a body for this unit.
2323 -- If there is no spec, we need to check
2324 -- that it is not a subunit.
2326 if The_Unit_Data
.File_Names
2327 (Specification
).Name
= No_Name
2330 Src_Ind
: Source_File_Index
;
2333 Src_Ind
:= Sinput
.P
.Load_Project_File
2335 (The_Unit_Data
.File_Names
2338 if Sinput
.P
.Source_File_Is_Subunit
2343 "{ is a subunit; " &
2344 "it cannot be an interface",
2346 String_Elements
.Table
2347 (Interfaces
).Location
);
2352 -- The unit is not a subunit, so we add
2353 -- to the Interface ALIs the ALI file
2354 -- corresponding to the body.
2357 (The_Unit_Data
.File_Names
(Body_Part
).Name
);
2362 "{ is not an unit of this project",
2363 In_Tree
.String_Elements
.Table
2364 (Interfaces
).Location
);
2367 elsif The_Unit_Data
.File_Names
2368 (Specification
).Name
/= No_Name
2369 and then The_Unit_Data
.File_Names
2370 (Specification
).Path
/= Slash
2371 and then Check_Project
2372 (The_Unit_Data
.File_Names
2373 (Specification
).Project
,
2374 Project
, In_Tree
, Extending
)
2377 -- The unit is part of the project, it has
2378 -- a spec, but no body. We add to the Interface
2379 -- ALIs the ALI file corresponding to the spec.
2382 (The_Unit_Data
.File_Names
(Specification
).Name
);
2387 "{ is not an unit of this project",
2388 In_Tree
.String_Elements
.Table
2389 (Interfaces
).Location
);
2396 In_Tree
.String_Elements
.Table
(Interfaces
).Next
;
2399 -- Put the list of Interface ALIs in the project data
2401 Data
.Lib_Interface_ALIs
:= Interface_ALIs
;
2403 -- Check value of attribute Library_Auto_Init and set
2404 -- Lib_Auto_Init accordingly.
2406 if Lib_Auto_Init
.Default
then
2408 -- If no attribute Library_Auto_Init is declared, then
2409 -- set auto init only if it is supported.
2411 Data
.Lib_Auto_Init
:= Auto_Init_Supported
;
2414 Get_Name_String
(Lib_Auto_Init
.Value
);
2415 To_Lower
(Name_Buffer
(1 .. Name_Len
));
2417 if Name_Buffer
(1 .. Name_Len
) = "false" then
2418 Data
.Lib_Auto_Init
:= False;
2420 elsif Name_Buffer
(1 .. Name_Len
) = "true" then
2421 if Auto_Init_Supported
then
2422 Data
.Lib_Auto_Init
:= True;
2425 -- Library_Auto_Init cannot be "true" if auto init
2430 "library auto init not supported " &
2432 Lib_Auto_Init
.Location
);
2438 "invalid value for attribute Library_Auto_Init",
2439 Lib_Auto_Init
.Location
);
2444 -- If attribute Library_Src_Dir is defined and not the
2445 -- empty string, check if the directory exist and is not
2446 -- the object directory or one of the source directories.
2447 -- This is the directory where copies of the interface
2448 -- sources will be copied. Note that this directory may be
2449 -- the library directory.
2451 if Lib_Src_Dir
.Value
/= Empty_String
then
2453 Dir_Id
: constant Name_Id
:= Lib_Src_Dir
.Value
;
2457 (Dir_Id
, Data
.Display_Directory
,
2458 Data
.Library_Src_Dir
,
2459 Data
.Display_Library_Src_Dir
);
2461 -- If directory does not exist, report an error
2463 if Data
.Library_Src_Dir
= No_Name
then
2465 -- Get the absolute name of the library directory
2466 -- that does not exist, to report an error.
2469 Dir_Name
: constant String :=
2470 Get_Name_String
(Dir_Id
);
2473 if Is_Absolute_Path
(Dir_Name
) then
2474 Err_Vars
.Error_Msg_Name_1
:= Dir_Id
;
2477 Get_Name_String
(Data
.Directory
);
2479 if Name_Buffer
(Name_Len
) /=
2482 Name_Len
:= Name_Len
+ 1;
2483 Name_Buffer
(Name_Len
) :=
2484 Directory_Separator
;
2489 Name_Len
+ Dir_Name
'Length) :=
2491 Name_Len
:= Name_Len
+ Dir_Name
'Length;
2492 Err_Vars
.Error_Msg_Name_1
:= Name_Find
;
2499 "Directory { does not exist",
2500 Lib_Src_Dir
.Location
);
2503 -- Report an error if it is the same as the object
2506 elsif Data
.Library_Src_Dir
= Data
.Object_Directory
then
2509 "directory to copy interfaces cannot be " &
2510 "the object directory",
2511 Lib_Src_Dir
.Location
);
2512 Data
.Library_Src_Dir
:= No_Name
;
2516 Src_Dirs
: String_List_Id
;
2517 Src_Dir
: String_Element
;
2520 -- Interface copy directory cannot be one of the source
2521 -- directory of the current project.
2523 Src_Dirs
:= Data
.Source_Dirs
;
2524 while Src_Dirs
/= Nil_String
loop
2525 Src_Dir
:= In_Tree
.String_Elements
.Table
2528 -- Report error if it is one of the source directories
2530 if Data
.Library_Src_Dir
= Src_Dir
.Value
then
2533 "directory to copy interfaces cannot " &
2534 "be one of the source directories",
2535 Lib_Src_Dir
.Location
);
2536 Data
.Library_Src_Dir
:= No_Name
;
2540 Src_Dirs
:= Src_Dir
.Next
;
2543 if Data
.Library_Src_Dir
/= No_Name
then
2545 -- It cannot be a source directory of any other
2548 Project_Loop
: for Pid
in 1 ..
2549 Project_Table
.Last
(In_Tree
.Projects
)
2552 In_Tree
.Projects
.Table
(Pid
).Source_Dirs
;
2553 Dir_Loop
: while Src_Dirs
/= Nil_String
loop
2555 In_Tree
.String_Elements
.Table
(Src_Dirs
);
2557 -- Report error if it is one of the source
2560 if Data
.Library_Src_Dir
= Src_Dir
.Value
then
2561 Error_Msg_Name_1
:= Src_Dir
.Value
;
2563 In_Tree
.Projects
.Table
(Pid
).Name
;
2566 "directory to copy interfaces cannot " &
2567 "be the same as source directory { of " &
2569 Lib_Src_Dir
.Location
);
2570 Data
.Library_Src_Dir
:= No_Name
;
2574 Src_Dirs
:= Src_Dir
.Next
;
2576 end loop Project_Loop
;
2580 -- In high verbosity, if there is a valid Library_Src_Dir,
2581 -- display its path name.
2583 if Data
.Library_Src_Dir
/= No_Name
2584 and then Current_Verbosity
= High
2586 Write_Str
("Directory to copy interfaces =""");
2587 Write_Str
(Get_Name_String
(Data
.Library_Src_Dir
));
2594 -- Check the symbol related attributes
2596 -- First, the symbol policy
2598 if not Lib_Symbol_Policy
.Default
then
2600 Value
: constant String :=
2602 (Get_Name_String
(Lib_Symbol_Policy
.Value
));
2605 -- Symbol policy must hove one of a limited number of values
2607 if Value
= "autonomous" or else Value
= "default" then
2608 Data
.Symbol_Data
.Symbol_Policy
:= Autonomous
;
2610 elsif Value
= "compliant" then
2611 Data
.Symbol_Data
.Symbol_Policy
:= Compliant
;
2613 elsif Value
= "controlled" then
2614 Data
.Symbol_Data
.Symbol_Policy
:= Controlled
;
2616 elsif Value
= "restricted" then
2617 Data
.Symbol_Data
.Symbol_Policy
:= Restricted
;
2622 "illegal value for Library_Symbol_Policy",
2623 Lib_Symbol_Policy
.Location
);
2628 -- If attribute Library_Symbol_File is not specified, symbol policy
2629 -- cannot be Restricted.
2631 if Lib_Symbol_File
.Default
then
2632 if Data
.Symbol_Data
.Symbol_Policy
= Restricted
then
2635 "Library_Symbol_File needs to be defined when " &
2636 "symbol policy is Restricted",
2637 Lib_Symbol_Policy
.Location
);
2641 -- Library_Symbol_File is defined. Check that the file exists
2643 Data
.Symbol_Data
.Symbol_File
:= Lib_Symbol_File
.Value
;
2645 Get_Name_String
(Lib_Symbol_File
.Value
);
2647 if Name_Len
= 0 then
2650 "symbol file name cannot be an empty string",
2651 Lib_Symbol_File
.Location
);
2654 OK
:= not Is_Absolute_Path
(Name_Buffer
(1 .. Name_Len
));
2657 for J
in 1 .. Name_Len
loop
2658 if Name_Buffer
(J
) = '/'
2659 or else Name_Buffer
(J
) = Directory_Separator
2668 Error_Msg_Name_1
:= Lib_Symbol_File
.Value
;
2671 "symbol file name { is illegal. " &
2672 "Name canot include directory info.",
2673 Lib_Symbol_File
.Location
);
2678 -- If attribute Library_Reference_Symbol_File is not defined,
2679 -- symbol policy cannot be Compilant or Controlled.
2681 if Lib_Ref_Symbol_File
.Default
then
2682 if Data
.Symbol_Data
.Symbol_Policy
= Compliant
2683 or else Data
.Symbol_Data
.Symbol_Policy
= Controlled
2687 "a reference symbol file need to be defined",
2688 Lib_Symbol_Policy
.Location
);
2692 -- Library_Reference_Symbol_File is defined, check file exists
2694 Data
.Symbol_Data
.Reference
:= Lib_Ref_Symbol_File
.Value
;
2696 Get_Name_String
(Lib_Ref_Symbol_File
.Value
);
2698 if Name_Len
= 0 then
2701 "reference symbol file name cannot be an empty string",
2702 Lib_Symbol_File
.Location
);
2705 OK
:= not Is_Absolute_Path
(Name_Buffer
(1 .. Name_Len
));
2708 for J
in 1 .. Name_Len
loop
2709 if Name_Buffer
(J
) = '/'
2710 or else Name_Buffer
(J
) = Directory_Separator
2719 Error_Msg_Name_1
:= Lib_Ref_Symbol_File
.Value
;
2722 "reference symbol file { name is illegal. " &
2723 "Name canot include directory info.",
2724 Lib_Ref_Symbol_File
.Location
);
2727 if not Is_Regular_File
2728 (Get_Name_String
(Data
.Object_Directory
) &
2729 Directory_Separator
&
2730 Get_Name_String
(Lib_Ref_Symbol_File
.Value
))
2732 Error_Msg_Name_1
:= Lib_Ref_Symbol_File
.Value
;
2734 -- For controlled symbol policy, it is an error if the
2735 -- reference symbol file does not exist. For other symbol
2736 -- policies, this is just a warning
2739 Data
.Symbol_Data
.Symbol_Policy
/= Controlled
;
2743 "<library reference symbol file { does not exist",
2744 Lib_Ref_Symbol_File
.Location
);
2746 -- In addition in the non-controlled case, if symbol policy
2747 -- is Compliant, it is changed to Autonomous, because there
2748 -- is no reference to check against, and we don't want to
2749 -- fail in this case.
2751 if Data
.Symbol_Data
.Symbol_Policy
/= Controlled
then
2752 if Data
.Symbol_Data
.Symbol_Policy
= Compliant
then
2753 Data
.Symbol_Data
.Symbol_Policy
:= Autonomous
;
2760 end Check_Stand_Alone_Library
;
2762 ----------------------------
2763 -- Compute_Directory_Last --
2764 ----------------------------
2766 function Compute_Directory_Last
(Dir
: String) return Natural is
2769 and then (Dir
(Dir
'Last - 1) = Directory_Separator
2770 or else Dir
(Dir
'Last - 1) = '/')
2772 return Dir
'Last - 1;
2776 end Compute_Directory_Last
;
2778 --------------------
2779 -- Body_Suffix_Of --
2780 --------------------
2782 function Body_Suffix_Of
2783 (Language
: Language_Index
;
2784 In_Project
: Project_Data
;
2785 In_Tree
: Project_Tree_Ref
) return String
2787 Suffix_Id
: constant Name_Id
:=
2788 Suffix_Of
(Language
, In_Project
, In_Tree
);
2790 if Suffix_Id
/= No_Name
then
2791 return Get_Name_String
(Suffix_Id
);
2793 return "." & Get_Name_String
(Language_Names
.Table
(Language
));
2802 (Project
: Project_Id
;
2803 In_Tree
: Project_Tree_Ref
;
2805 Flag_Location
: Source_Ptr
)
2807 Real_Location
: Source_Ptr
:= Flag_Location
;
2808 Error_Buffer
: String (1 .. 5_000
);
2809 Error_Last
: Natural := 0;
2810 Msg_Name
: Natural := 0;
2811 First
: Positive := Msg
'First;
2813 procedure Add
(C
: Character);
2814 -- Add a character to the buffer
2816 procedure Add
(S
: String);
2817 -- Add a string to the buffer
2819 procedure Add
(Id
: Name_Id
);
2820 -- Add a name to the buffer
2826 procedure Add
(C
: Character) is
2828 Error_Last
:= Error_Last
+ 1;
2829 Error_Buffer
(Error_Last
) := C
;
2832 procedure Add
(S
: String) is
2834 Error_Buffer
(Error_Last
+ 1 .. Error_Last
+ S
'Length) := S
;
2835 Error_Last
:= Error_Last
+ S
'Length;
2838 procedure Add
(Id
: Name_Id
) is
2840 Get_Name_String
(Id
);
2841 Add
(Name_Buffer
(1 .. Name_Len
));
2844 -- Start of processing for Error_Msg
2847 -- If location of error is unknown, use the location of the project
2849 if Real_Location
= No_Location
then
2850 Real_Location
:= In_Tree
.Projects
.Table
(Project
).Location
;
2853 if Error_Report
= null then
2854 Prj
.Err
.Error_Msg
(Msg
, Real_Location
);
2858 -- Ignore continuation character
2860 if Msg
(First
) = '\' then
2863 -- Warniung character is always the first one in this package
2864 -- this is an undoocumented kludge!!!
2866 elsif Msg
(First
) = '?' then
2870 elsif Msg
(First
) = '<' then
2873 if Err_Vars
.Error_Msg_Warn
then
2878 for Index
in First
.. Msg
'Last loop
2879 if Msg
(Index
) = '{' or else Msg
(Index
) = '%' then
2881 -- Include a name between double quotes
2883 Msg_Name
:= Msg_Name
+ 1;
2887 when 1 => Add
(Err_Vars
.Error_Msg_Name_1
);
2888 when 2 => Add
(Err_Vars
.Error_Msg_Name_2
);
2889 when 3 => Add
(Err_Vars
.Error_Msg_Name_3
);
2891 when others => null;
2902 Error_Report
(Error_Buffer
(1 .. Error_Last
), Project
, In_Tree
);
2909 procedure Find_Sources
2910 (Project
: Project_Id
;
2911 In_Tree
: Project_Tree_Ref
;
2912 Data
: in out Project_Data
;
2913 For_Language
: Language_Index
;
2914 Follow_Links
: Boolean := False)
2916 Source_Dir
: String_List_Id
:= Data
.Source_Dirs
;
2917 Element
: String_Element
;
2919 Current_Source
: String_List_Id
:= Nil_String
;
2920 Source_Recorded
: Boolean := False;
2923 if Current_Verbosity
= High
then
2924 Write_Line
("Looking for sources:");
2927 -- For each subdirectory
2929 while Source_Dir
/= Nil_String
loop
2931 Source_Recorded
:= False;
2932 Element
:= In_Tree
.String_Elements
.Table
(Source_Dir
);
2933 if Element
.Value
/= No_Name
then
2934 Get_Name_String
(Element
.Display_Value
);
2937 Source_Directory
: constant String :=
2938 Name_Buffer
(1 .. Name_Len
) & Directory_Separator
;
2939 Dir_Last
: constant Natural :=
2940 Compute_Directory_Last
(Source_Directory
);
2943 if Current_Verbosity
= High
then
2944 Write_Str
("Source_Dir = ");
2945 Write_Line
(Source_Directory
);
2948 -- We look to every entry in the source directory
2950 Open
(Dir
, Source_Directory
2951 (Source_Directory
'First .. Dir_Last
));
2954 Read
(Dir
, Name_Buffer
, Name_Len
);
2956 if Current_Verbosity
= High
then
2957 Write_Str
(" Checking ");
2958 Write_Line
(Name_Buffer
(1 .. Name_Len
));
2961 exit when Name_Len
= 0;
2964 File_Name
: constant Name_Id
:= Name_Find
;
2965 Path
: constant String :=
2967 (Name
=> Name_Buffer
(1 .. Name_Len
),
2968 Directory
=> Source_Directory
2969 (Source_Directory
'First .. Dir_Last
),
2970 Resolve_Links
=> Follow_Links
,
2971 Case_Sensitive
=> True);
2972 Path_Name
: Name_Id
;
2975 Name_Len
:= Path
'Length;
2976 Name_Buffer
(1 .. Name_Len
) := Path
;
2977 Path_Name
:= Name_Find
;
2979 if For_Language
= Ada_Language_Index
then
2981 -- We attempt to register it as a source. However,
2982 -- there is no error if the file does not contain
2983 -- a valid source. But there is an error if we have
2984 -- a duplicate unit name.
2987 (File_Name
=> File_Name
,
2988 Path_Name
=> Path_Name
,
2992 Location
=> No_Location
,
2993 Current_Source
=> Current_Source
,
2994 Source_Recorded
=> Source_Recorded
,
2995 Follow_Links
=> Follow_Links
);
2999 (File_Name
=> File_Name
,
3000 Path_Name
=> Path_Name
,
3004 Location
=> No_Location
,
3005 Language
=> For_Language
,
3007 Body_Suffix_Of
(For_Language
, Data
, In_Tree
),
3008 Naming_Exception
=> False);
3018 when Directory_Error
=>
3022 if Source_Recorded
then
3023 In_Tree
.String_Elements
.Table
(Source_Dir
).Flag
:=
3027 Source_Dir
:= Element
.Next
;
3030 if Current_Verbosity
= High
then
3031 Write_Line
("end Looking for sources.");
3034 if For_Language
= Ada_Language_Index
then
3036 -- If we have looked for sources and found none, then
3037 -- it is an error, except if it is an extending project.
3038 -- If a non extending project is not supposed to contain
3039 -- any source, then we never call Find_Sources.
3041 if Current_Source
/= Nil_String
then
3042 Data
.Ada_Sources_Present
:= True;
3044 elsif Data
.Extends
= No_Project
then
3045 Report_No_Ada_Sources
(Project
, In_Tree
, Data
.Location
);
3050 --------------------------------
3051 -- Free_Ada_Naming_Exceptions --
3052 --------------------------------
3054 procedure Free_Ada_Naming_Exceptions
is
3056 Ada_Naming_Exception_Table
.Set_Last
(0);
3057 Ada_Naming_Exceptions
.Reset
;
3058 Reverse_Ada_Naming_Exceptions
.Reset
;
3059 end Free_Ada_Naming_Exceptions
;
3061 ---------------------
3062 -- Get_Directories --
3063 ---------------------
3065 procedure Get_Directories
3066 (Project
: Project_Id
;
3067 In_Tree
: Project_Tree_Ref
;
3068 Data
: in out Project_Data
)
3070 Object_Dir
: constant Variable_Value
:=
3072 (Name_Object_Dir
, Data
.Decl
.Attributes
, In_Tree
);
3074 Exec_Dir
: constant Variable_Value
:=
3076 (Name_Exec_Dir
, Data
.Decl
.Attributes
, In_Tree
);
3078 Source_Dirs
: constant Variable_Value
:=
3080 (Name_Source_Dirs
, Data
.Decl
.Attributes
, In_Tree
);
3082 Last_Source_Dir
: String_List_Id
:= Nil_String
;
3084 procedure Find_Source_Dirs
(From
: Name_Id
; Location
: Source_Ptr
);
3085 -- Find one or several source directories, and add them
3086 -- to the list of source directories of the project.
3088 ----------------------
3089 -- Find_Source_Dirs --
3090 ----------------------
3092 procedure Find_Source_Dirs
(From
: Name_Id
; Location
: Source_Ptr
) is
3093 Directory
: constant String := Get_Name_String
(From
);
3094 Element
: String_Element
;
3096 procedure Recursive_Find_Dirs
(Path
: Name_Id
);
3097 -- Find all the subdirectories (recursively) of Path and add them
3098 -- to the list of source directories of the project.
3100 -------------------------
3101 -- Recursive_Find_Dirs --
3102 -------------------------
3104 procedure Recursive_Find_Dirs
(Path
: Name_Id
) is
3106 Name
: String (1 .. 250);
3108 List
: String_List_Id
:= Data
.Source_Dirs
;
3109 Element
: String_Element
;
3110 Found
: Boolean := False;
3112 Non_Canonical_Path
: Name_Id
:= No_Name
;
3113 Canonical_Path
: Name_Id
:= No_Name
;
3115 The_Path
: constant String :=
3116 Normalize_Pathname
(Get_Name_String
(Path
)) &
3117 Directory_Separator
;
3119 The_Path_Last
: constant Natural :=
3120 Compute_Directory_Last
(The_Path
);
3123 Name_Len
:= The_Path_Last
- The_Path
'First + 1;
3124 Name_Buffer
(1 .. Name_Len
) :=
3125 The_Path
(The_Path
'First .. The_Path_Last
);
3126 Non_Canonical_Path
:= Name_Find
;
3127 Get_Name_String
(Non_Canonical_Path
);
3128 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
3129 Canonical_Path
:= Name_Find
;
3131 -- To avoid processing the same directory several times, check
3132 -- if the directory is already in Recursive_Dirs. If it is,
3133 -- then there is nothing to do, just return. If it is not, put
3134 -- it there and continue recursive processing.
3136 if Recursive_Dirs
.Get
(Canonical_Path
) then
3140 Recursive_Dirs
.Set
(Canonical_Path
, True);
3143 -- Check if directory is already in list
3145 while List
/= Nil_String
loop
3146 Element
:= In_Tree
.String_Elements
.Table
(List
);
3148 if Element
.Value
/= No_Name
then
3149 Found
:= Element
.Value
= Canonical_Path
;
3153 List
:= Element
.Next
;
3156 -- If directory is not already in list, put it there
3159 if Current_Verbosity
= High
then
3161 Write_Line
(The_Path
(The_Path
'First .. The_Path_Last
));
3164 String_Element_Table
.Increment_Last
3165 (In_Tree
.String_Elements
);
3167 (Value
=> Canonical_Path
,
3168 Display_Value
=> Non_Canonical_Path
,
3169 Location
=> No_Location
,
3174 -- Case of first source directory
3176 if Last_Source_Dir
= Nil_String
then
3177 Data
.Source_Dirs
:= String_Element_Table
.Last
3178 (In_Tree
.String_Elements
);
3180 -- Here we already have source directories
3183 -- Link the previous last to the new one
3185 In_Tree
.String_Elements
.Table
3186 (Last_Source_Dir
).Next
:=
3187 String_Element_Table
.Last
3188 (In_Tree
.String_Elements
);
3191 -- And register this source directory as the new last
3193 Last_Source_Dir
:= String_Element_Table
.Last
3194 (In_Tree
.String_Elements
);
3195 In_Tree
.String_Elements
.Table
(Last_Source_Dir
) :=
3199 -- Now look for subdirectories. We do that even when this
3200 -- directory is already in the list, because some of its
3201 -- subdirectories may not be in the list yet.
3203 Open
(Dir
, The_Path
(The_Path
'First .. The_Path_Last
));
3206 Read
(Dir
, Name
, Last
);
3209 if Name
(1 .. Last
) /= "."
3210 and then Name
(1 .. Last
) /= ".."
3212 -- Avoid . and .. directories
3214 if Current_Verbosity
= High
then
3215 Write_Str
(" Checking ");
3216 Write_Line
(Name
(1 .. Last
));
3220 Path_Name
: constant String :=
3222 (Name
=> Name
(1 .. Last
),
3225 (The_Path
'First .. The_Path_Last
),
3226 Resolve_Links
=> False,
3227 Case_Sensitive
=> True);
3230 if Is_Directory
(Path_Name
) then
3232 -- We have found a new subdirectory, call self
3234 Name_Len
:= Path_Name
'Length;
3235 Name_Buffer
(1 .. Name_Len
) := Path_Name
;
3236 Recursive_Find_Dirs
(Name_Find
);
3245 when Directory_Error
=>
3247 end Recursive_Find_Dirs
;
3249 -- Start of processing for Find_Source_Dirs
3252 if Current_Verbosity
= High
then
3253 Write_Str
("Find_Source_Dirs (""");
3254 Write_Str
(Directory
);
3258 -- First, check if we are looking for a directory tree,
3259 -- indicated by "/**" at the end.
3261 if Directory
'Length >= 3
3262 and then Directory
(Directory
'Last - 1 .. Directory
'Last) = "**"
3263 and then (Directory
(Directory
'Last - 2) = '/'
3265 Directory
(Directory
'Last - 2) = Directory_Separator
)
3267 Data
.Known_Order_Of_Source_Dirs
:= False;
3269 Name_Len
:= Directory
'Length - 3;
3271 if Name_Len
= 0 then
3273 -- This is the case of "/**": all directories
3274 -- in the file system.
3277 Name_Buffer
(1) := Directory
(Directory
'First);
3280 Name_Buffer
(1 .. Name_Len
) :=
3281 Directory
(Directory
'First .. Directory
'Last - 3);
3284 if Current_Verbosity
= High
then
3285 Write_Str
("Looking for all subdirectories of """);
3286 Write_Str
(Name_Buffer
(1 .. Name_Len
));
3291 Base_Dir
: constant Name_Id
:= Name_Find
;
3292 Root_Dir
: constant String :=
3294 (Name
=> Get_Name_String
(Base_Dir
),
3296 Get_Name_String
(Data
.Display_Directory
),
3297 Resolve_Links
=> False,
3298 Case_Sensitive
=> True);
3301 if Root_Dir
'Length = 0 then
3302 Err_Vars
.Error_Msg_Name_1
:= Base_Dir
;
3304 if Location
= No_Location
then
3307 "{ is not a valid directory.",
3312 "{ is not a valid directory.",
3317 -- We have an existing directory, we register it and all
3318 -- of its subdirectories.
3320 if Current_Verbosity
= High
then
3321 Write_Line
("Looking for source directories:");
3324 Name_Len
:= Root_Dir
'Length;
3325 Name_Buffer
(1 .. Name_Len
) := Root_Dir
;
3326 Recursive_Find_Dirs
(Name_Find
);
3328 if Current_Verbosity
= High
then
3329 Write_Line
("End of looking for source directories.");
3334 -- We have a single directory
3338 Path_Name
: Name_Id
;
3339 Display_Path_Name
: Name_Id
;
3343 (From
, Data
.Display_Directory
, Path_Name
, Display_Path_Name
);
3345 if Path_Name
= No_Name
then
3346 Err_Vars
.Error_Msg_Name_1
:= From
;
3348 if Location
= No_Location
then
3351 "{ is not a valid directory",
3356 "{ is not a valid directory",
3361 -- As it is an existing directory, we add it to
3362 -- the list of directories.
3364 String_Element_Table
.Increment_Last
3365 (In_Tree
.String_Elements
);
3366 Element
.Value
:= Path_Name
;
3367 Element
.Display_Value
:= Display_Path_Name
;
3369 if Last_Source_Dir
= Nil_String
then
3371 -- This is the first source directory
3373 Data
.Source_Dirs
:= String_Element_Table
.Last
3374 (In_Tree
.String_Elements
);
3377 -- We already have source directories,
3378 -- link the previous last to the new one.
3380 In_Tree
.String_Elements
.Table
3381 (Last_Source_Dir
).Next
:=
3382 String_Element_Table
.Last
3383 (In_Tree
.String_Elements
);
3386 -- And register this source directory as the new last
3388 Last_Source_Dir
:= String_Element_Table
.Last
3389 (In_Tree
.String_Elements
);
3390 In_Tree
.String_Elements
.Table
3391 (Last_Source_Dir
) := Element
;
3395 end Find_Source_Dirs
;
3397 -- Start of processing for Get_Directories
3400 if Current_Verbosity
= High
then
3401 Write_Line
("Starting to look for directories");
3404 -- Check the object directory
3406 pragma Assert
(Object_Dir
.Kind
= Single
,
3407 "Object_Dir is not a single string");
3409 -- We set the object directory to its default
3411 Data
.Object_Directory
:= Data
.Directory
;
3412 Data
.Display_Object_Dir
:= Data
.Display_Directory
;
3414 if Object_Dir
.Value
/= Empty_String
then
3415 Get_Name_String
(Object_Dir
.Value
);
3417 if Name_Len
= 0 then
3420 "Object_Dir cannot be empty",
3421 Object_Dir
.Location
);
3424 -- We check that the specified object directory does exist
3427 (Object_Dir
.Value
, Data
.Display_Directory
,
3428 Data
.Object_Directory
, Data
.Display_Object_Dir
);
3430 if Data
.Object_Directory
= No_Name
then
3432 -- The object directory does not exist, report an error
3434 Err_Vars
.Error_Msg_Name_1
:= Object_Dir
.Value
;
3437 "the object directory { cannot be found",
3440 -- Do not keep a nil Object_Directory. Set it to the specified
3441 -- (relative or absolute) path. This is for the benefit of
3442 -- tools that recover from errors; for example, these tools
3443 -- could create the non existent directory.
3445 Data
.Display_Object_Dir
:= Object_Dir
.Value
;
3446 Get_Name_String
(Object_Dir
.Value
);
3447 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
3448 Data
.Object_Directory
:= Name_Find
;
3453 if Current_Verbosity
= High
then
3454 if Data
.Object_Directory
= No_Name
then
3455 Write_Line
("No object directory");
3457 Write_Str
("Object directory: """);
3458 Write_Str
(Get_Name_String
(Data
.Display_Object_Dir
));
3463 -- Check the exec directory
3465 pragma Assert
(Exec_Dir
.Kind
= Single
,
3466 "Exec_Dir is not a single string");
3468 -- We set the object directory to its default
3470 Data
.Exec_Directory
:= Data
.Object_Directory
;
3471 Data
.Display_Exec_Dir
:= Data
.Display_Object_Dir
;
3473 if Exec_Dir
.Value
/= Empty_String
then
3474 Get_Name_String
(Exec_Dir
.Value
);
3476 if Name_Len
= 0 then
3479 "Exec_Dir cannot be empty",
3483 -- We check that the specified object directory
3487 (Exec_Dir
.Value
, Data
.Directory
,
3488 Data
.Exec_Directory
, Data
.Display_Exec_Dir
);
3490 if Data
.Exec_Directory
= No_Name
then
3491 Err_Vars
.Error_Msg_Name_1
:= Exec_Dir
.Value
;
3494 "the exec directory { cannot be found",
3500 if Current_Verbosity
= High
then
3501 if Data
.Exec_Directory
= No_Name
then
3502 Write_Line
("No exec directory");
3504 Write_Str
("Exec directory: """);
3505 Write_Str
(Get_Name_String
(Data
.Display_Exec_Dir
));
3510 -- Look for the source directories
3512 if Current_Verbosity
= High
then
3513 Write_Line
("Starting to look for source directories");
3516 pragma Assert
(Source_Dirs
.Kind
= List
, "Source_Dirs is not a list");
3518 if Source_Dirs
.Default
then
3520 -- No Source_Dirs specified: the single source directory
3521 -- is the one containing the project file
3523 String_Element_Table
.Increment_Last
3524 (In_Tree
.String_Elements
);
3525 Data
.Source_Dirs
:= String_Element_Table
.Last
3526 (In_Tree
.String_Elements
);
3527 In_Tree
.String_Elements
.Table
(Data
.Source_Dirs
) :=
3528 (Value
=> Data
.Directory
,
3529 Display_Value
=> Data
.Display_Directory
,
3530 Location
=> No_Location
,
3535 if Current_Verbosity
= High
then
3536 Write_Line
("Single source directory:");
3538 Write_Str
(Get_Name_String
(Data
.Display_Directory
));
3542 elsif Source_Dirs
.Values
= Nil_String
then
3544 -- If Source_Dirs is an empty string list, this means
3545 -- that this project contains no source. For projects that
3546 -- don't extend other projects, this also means that there is no
3547 -- need for an object directory, if not specified.
3549 if Data
.Extends
= No_Project
3550 and then Data
.Object_Directory
= Data
.Directory
3552 Data
.Object_Directory
:= No_Name
;
3555 Data
.Source_Dirs
:= Nil_String
;
3556 Data
.Ada_Sources_Present
:= False;
3557 Data
.Other_Sources_Present
:= False;
3561 Source_Dir
: String_List_Id
:= Source_Dirs
.Values
;
3562 Element
: String_Element
;
3565 -- We will find the source directories for each
3566 -- element of the list
3568 while Source_Dir
/= Nil_String
loop
3570 In_Tree
.String_Elements
.Table
(Source_Dir
);
3571 Find_Source_Dirs
(Element
.Value
, Element
.Location
);
3572 Source_Dir
:= Element
.Next
;
3577 if Current_Verbosity
= High
then
3578 Write_Line
("Putting source directories in canonical cases");
3582 Current
: String_List_Id
:= Data
.Source_Dirs
;
3583 Element
: String_Element
;
3586 while Current
/= Nil_String
loop
3587 Element
:= In_Tree
.String_Elements
.Table
(Current
);
3588 if Element
.Value
/= No_Name
then
3589 Get_Name_String
(Element
.Value
);
3590 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
3591 Element
.Value
:= Name_Find
;
3592 In_Tree
.String_Elements
.Table
(Current
) := Element
;
3595 Current
:= Element
.Next
;
3599 end Get_Directories
;
3606 (Project
: Project_Id
;
3607 In_Tree
: Project_Tree_Ref
;
3608 Data
: in out Project_Data
) is
3609 Mains
: constant Variable_Value
:=
3610 Prj
.Util
.Value_Of
(Name_Main
, Data
.Decl
.Attributes
, In_Tree
);
3613 Data
.Mains
:= Mains
.Values
;
3615 -- If no Mains were specified, and if we are an extending
3616 -- project, inherit the Mains from the project we are extending.
3618 if Mains
.Default
then
3619 if Data
.Extends
/= No_Project
then
3621 In_Tree
.Projects
.Table
(Data
.Extends
).Mains
;
3624 -- In a library project file, Main cannot be specified
3626 elsif Data
.Library
then
3629 "a library project file cannot have Main specified",
3634 ---------------------------
3635 -- Get_Sources_From_File --
3636 ---------------------------
3638 procedure Get_Sources_From_File
3640 Location
: Source_Ptr
;
3641 Project
: Project_Id
;
3642 In_Tree
: Project_Tree_Ref
)
3644 File
: Prj
.Util
.Text_File
;
3645 Line
: String (1 .. 250);
3647 Source_Name
: Name_Id
;
3652 if Current_Verbosity
= High
then
3653 Write_Str
("Opening """);
3660 Prj
.Util
.Open
(File
, Path
);
3662 if not Prj
.Util
.Is_Valid
(File
) then
3663 Error_Msg
(Project
, In_Tree
, "file does not exist", Location
);
3665 -- Read the lines one by one
3667 while not Prj
.Util
.End_Of_File
(File
) loop
3668 Prj
.Util
.Get_Line
(File
, Line
, Last
);
3670 -- A non empty, non comment line should contain a file name
3673 and then (Last
= 1 or else Line
(1 .. 2) /= "--")
3675 -- ??? we should check that there is no directory information
3678 Name_Buffer
(1 .. Name_Len
) := Line
(1 .. Last
);
3679 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
3680 Source_Name
:= Name_Find
;
3684 (Name
=> Source_Name
,
3685 Location
=> Location
,
3690 Prj
.Util
.Close
(File
);
3693 end Get_Sources_From_File
;
3700 (Canonical_File_Name
: Name_Id
;
3701 Naming
: Naming_Data
;
3702 Exception_Id
: out Ada_Naming_Exception_Id
;
3703 Unit_Name
: out Name_Id
;
3704 Unit_Kind
: out Spec_Or_Body
;
3705 Needs_Pragma
: out Boolean)
3707 Info_Id
: Ada_Naming_Exception_Id
3708 := Ada_Naming_Exceptions
.Get
(Canonical_File_Name
);
3712 if Info_Id
= No_Ada_Naming_Exception
then
3713 if Hostparm
.OpenVMS
then
3714 VMS_Name
:= Canonical_File_Name
;
3715 Get_Name_String
(VMS_Name
);
3717 if Name_Buffer
(Name_Len
) = '.' then
3718 Name_Len
:= Name_Len
- 1;
3719 VMS_Name
:= Name_Find
;
3722 Info_Id
:= Ada_Naming_Exceptions
.Get
(VMS_Name
);
3727 if Info_Id
/= No_Ada_Naming_Exception
then
3728 Exception_Id
:= Info_Id
;
3729 Unit_Name
:= No_Name
;
3730 Unit_Kind
:= Specification
;
3731 Needs_Pragma
:= True;
3735 Needs_Pragma
:= False;
3736 Exception_Id
:= No_Ada_Naming_Exception
;
3738 Get_Name_String
(Canonical_File_Name
);
3741 File
: String := Name_Buffer
(1 .. Name_Len
);
3742 First
: constant Positive := File
'First;
3743 Last
: Natural := File
'Last;
3744 Standard_GNAT
: Boolean;
3748 Naming
.Ada_Spec_Suffix
= Default_Ada_Spec_Suffix
3749 and then Naming
.Ada_Body_Suffix
= Default_Ada_Body_Suffix
;
3751 -- Check if the end of the file name is Specification_Append
3753 Get_Name_String
(Naming
.Ada_Spec_Suffix
);
3755 if File
'Length > Name_Len
3756 and then File
(Last
- Name_Len
+ 1 .. Last
) =
3757 Name_Buffer
(1 .. Name_Len
)
3761 Unit_Kind
:= Specification
;
3762 Last
:= Last
- Name_Len
;
3764 if Current_Verbosity
= High
then
3765 Write_Str
(" Specification: ");
3766 Write_Line
(File
(First
.. Last
));
3770 Get_Name_String
(Naming
.Ada_Body_Suffix
);
3772 -- Check if the end of the file name is Body_Append
3774 if File
'Length > Name_Len
3775 and then File
(Last
- Name_Len
+ 1 .. Last
) =
3776 Name_Buffer
(1 .. Name_Len
)
3780 Unit_Kind
:= Body_Part
;
3781 Last
:= Last
- Name_Len
;
3783 if Current_Verbosity
= High
then
3784 Write_Str
(" Body: ");
3785 Write_Line
(File
(First
.. Last
));
3788 elsif Naming
.Separate_Suffix
/= Naming
.Ada_Spec_Suffix
then
3789 Get_Name_String
(Naming
.Separate_Suffix
);
3791 -- Check if the end of the file name is Separate_Append
3793 if File
'Length > Name_Len
3794 and then File
(Last
- Name_Len
+ 1 .. Last
) =
3795 Name_Buffer
(1 .. Name_Len
)
3797 -- We have a separate (a body)
3799 Unit_Kind
:= Body_Part
;
3800 Last
:= Last
- Name_Len
;
3802 if Current_Verbosity
= High
then
3803 Write_Str
(" Separate: ");
3804 Write_Line
(File
(First
.. Last
));
3818 -- This is not a source file
3820 Unit_Name
:= No_Name
;
3821 Unit_Kind
:= Specification
;
3823 if Current_Verbosity
= High
then
3824 Write_Line
(" Not a valid file name.");
3830 Get_Name_String
(Naming
.Dot_Replacement
);
3832 Standard_GNAT
and then Name_Buffer
(1 .. Name_Len
) = "-";
3834 if Name_Buffer
(1 .. Name_Len
) /= "." then
3836 -- If Dot_Replacement is not a single dot, then there should
3837 -- not be any dot in the name.
3839 for Index
in First
.. Last
loop
3840 if File
(Index
) = '.' then
3841 if Current_Verbosity
= High
then
3843 (" Not a valid file name (some dot not replaced).");
3846 Unit_Name
:= No_Name
;
3852 -- Replace the substring Dot_Replacement with dots
3855 Index
: Positive := First
;
3858 while Index
<= Last
- Name_Len
+ 1 loop
3860 if File
(Index
.. Index
+ Name_Len
- 1) =
3861 Name_Buffer
(1 .. Name_Len
)
3863 File
(Index
) := '.';
3865 if Name_Len
> 1 and then Index
< Last
then
3866 File
(Index
+ 1 .. Last
- Name_Len
+ 1) :=
3867 File
(Index
+ Name_Len
.. Last
);
3870 Last
:= Last
- Name_Len
+ 1;
3878 -- Check if the casing is right
3881 Src
: String := File
(First
.. Last
);
3884 case Naming
.Casing
is
3885 when All_Lower_Case
=>
3888 Mapping
=> Lower_Case_Map
);
3890 when All_Upper_Case
=>
3893 Mapping
=> Upper_Case_Map
);
3895 when Mixed_Case | Unknown
=>
3899 if Src
/= File
(First
.. Last
) then
3900 if Current_Verbosity
= High
then
3901 Write_Line
(" Not a valid file name (casing).");
3904 Unit_Name
:= No_Name
;
3908 -- We put the name in lower case
3912 Mapping
=> Lower_Case_Map
);
3914 -- In the standard GNAT naming scheme, check for special cases:
3915 -- children or separates of A, G, I or S, and run time sources.
3917 if Standard_GNAT
and then Src
'Length >= 3 then
3919 S1
: constant Character := Src
(Src
'First);
3920 S2
: constant Character := Src
(Src
'First + 1);
3921 S3
: constant Character := Src
(Src
'First + 2);
3924 if S1
= 'a' or else S1
= 'g'
3925 or else S1
= 'i' or else S1
= 's'
3927 -- Children or separates of packages A, G, I or S
3929 if (OpenVMS_On_Target
3935 Src
(Src
'First + 1) := '.';
3937 -- If it is potentially a run time source, disable
3938 -- filling of the mapping file to avoid warnings.
3941 Set_Mapping_File_Initial_State_To_Empty
;
3948 if Current_Verbosity
= High
then
3953 -- Now, we check if this name is a valid unit name
3955 Check_Ada_Name
(Name
=> Src
, Unit
=> Unit_Name
);
3965 function Hash
(Unit
: Unit_Info
) return Header_Num
is
3967 return Header_Num
(Unit
.Unit
mod 2048);
3970 -----------------------
3971 -- Is_Illegal_Suffix --
3972 -----------------------
3974 function Is_Illegal_Suffix
3976 Dot_Replacement_Is_A_Single_Dot
: Boolean) return Boolean
3979 if Suffix
'Length = 0 or else Index
(Suffix
, ".") = 0 then
3983 -- If dot replacement is a single dot, and first character of
3984 -- suffix is also a dot
3986 if Dot_Replacement_Is_A_Single_Dot
3987 and then Suffix
(Suffix
'First) = '.'
3989 for Index
in Suffix
'First + 1 .. Suffix
'Last loop
3991 -- If there is another dot
3993 if Suffix
(Index
) = '.' then
3995 -- It is illegal to have a letter following the initial dot
3997 return Is_Letter
(Suffix
(Suffix
'First + 1));
4005 end Is_Illegal_Suffix
;
4007 ----------------------
4008 -- Locate_Directory --
4009 ----------------------
4011 procedure Locate_Directory
4015 Display
: out Name_Id
)
4017 The_Name
: constant String := Get_Name_String
(Name
);
4019 The_Parent
: constant String :=
4020 Get_Name_String
(Parent
) & Directory_Separator
;
4022 The_Parent_Last
: constant Natural :=
4023 Compute_Directory_Last
(The_Parent
);
4026 if Current_Verbosity
= High
then
4027 Write_Str
("Locate_Directory (""");
4028 Write_Str
(The_Name
);
4029 Write_Str
(""", """);
4030 Write_Str
(The_Parent
);
4037 if Is_Absolute_Path
(The_Name
) then
4038 if Is_Directory
(The_Name
) then
4040 Normed
: constant String :=
4043 Resolve_Links
=> False,
4044 Case_Sensitive
=> True);
4046 Canonical_Path
: constant String :=
4049 Resolve_Links
=> True,
4050 Case_Sensitive
=> False);
4053 Name_Len
:= Normed
'Length;
4054 Name_Buffer
(1 .. Name_Len
) := Normed
;
4055 Display
:= Name_Find
;
4057 Name_Len
:= Canonical_Path
'Length;
4058 Name_Buffer
(1 .. Name_Len
) := Canonical_Path
;
4065 Full_Path
: constant String :=
4066 The_Parent
(The_Parent
'First .. The_Parent_Last
) &
4070 if Is_Directory
(Full_Path
) then
4072 Normed
: constant String :=
4075 Resolve_Links
=> False,
4076 Case_Sensitive
=> True);
4078 Canonical_Path
: constant String :=
4081 Resolve_Links
=> True,
4082 Case_Sensitive
=> False);
4085 Name_Len
:= Normed
'Length;
4086 Name_Buffer
(1 .. Name_Len
) := Normed
;
4087 Display
:= Name_Find
;
4089 Name_Len
:= Canonical_Path
'Length;
4090 Name_Buffer
(1 .. Name_Len
) := Canonical_Path
;
4096 end Locate_Directory
;
4098 ----------------------
4099 -- Look_For_Sources --
4100 ----------------------
4102 procedure Look_For_Sources
4103 (Project
: Project_Id
;
4104 In_Tree
: Project_Tree_Ref
;
4105 Data
: in out Project_Data
;
4106 Follow_Links
: Boolean)
4108 procedure Get_Path_Names_And_Record_Sources
(Follow_Links
: Boolean);
4109 -- Find the path names of the source files in the Source_Names table
4110 -- in the source directories and record those that are Ada sources.
4112 procedure Get_Sources_From_File
4114 Location
: Source_Ptr
);
4115 -- Get the sources of a project from a text file
4117 ---------------------------------------
4118 -- Get_Path_Names_And_Record_Sources --
4119 ---------------------------------------
4121 procedure Get_Path_Names_And_Record_Sources
(Follow_Links
: Boolean) is
4122 Source_Dir
: String_List_Id
:= Data
.Source_Dirs
;
4123 Element
: String_Element
;
4128 Canonical_Name
: Name_Id
;
4129 Name_Str
: String (1 .. 1_024
);
4130 Last
: Natural := 0;
4133 Current_Source
: String_List_Id
:= Nil_String
;
4135 First_Error
: Boolean := True;
4137 Source_Recorded
: Boolean := False;
4140 -- We look in all source directories for the file names in the
4141 -- hash table Source_Names
4143 while Source_Dir
/= Nil_String
loop
4144 Source_Recorded
:= False;
4145 Element
:= In_Tree
.String_Elements
.Table
(Source_Dir
);
4148 Dir_Path
: constant String := Get_Name_String
(Element
.Value
);
4150 if Current_Verbosity
= High
then
4151 Write_Str
("checking directory """);
4152 Write_Str
(Dir_Path
);
4156 Open
(Dir
, Dir_Path
);
4159 Read
(Dir
, Name_Str
, Last
);
4162 Name_Buffer
(1 .. Name_Len
) := Name_Str
(1 .. Last
);
4164 Canonical_Case_File_Name
(Name_Str
(1 .. Last
));
4166 Name_Buffer
(1 .. Name_Len
) := Name_Str
(1 .. Last
);
4167 Canonical_Name
:= Name_Find
;
4168 NL
:= Source_Names
.Get
(Canonical_Name
);
4170 if NL
/= No_Name_Location
and then not NL
.Found
then
4172 Source_Names
.Set
(Canonical_Name
, NL
);
4173 Name_Len
:= Dir_Path
'Length;
4174 Name_Buffer
(1 .. Name_Len
) := Dir_Path
;
4176 if Name_Buffer
(Name_Len
) /= Directory_Separator
then
4177 Add_Char_To_Name_Buffer
(Directory_Separator
);
4180 Add_Str_To_Name_Buffer
(Name_Str
(1 .. Last
));
4183 if Current_Verbosity
= High
then
4184 Write_Str
(" found ");
4185 Write_Line
(Get_Name_String
(Name
));
4188 -- Register the source if it is an Ada compilation unit
4196 Location
=> NL
.Location
,
4197 Current_Source
=> Current_Source
,
4198 Source_Recorded
=> Source_Recorded
,
4199 Follow_Links
=> Follow_Links
);
4206 if Source_Recorded
then
4207 In_Tree
.String_Elements
.Table
(Source_Dir
).Flag
:=
4211 Source_Dir
:= Element
.Next
;
4214 -- It is an error if a source file name in a source list or
4215 -- in a source list file is not found.
4217 NL
:= Source_Names
.Get_First
;
4219 while NL
/= No_Name_Location
loop
4220 if not NL
.Found
then
4221 Err_Vars
.Error_Msg_Name_1
:= NL
.Name
;
4226 "source file { cannot be found",
4228 First_Error
:= False;
4233 "\source file { cannot be found",
4238 NL
:= Source_Names
.Get_Next
;
4240 end Get_Path_Names_And_Record_Sources
;
4242 ---------------------------
4243 -- Get_Sources_From_File --
4244 ---------------------------
4246 procedure Get_Sources_From_File
4248 Location
: Source_Ptr
)
4251 -- Get the list of sources from the file and put them in hash table
4254 Get_Sources_From_File
(Path
, Location
, Project
, In_Tree
);
4256 -- Look in the source directories to find those sources
4258 Get_Path_Names_And_Record_Sources
(Follow_Links
);
4260 -- We should have found at least one source.
4261 -- If not, report an error/warning.
4263 if Data
.Sources
= Nil_String
then
4264 Report_No_Ada_Sources
(Project
, In_Tree
, Location
);
4266 end Get_Sources_From_File
;
4269 if Data
.Ada_Sources_Present
then
4271 Sources
: constant Variable_Value
:=
4274 Data
.Decl
.Attributes
,
4277 Source_List_File
: constant Variable_Value
:=
4279 (Name_Source_List_File
,
4280 Data
.Decl
.Attributes
,
4283 Locally_Removed
: constant Variable_Value
:=
4285 (Name_Locally_Removed_Files
,
4286 Data
.Decl
.Attributes
,
4291 (Sources
.Kind
= List
,
4292 "Source_Files is not a list");
4295 (Source_List_File
.Kind
= Single
,
4296 "Source_List_File is not a single string");
4298 if not Sources
.Default
then
4299 if not Source_List_File
.Default
then
4302 "?both variables source_files and " &
4303 "source_list_file are present",
4304 Source_List_File
.Location
);
4307 -- Sources is a list of file names
4310 Current
: String_List_Id
:= Sources
.Values
;
4311 Element
: String_Element
;
4312 Location
: Source_Ptr
;
4318 Data
.Ada_Sources_Present
:= Current
/= Nil_String
;
4320 while Current
/= Nil_String
loop
4322 In_Tree
.String_Elements
.Table
(Current
);
4323 Get_Name_String
(Element
.Value
);
4324 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
4327 -- If the element has no location, then use the
4328 -- location of Sources to report possible errors.
4330 if Element
.Location
= No_Location
then
4331 Location
:= Sources
.Location
;
4333 Location
:= Element
.Location
;
4340 Location
=> Location
,
4343 Current
:= Element
.Next
;
4346 Get_Path_Names_And_Record_Sources
(Follow_Links
);
4349 -- No source_files specified
4351 -- We check Source_List_File has been specified
4353 elsif not Source_List_File
.Default
then
4355 -- Source_List_File is the name of the file
4356 -- that contains the source file names
4359 Source_File_Path_Name
: constant String :=
4361 (Source_List_File
.Value
,
4365 if Source_File_Path_Name
'Length = 0 then
4366 Err_Vars
.Error_Msg_Name_1
:= Source_List_File
.Value
;
4369 "file with sources { does not exist",
4370 Source_List_File
.Location
);
4373 Get_Sources_From_File
4374 (Source_File_Path_Name
,
4375 Source_List_File
.Location
);
4380 -- Neither Source_Files nor Source_List_File has been
4381 -- specified. Find all the files that satisfy the naming
4382 -- scheme in all the source directories.
4385 (Project
, In_Tree
, Data
, Ada_Language_Index
, Follow_Links
);
4388 -- If there are sources that are locally removed, mark them as
4389 -- such in the Units table.
4391 if not Locally_Removed
.Default
then
4393 -- Sources can be locally removed only in extending
4396 if Data
.Extends
= No_Project
then
4399 "Locally_Removed_Files can only be used " &
4400 "in an extending project file",
4401 Locally_Removed
.Location
);
4405 Current
: String_List_Id
:= Locally_Removed
.Values
;
4406 Element
: String_Element
;
4407 Location
: Source_Ptr
;
4411 Extended
: Project_Id
;
4414 while Current
/= Nil_String
loop
4416 In_Tree
.String_Elements
.Table
(Current
);
4417 Get_Name_String
(Element
.Value
);
4418 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
4421 -- If the element has no location, then use the
4422 -- location of Locally_Removed to report
4425 if Element
.Location
= No_Location
then
4426 Location
:= Locally_Removed
.Location
;
4428 Location
:= Element
.Location
;
4433 for Index
in Unit_Table
.First
..
4434 Unit_Table
.Last
(In_Tree
.Units
)
4436 Unit
:= In_Tree
.Units
.Table
(Index
);
4438 if Unit
.File_Names
(Specification
).Name
= Name
then
4441 -- Check that this is from a project that
4442 -- the current project extends, but not the
4445 Extended
:= Unit
.File_Names
4446 (Specification
).Project
;
4448 if Extended
= Project
then
4451 "cannot remove a source " &
4452 "of the same project",
4456 Project_Extends
(Project
, Extended
, In_Tree
)
4459 (Specification
).Path
:= Slash
;
4461 (Specification
).Needs_Pragma
:= False;
4462 In_Tree
.Units
.Table
(Index
) :=
4464 Add_Forbidden_File_Name
4465 (Unit
.File_Names
(Specification
).Name
);
4471 "cannot remove a source from " &
4477 Unit
.File_Names
(Body_Part
).Name
= Name
4481 -- Check that this is from a project that
4482 -- the current project extends, but not the
4485 Extended
:= Unit
.File_Names
4486 (Body_Part
).Project
;
4488 if Extended
= Project
then
4491 "cannot remove a source " &
4492 "of the same project",
4496 Project_Extends
(Project
, Extended
, In_Tree
)
4498 Unit
.File_Names
(Body_Part
).Path
:= Slash
;
4499 Unit
.File_Names
(Body_Part
).Needs_Pragma
4501 In_Tree
.Units
.Table
(Index
) :=
4503 Add_Forbidden_File_Name
4504 (Unit
.File_Names
(Body_Part
).Name
);
4512 Err_Vars
.Error_Msg_Name_1
:= Name
;
4514 (Project
, In_Tree
, "unknown file {", Location
);
4517 Current
:= Element
.Next
;
4525 if Data
.Other_Sources_Present
then
4527 -- Set Source_Present to False. It will be set back to True
4528 -- whenever a source is found.
4530 Data
.Other_Sources_Present
:= False;
4531 for Lang
in Ada_Language_Index
+ 1 .. Last_Language_Index
loop
4533 -- For each language (other than Ada) in the project file
4535 if Is_Present
(Lang
, Data
, In_Tree
) then
4537 -- Reset the indication that there are sources of this
4538 -- language. It will be set back to True whenever we find a
4539 -- source of the language.
4541 Set
(Lang
, False, Data
, In_Tree
);
4543 -- First, get the source suffix for the language
4545 Set
(Suffix
=> Suffix_For
(Lang
, Data
.Naming
, In_Tree
),
4546 For_Language
=> Lang
,
4548 In_Tree
=> In_Tree
);
4550 -- Then, deal with the naming exceptions, if any
4555 Naming_Exceptions
: constant Variable_Value
:=
4557 (Index
=> Language_Names
.Table
(Lang
),
4559 In_Array
=> Data
.Naming
.Implementation_Exceptions
,
4560 In_Tree
=> In_Tree
);
4561 Element_Id
: String_List_Id
;
4562 Element
: String_Element
;
4564 Source_Found
: Boolean := False;
4567 -- If there are naming exceptions, look through them one
4570 if Naming_Exceptions
/= Nil_Variable_Value
then
4571 Element_Id
:= Naming_Exceptions
.Values
;
4573 while Element_Id
/= Nil_String
loop
4574 Element
:= In_Tree
.String_Elements
.Table
4576 Get_Name_String
(Element
.Value
);
4577 Canonical_Case_File_Name
4578 (Name_Buffer
(1 .. Name_Len
));
4579 File_Id
:= Name_Find
;
4581 -- Put each naming exception in the Source_Names
4582 -- hash table, but if there are repetition, don't
4583 -- bother after the first instance.
4586 Source_Names
.Get
(File_Id
) = No_Name_Location
4588 Source_Found
:= True;
4592 Location
=> Element
.Location
,
4596 Element_Id
:= Element
.Next
;
4599 -- If there is at least one naming exception, record
4600 -- those that are found in the source directories.
4602 if Source_Found
then
4603 Record_Other_Sources
4604 (Project
=> Project
,
4608 Naming_Exceptions
=> True);
4614 -- Now, check if a list of sources is declared either through
4615 -- a string list (attribute Source_Files) or a text file
4616 -- (attribute Source_List_File). If a source list is declared,
4617 -- we will consider only those naming exceptions that are
4621 Sources
: constant Variable_Value
:=
4624 Data
.Decl
.Attributes
,
4627 Source_List_File
: constant Variable_Value
:=
4629 (Name_Source_List_File
,
4630 Data
.Decl
.Attributes
,
4635 (Sources
.Kind
= List
,
4636 "Source_Files is not a list");
4639 (Source_List_File
.Kind
= Single
,
4640 "Source_List_File is not a single string");
4642 if not Sources
.Default
then
4643 if not Source_List_File
.Default
then
4646 "?both variables source_files and " &
4647 "source_list_file are present",
4648 Source_List_File
.Location
);
4651 -- Sources is a list of file names
4654 Current
: String_List_Id
:= Sources
.Values
;
4655 Element
: String_Element
;
4656 Location
: Source_Ptr
;
4662 -- Put all the sources in the Source_Names hash table
4664 while Current
/= Nil_String
loop
4666 In_Tree
.String_Elements
.Table
4668 Get_Name_String
(Element
.Value
);
4669 Canonical_Case_File_Name
4670 (Name_Buffer
(1 .. Name_Len
));
4673 -- If the element has no location, then use the
4674 -- location of Sources to report possible errors.
4676 if Element
.Location
= No_Location
then
4677 Location
:= Sources
.Location
;
4679 Location
:= Element
.Location
;
4686 Location
=> Location
,
4689 Current
:= Element
.Next
;
4692 -- And look for their directories
4694 Record_Other_Sources
4695 (Project
=> Project
,
4699 Naming_Exceptions
=> False);
4702 -- No source_files specified
4704 -- We check if Source_List_File has been specified
4706 elsif not Source_List_File
.Default
then
4708 -- Source_List_File is the name of the file
4709 -- that contains the source file names
4712 Source_File_Path_Name
: constant String :=
4714 (Source_List_File
.Value
,
4718 if Source_File_Path_Name
'Length = 0 then
4719 Err_Vars
.Error_Msg_Name_1
:=
4720 Source_List_File
.Value
;
4723 "file with sources { does not exist",
4724 Source_List_File
.Location
);
4727 -- Read the file, putting each source in the
4728 -- Source_Names hash table.
4730 Get_Sources_From_File
4731 (Source_File_Path_Name
,
4732 Source_List_File
.Location
,
4735 -- And look for their directories
4737 Record_Other_Sources
4738 (Project
=> Project
,
4742 Naming_Exceptions
=> False);
4746 -- Neither Source_Files nor Source_List_File was specified
4749 -- Find all the files that satisfy the naming scheme in
4750 -- all the source directories. All the naming exceptions
4751 -- that effectively exist are also part of the source
4752 -- of this language.
4754 Find_Sources
(Project
, In_Tree
, Data
, Lang
);
4760 end Look_For_Sources
;
4766 function Path_Name_Of
4767 (File_Name
: Name_Id
;
4768 Directory
: Name_Id
) return String
4770 Result
: String_Access
;
4772 The_Directory
: constant String := Get_Name_String
(Directory
);
4775 Get_Name_String
(File_Name
);
4776 Result
:= Locate_Regular_File
4777 (File_Name
=> Name_Buffer
(1 .. Name_Len
),
4778 Path
=> The_Directory
);
4780 if Result
= null then
4783 Canonical_Case_File_Name
(Result
.all);
4788 -------------------------------
4789 -- Prepare_Ada_Naming_Exceptions --
4790 -------------------------------
4792 procedure Prepare_Ada_Naming_Exceptions
4793 (List
: Array_Element_Id
;
4794 In_Tree
: Project_Tree_Ref
;
4795 Kind
: Spec_Or_Body
)
4797 Current
: Array_Element_Id
:= List
;
4798 Element
: Array_Element
;
4803 -- Traverse the list
4805 while Current
/= No_Array_Element
loop
4806 Element
:= In_Tree
.Array_Elements
.Table
(Current
);
4808 if Element
.Index
/= No_Name
then
4811 Unit
=> Element
.Index
,
4812 Next
=> No_Ada_Naming_Exception
);
4813 Reverse_Ada_Naming_Exceptions
.Set
4814 (Unit
, (Element
.Value
.Value
, Element
.Value
.Index
));
4815 Unit
.Next
:= Ada_Naming_Exceptions
.Get
(Element
.Value
.Value
);
4816 Ada_Naming_Exception_Table
.Increment_Last
;
4817 Ada_Naming_Exception_Table
.Table
4818 (Ada_Naming_Exception_Table
.Last
) := Unit
;
4819 Ada_Naming_Exceptions
.Set
4820 (Element
.Value
.Value
, Ada_Naming_Exception_Table
.Last
);
4823 Current
:= Element
.Next
;
4825 end Prepare_Ada_Naming_Exceptions
;
4827 ---------------------
4828 -- Project_Extends --
4829 ---------------------
4831 function Project_Extends
4832 (Extending
: Project_Id
;
4833 Extended
: Project_Id
;
4834 In_Tree
: Project_Tree_Ref
) return Boolean
4836 Current
: Project_Id
:= Extending
;
4839 if Current
= No_Project
then
4842 elsif Current
= Extended
then
4846 Current
:= In_Tree
.Projects
.Table
(Current
).Extends
;
4848 end Project_Extends
;
4850 -----------------------
4851 -- Record_Ada_Source --
4852 -----------------------
4854 procedure Record_Ada_Source
4855 (File_Name
: Name_Id
;
4856 Path_Name
: Name_Id
;
4857 Project
: Project_Id
;
4858 In_Tree
: Project_Tree_Ref
;
4859 Data
: in out Project_Data
;
4860 Location
: Source_Ptr
;
4861 Current_Source
: in out String_List_Id
;
4862 Source_Recorded
: in out Boolean;
4863 Follow_Links
: Boolean)
4865 Canonical_File_Name
: Name_Id
;
4866 Canonical_Path_Name
: Name_Id
;
4868 Exception_Id
: Ada_Naming_Exception_Id
;
4869 Unit_Name
: Name_Id
;
4870 Unit_Kind
: Spec_Or_Body
;
4871 Unit_Index
: Int
:= 0;
4873 Name_Index
: Name_And_Index
;
4874 Needs_Pragma
: Boolean;
4876 The_Location
: Source_Ptr
:= Location
;
4877 Previous_Source
: constant String_List_Id
:= Current_Source
;
4878 Except_Name
: Name_And_Index
:= No_Name_And_Index
;
4880 Unit_Prj
: Unit_Project
;
4882 File_Name_Recorded
: Boolean := False;
4885 Get_Name_String
(File_Name
);
4886 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
4887 Canonical_File_Name
:= Name_Find
;
4890 Canonical_Path
: constant String :=
4892 (Get_Name_String
(Path_Name
),
4893 Resolve_Links
=> Follow_Links
,
4894 Case_Sensitive
=> False);
4897 Add_Str_To_Name_Buffer
(Canonical_Path
);
4898 Canonical_Path_Name
:= Name_Find
;
4901 -- Find out the unit name, the unit kind and if it needs
4902 -- a specific SFN pragma.
4905 (Canonical_File_Name
=> Canonical_File_Name
,
4906 Naming
=> Data
.Naming
,
4907 Exception_Id
=> Exception_Id
,
4908 Unit_Name
=> Unit_Name
,
4909 Unit_Kind
=> Unit_Kind
,
4910 Needs_Pragma
=> Needs_Pragma
);
4912 if Exception_Id
= No_Ada_Naming_Exception
and then
4915 if Current_Verbosity
= High
then
4917 Write_Str
(Get_Name_String
(Canonical_File_Name
));
4918 Write_Line
(""" is not a valid source file name (ignored).");
4922 -- Check to see if the source has been hidden by an exception,
4923 -- but only if it is not an exception.
4925 if not Needs_Pragma
then
4927 Reverse_Ada_Naming_Exceptions
.Get
4928 ((Unit_Kind
, Unit_Name
, No_Ada_Naming_Exception
));
4930 if Except_Name
/= No_Name_And_Index
then
4931 if Current_Verbosity
= High
then
4933 Write_Str
(Get_Name_String
(Canonical_File_Name
));
4934 Write_Str
(""" contains a unit that is found in """);
4935 Write_Str
(Get_Name_String
(Except_Name
.Name
));
4936 Write_Line
(""" (ignored).");
4939 -- The file is not included in the source of the project,
4940 -- because it is hidden by the exception.
4941 -- So, there is nothing else to do.
4948 if Exception_Id
/= No_Ada_Naming_Exception
then
4949 Info
:= Ada_Naming_Exception_Table
.Table
(Exception_Id
);
4950 Exception_Id
:= Info
.Next
;
4951 Info
.Next
:= No_Ada_Naming_Exception
;
4952 Name_Index
:= Reverse_Ada_Naming_Exceptions
.Get
(Info
);
4954 Unit_Name
:= Info
.Unit
;
4955 Unit_Index
:= Name_Index
.Index
;
4956 Unit_Kind
:= Info
.Kind
;
4959 -- Put the file name in the list of sources of the project
4961 if not File_Name_Recorded
then
4962 String_Element_Table
.Increment_Last
4963 (In_Tree
.String_Elements
);
4964 In_Tree
.String_Elements
.Table
4965 (String_Element_Table
.Last
4966 (In_Tree
.String_Elements
)) :=
4967 (Value
=> Canonical_File_Name
,
4968 Display_Value
=> File_Name
,
4969 Location
=> No_Location
,
4972 Index
=> Unit_Index
);
4975 if Current_Source
= Nil_String
then
4976 Data
.Sources
:= String_Element_Table
.Last
4977 (In_Tree
.String_Elements
);
4979 In_Tree
.String_Elements
.Table
4980 (Current_Source
).Next
:=
4981 String_Element_Table
.Last
4982 (In_Tree
.String_Elements
);
4985 Current_Source
:= String_Element_Table
.Last
4986 (In_Tree
.String_Elements
);
4988 -- Put the unit in unit list
4991 The_Unit
: Unit_Id
:=
4992 Units_Htable
.Get
(In_Tree
.Units_HT
, Unit_Name
);
4993 The_Unit_Data
: Unit_Data
;
4996 if Current_Verbosity
= High
then
4997 Write_Str
("Putting ");
4998 Write_Str
(Get_Name_String
(Unit_Name
));
4999 Write_Line
(" in the unit list.");
5002 -- The unit is already in the list, but may be it is
5003 -- only the other unit kind (spec or body), or what is
5004 -- in the unit list is a unit of a project we are extending.
5006 if The_Unit
/= No_Unit
then
5007 The_Unit_Data
:= In_Tree
.Units
.Table
(The_Unit
);
5009 if The_Unit_Data
.File_Names
(Unit_Kind
).Name
= No_Name
5010 or else Project_Extends
5012 The_Unit_Data
.File_Names
(Unit_Kind
).Project
,
5015 if The_Unit_Data
.File_Names
(Unit_Kind
).Path
= Slash
then
5016 Remove_Forbidden_File_Name
5017 (The_Unit_Data
.File_Names
(Unit_Kind
).Name
);
5020 -- Record the file name in the hash table Files_Htable
5022 Unit_Prj
:= (Unit
=> The_Unit
, Project
=> Project
);
5025 Canonical_File_Name
,
5028 The_Unit_Data
.File_Names
(Unit_Kind
) :=
5029 (Name
=> Canonical_File_Name
,
5030 Index
=> Unit_Index
,
5031 Display_Name
=> File_Name
,
5032 Path
=> Canonical_Path_Name
,
5033 Display_Path
=> Path_Name
,
5035 Needs_Pragma
=> Needs_Pragma
);
5036 In_Tree
.Units
.Table
(The_Unit
) :=
5038 Source_Recorded
:= True;
5040 elsif The_Unit_Data
.File_Names
(Unit_Kind
).Project
= Project
5041 and then (Data
.Known_Order_Of_Source_Dirs
or else
5042 The_Unit_Data
.File_Names
(Unit_Kind
).Path
=
5043 Canonical_Path_Name
)
5045 if Previous_Source
= Nil_String
then
5046 Data
.Sources
:= Nil_String
;
5048 In_Tree
.String_Elements
.Table
5049 (Previous_Source
).Next
:= Nil_String
;
5050 String_Element_Table
.Decrement_Last
5051 (In_Tree
.String_Elements
);
5054 Current_Source
:= Previous_Source
;
5057 -- It is an error to have two units with the same name
5058 -- and the same kind (spec or body).
5060 if The_Location
= No_Location
then
5062 In_Tree
.Projects
.Table
5066 Err_Vars
.Error_Msg_Name_1
:= Unit_Name
;
5068 (Project
, In_Tree
, "duplicate source {", The_Location
);
5070 Err_Vars
.Error_Msg_Name_1
:=
5071 In_Tree
.Projects
.Table
5072 (The_Unit_Data
.File_Names
(Unit_Kind
).Project
).Name
;
5073 Err_Vars
.Error_Msg_Name_2
:=
5074 The_Unit_Data
.File_Names
(Unit_Kind
).Path
;
5077 "\ project file {, {", The_Location
);
5079 Err_Vars
.Error_Msg_Name_1
:=
5080 In_Tree
.Projects
.Table
(Project
).Name
;
5081 Err_Vars
.Error_Msg_Name_2
:= Canonical_Path_Name
;
5084 "\ project file {, {", The_Location
);
5087 -- It is a new unit, create a new record
5090 -- First, check if there is no other unit with this file
5091 -- name in another project. If it is, report an error.
5092 -- Of course, we do that only for the first unit in the
5095 Unit_Prj
:= Files_Htable
.Get
5096 (In_Tree
.Files_HT
, Canonical_File_Name
);
5098 if not File_Name_Recorded
and then
5099 Unit_Prj
/= No_Unit_Project
5101 Error_Msg_Name_1
:= File_Name
;
5103 In_Tree
.Projects
.Table
5104 (Unit_Prj
.Project
).Name
;
5107 "{ is already a source of project {",
5111 Unit_Table
.Increment_Last
(In_Tree
.Units
);
5112 The_Unit
:= Unit_Table
.Last
(In_Tree
.Units
);
5114 (In_Tree
.Units_HT
, Unit_Name
, The_Unit
);
5115 Unit_Prj
:= (Unit
=> The_Unit
, Project
=> Project
);
5118 Canonical_File_Name
,
5120 The_Unit_Data
.Name
:= Unit_Name
;
5121 The_Unit_Data
.File_Names
(Unit_Kind
) :=
5122 (Name
=> Canonical_File_Name
,
5123 Index
=> Unit_Index
,
5124 Display_Name
=> File_Name
,
5125 Path
=> Canonical_Path_Name
,
5126 Display_Path
=> Path_Name
,
5128 Needs_Pragma
=> Needs_Pragma
);
5129 In_Tree
.Units
.Table
(The_Unit
) :=
5131 Source_Recorded
:= True;
5136 exit when Exception_Id
= No_Ada_Naming_Exception
;
5137 File_Name_Recorded
:= True;
5140 end Record_Ada_Source
;
5142 --------------------------
5143 -- Record_Other_Sources --
5144 --------------------------
5146 procedure Record_Other_Sources
5147 (Project
: Project_Id
;
5148 In_Tree
: Project_Tree_Ref
;
5149 Data
: in out Project_Data
;
5150 Language
: Language_Index
;
5151 Naming_Exceptions
: Boolean)
5153 Source_Dir
: String_List_Id
:= Data
.Source_Dirs
;
5154 Element
: String_Element
;
5158 Canonical_Name
: Name_Id
;
5160 Name_Str
: String (1 .. 1_024
);
5161 Last
: Natural := 0;
5164 First_Error
: Boolean := True;
5166 Suffix
: constant String := Body_Suffix_Of
(Language
, Data
, In_Tree
);
5169 while Source_Dir
/= Nil_String
loop
5170 Element
:= In_Tree
.String_Elements
.Table
(Source_Dir
);
5173 Dir_Path
: constant String := Get_Name_String
(Element
.Value
);
5176 if Current_Verbosity
= High
then
5177 Write_Str
("checking directory """);
5178 Write_Str
(Dir_Path
);
5179 Write_Str
(""" for ");
5181 if Naming_Exceptions
then
5182 Write_Str
("naming exceptions");
5185 Write_Str
("sources");
5188 Write_Str
(" of Language ");
5189 Display_Language_Name
(Language
);
5192 Open
(Dir
, Dir_Path
);
5195 Read
(Dir
, Name_Str
, Last
);
5199 (Dir_Path
& Directory_Separator
& Name_Str
(1 .. Last
))
5202 Name_Buffer
(1 .. Name_Len
) := Name_Str
(1 .. Last
);
5203 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
5204 Canonical_Name
:= Name_Find
;
5205 NL
:= Source_Names
.Get
(Canonical_Name
);
5207 if NL
/= No_Name_Location
then
5209 if not Data
.Known_Order_Of_Source_Dirs
then
5210 Error_Msg_Name_1
:= Canonical_Name
;
5213 "{ is found in several source directories",
5219 Source_Names
.Set
(Canonical_Name
, NL
);
5220 Name_Len
:= Dir_Path
'Length;
5221 Name_Buffer
(1 .. Name_Len
) := Dir_Path
;
5222 Add_Char_To_Name_Buffer
(Directory_Separator
);
5223 Add_Str_To_Name_Buffer
(Name_Str
(1 .. Last
));
5227 (File_Name
=> Canonical_Name
,
5232 Location
=> NL
.Location
,
5233 Language
=> Language
,
5235 Naming_Exception
=> Naming_Exceptions
);
5244 Source_Dir
:= Element
.Next
;
5247 if not Naming_Exceptions
then
5248 NL
:= Source_Names
.Get_First
;
5250 -- It is an error if a source file name in a source list or
5251 -- in a source list file is not found.
5253 while NL
/= No_Name_Location
loop
5254 if not NL
.Found
then
5255 Err_Vars
.Error_Msg_Name_1
:= NL
.Name
;
5260 "source file { cannot be found",
5262 First_Error
:= False;
5267 "\source file { cannot be found",
5272 NL
:= Source_Names
.Get_Next
;
5275 -- Any naming exception of this language that is not in a list
5276 -- of sources must be removed.
5279 Source_Id
: Other_Source_Id
:= Data
.First_Other_Source
;
5280 Prev_Id
: Other_Source_Id
:= No_Other_Source
;
5281 Source
: Other_Source
;
5284 while Source_Id
/= No_Other_Source
loop
5285 Source
:= In_Tree
.Other_Sources
.Table
(Source_Id
);
5287 if Source
.Language
= Language
5288 and then Source
.Naming_Exception
5290 if Current_Verbosity
= High
then
5291 Write_Str
("Naming exception """);
5292 Write_Str
(Get_Name_String
(Source
.File_Name
));
5293 Write_Str
(""" is not in the list of sources,");
5294 Write_Line
(" so it is removed.");
5297 if Prev_Id
= No_Other_Source
then
5298 Data
.First_Other_Source
:= Source
.Next
;
5301 In_Tree
.Other_Sources
.Table
5302 (Prev_Id
).Next
:= Source
.Next
;
5305 Source_Id
:= Source
.Next
;
5307 if Source_Id
= No_Other_Source
then
5308 Data
.Last_Other_Source
:= Prev_Id
;
5312 Prev_Id
:= Source_Id
;
5313 Source_Id
:= Source
.Next
;
5318 end Record_Other_Sources
;
5320 ---------------------------
5321 -- Report_No_Ada_Sources --
5322 ---------------------------
5324 procedure Report_No_Ada_Sources
5325 (Project
: Project_Id
;
5326 In_Tree
: Project_Tree_Ref
;
5327 Location
: Source_Ptr
)
5330 case When_No_Sources
is
5334 when Warning | Error
=>
5335 Error_Msg_Warn
:= When_No_Sources
= Warning
;
5339 "<there are no Ada sources in this project",
5342 end Report_No_Ada_Sources
;
5344 ----------------------
5345 -- Show_Source_Dirs --
5346 ----------------------
5348 procedure Show_Source_Dirs
5349 (Project
: Project_Id
;
5350 In_Tree
: Project_Tree_Ref
)
5352 Current
: String_List_Id
;
5353 Element
: String_Element
;
5356 Write_Line
("Source_Dirs:");
5358 Current
:= In_Tree
.Projects
.Table
(Project
).Source_Dirs
;
5359 while Current
/= Nil_String
loop
5360 Element
:= In_Tree
.String_Elements
.Table
(Current
);
5362 Write_Line
(Get_Name_String
(Element
.Value
));
5363 Current
:= Element
.Next
;
5366 Write_Line
("end Source_Dirs.");
5367 end Show_Source_Dirs
;
5374 (Language
: Language_Index
;
5375 Naming
: Naming_Data
;
5376 In_Tree
: Project_Tree_Ref
) return Name_Id
5378 Suffix
: constant Variable_Value
:=
5380 (Index
=> Language_Names
.Table
(Language
),
5382 In_Array
=> Naming
.Body_Suffix
,
5383 In_Tree
=> In_Tree
);
5385 -- If no suffix for this language in package Naming, use the default
5387 if Suffix
= Nil_Variable_Value
then
5391 when Ada_Language_Index
=>
5392 Add_Str_To_Name_Buffer
(".adb");
5394 when C_Language_Index
=>
5395 Add_Str_To_Name_Buffer
(".c");
5397 when C_Plus_Plus_Language_Index
=>
5398 Add_Str_To_Name_Buffer
(".cpp");
5404 -- Otherwise use the one specified
5407 Get_Name_String
(Suffix
.Value
);
5410 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
5414 -------------------------
5415 -- Warn_If_Not_Sources --
5416 -------------------------
5418 -- comments needed in this body ???
5420 procedure Warn_If_Not_Sources
5421 (Project
: Project_Id
;
5422 In_Tree
: Project_Tree_Ref
;
5423 Conventions
: Array_Element_Id
;
5425 Extending
: Boolean)
5427 Conv
: Array_Element_Id
:= Conventions
;
5429 The_Unit_Id
: Unit_Id
;
5430 The_Unit_Data
: Unit_Data
;
5431 Location
: Source_Ptr
;
5434 while Conv
/= No_Array_Element
loop
5435 Unit
:= In_Tree
.Array_Elements
.Table
(Conv
).Index
;
5436 Error_Msg_Name_1
:= Unit
;
5437 Get_Name_String
(Unit
);
5438 To_Lower
(Name_Buffer
(1 .. Name_Len
));
5440 The_Unit_Id
:= Units_Htable
.Get
5441 (In_Tree
.Units_HT
, Unit
);
5442 Location
:= In_Tree
.Array_Elements
.Table
5443 (Conv
).Value
.Location
;
5445 if The_Unit_Id
= No_Unit
then
5452 The_Unit_Data
:= In_Tree
.Units
.Table
(The_Unit_Id
);
5454 In_Tree
.Array_Elements
.Table
(Conv
).Value
.Value
;
5457 if not Check_Project
5458 (The_Unit_Data
.File_Names
(Specification
).Project
,
5459 Project
, In_Tree
, Extending
)
5463 "?source of spec of unit { ({)" &
5464 " cannot be found in this project",
5469 if not Check_Project
5470 (The_Unit_Data
.File_Names
(Body_Part
).Project
,
5471 Project
, In_Tree
, Extending
)
5475 "?source of body of unit { ({)" &
5476 " cannot be found in this project",
5482 Conv
:= In_Tree
.Array_Elements
.Table
(Conv
).Next
;
5484 end Warn_If_Not_Sources
;