1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2002 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
28 with Ada
.Exceptions
; use Ada
.Exceptions
;
29 with Errout
; use Errout
;
30 with GNAT
.Directory_Operations
; use GNAT
.Directory_Operations
;
31 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
32 with Namet
; use Namet
;
33 with Osint
; use Osint
;
34 with Output
; use Output
;
35 with Prj
.Com
; use Prj
.Com
;
37 with Scans
; use Scans
;
39 with Sinfo
; use Sinfo
;
40 with Sinput
; use Sinput
;
41 with Sinput
.P
; use Sinput
.P
;
42 with Stringt
; use Stringt
;
44 with Types
; use Types
;
46 pragma Elaborate_All
(GNAT
.OS_Lib
);
48 package body Prj
.Part
is
50 Dir_Sep
: Character renames GNAT
.OS_Lib
.Directory_Separator
;
52 Project_Path
: String_Access
;
53 -- The project path; initialized during package elaboration.
55 Ada_Project_Path
: constant String := "ADA_PROJECT_PATH";
56 Prj_Path
: constant String_Access
:= Getenv
(Ada_Project_Path
);
58 ------------------------------------
59 -- Local Packages and Subprograms --
60 ------------------------------------
62 package Project_Stack
is new Table
.Table
63 (Table_Component_Type
=> Name_Id
,
64 Table_Index_Type
=> Nat
,
67 Table_Increment
=> 10,
68 Table_Name
=> "Prj.Part.Project_Stack");
69 -- This table is used to detect circular dependencies
70 -- for imported and modified projects.
72 procedure Parse_Context_Clause
73 (Context_Clause
: out Project_Node_Id
;
74 Project_Directory
: Name_Id
);
75 -- Parse the context clause of a project
76 -- Does nothing if there is b\no context clause (if the current
77 -- token is not "with").
79 procedure Parse_Single_Project
80 (Project
: out Project_Node_Id
;
83 -- Parse a project file.
84 -- Recursive procedure: it calls itself for imported and
87 function Project_Path_Name_Of
88 (Project_File_Name
: String;
91 -- Returns the path name of a project file.
92 -- Returns an empty string if project file cannot be found.
94 function Immediate_Directory_Of
(Path_Name
: Name_Id
) return Name_Id
;
95 -- Get the directory of the file with the specified path name.
96 -- This includes the directory separator as the last character.
97 -- Returns "./" if Path_Name contains no directory separator.
99 function Simple_File_Name_Of
(Path_Name
: Name_Id
) return Name_Id
;
100 -- Returns the name of a file with the specified path name
101 -- with no directory information.
103 function Project_Name_From
(Path_Name
: String) return Name_Id
;
104 -- Returns the name of the project that corresponds to its path name.
105 -- Returns No_Name if the path name is invalid, because the corresponding
106 -- project name does not have the syntax of an ada identifier.
108 ----------------------------
109 -- Immediate_Directory_Of --
110 ----------------------------
112 function Immediate_Directory_Of
(Path_Name
: Name_Id
) return Name_Id
is
114 Get_Name_String
(Path_Name
);
116 for Index
in reverse 1 .. Name_Len
loop
117 if Name_Buffer
(Index
) = '/'
118 or else Name_Buffer
(Index
) = Dir_Sep
120 -- Remove from name all characters after the last
121 -- directory separator.
128 -- There is no directory separator in name. Return "./" or ".\"
131 Name_Buffer
(1) := '.';
132 Name_Buffer
(2) := Dir_Sep
;
134 end Immediate_Directory_Of
;
141 (Project
: out Project_Node_Id
;
142 Project_File_Name
: String;
143 Always_Errout_Finalize
: Boolean)
145 Current_Directory
: constant String := Get_Current_Dir
;
148 Project
:= Empty_Node
;
150 if Current_Verbosity
>= Medium
then
151 Write_Str
("ADA_PROJECT_PATH=""");
152 Write_Str
(Project_Path
.all);
157 Path_Name
: constant String :=
158 Project_Path_Name_Of
(Project_File_Name
,
159 Directory
=> Current_Directory
);
164 -- Parse the main project file
166 if Path_Name
= "" then
167 Fail
("project file """ & Project_File_Name
& """ not found");
172 Path_Name
=> Path_Name
,
175 -- If there were any kind of error during the parsing, serious
176 -- or not, then the parsing fails.
178 if Errout
.Total_Errors_Detected
> 0 then
179 Project
:= Empty_Node
;
182 if Project
= Empty_Node
or else Always_Errout_Finalize
then
192 Write_Line
(Exception_Information
(X
));
193 Write_Str
("Exception ");
194 Write_Str
(Exception_Name
(X
));
195 Write_Line
(" raised, while processing project file");
196 Project
:= Empty_Node
;
199 --------------------------
200 -- Parse_Context_Clause --
201 --------------------------
203 procedure Parse_Context_Clause
204 (Context_Clause
: out Project_Node_Id
;
205 Project_Directory
: Name_Id
)
207 Project_Directory_Path
: constant String :=
208 Get_Name_String
(Project_Directory
);
209 Current_With_Clause
: Project_Node_Id
:= Empty_Node
;
210 Next_With_Clause
: Project_Node_Id
:= Empty_Node
;
213 -- Assume no context clause
215 Context_Clause
:= Empty_Node
;
218 -- If Token is not WITH, there is no context clause,
219 -- or we have exhausted the with clauses.
221 while Token
= Tok_With
loop
224 Scan
; -- scan past WITH or ","
226 Expect
(Tok_String_Literal
, "literal string");
228 if Token
/= Tok_String_Literal
then
232 String_To_Name_Buffer
(Strval
(Token_Node
));
235 Original_Path
: constant String :=
236 Name_Buffer
(1 .. Name_Len
);
238 Imported_Path_Name
: constant String :=
241 Project_Directory_Path
);
243 Withed_Project
: Project_Node_Id
:= Empty_Node
;
246 if Imported_Path_Name
= "" then
248 -- The project file cannot be found
250 Name_Len
:= Original_Path
'Length;
251 Name_Buffer
(1 .. Name_Len
) := Original_Path
;
252 Error_Msg_Name_1
:= Name_Find
;
254 Error_Msg
("unknown project file: {", Token_Ptr
);
256 -- If this is not imported by the main project file,
257 -- display the import path.
259 if Project_Stack
.Last
> 1 then
260 for Index
in reverse 1 .. Project_Stack
.Last
loop
261 Error_Msg_Name_1
:= Project_Stack
.Table
(Index
);
262 Error_Msg
("\imported by {", Token_Ptr
);
269 if Current_With_Clause
= Empty_Node
then
271 -- First with clause of the context clause
273 Current_With_Clause
:= Default_Project_Node
274 (Of_Kind
=> N_With_Clause
);
275 Context_Clause
:= Current_With_Clause
;
278 Next_With_Clause
:= Default_Project_Node
279 (Of_Kind
=> N_With_Clause
);
280 Set_Next_With_Clause_Of
281 (Current_With_Clause
, Next_With_Clause
);
282 Current_With_Clause
:= Next_With_Clause
;
286 (Current_With_Clause
, Strval
(Token_Node
));
287 Set_Location_Of
(Current_With_Clause
, Token_Ptr
);
288 String_To_Name_Buffer
289 (String_Value_Of
(Current_With_Clause
));
291 -- Parse the imported project
294 (Project
=> Withed_Project
,
295 Path_Name
=> Imported_Path_Name
,
298 if Withed_Project
/= Empty_Node
then
300 -- If parsing was successful, record project name
301 -- and path name in with clause
303 Set_Project_Node_Of
(Current_With_Clause
, Withed_Project
);
304 Set_Name_Of
(Current_With_Clause
,
305 Name_Of
(Withed_Project
));
306 Name_Len
:= Imported_Path_Name
'Length;
307 Name_Buffer
(1 .. Name_Len
) := Imported_Path_Name
;
308 Set_Path_Name_Of
(Current_With_Clause
, Name_Find
);
314 if Token
= Tok_Semicolon
then
316 -- End of (possibly multiple) with clause;
318 Scan
; -- scan past the semicolon.
321 elsif Token
/= Tok_Comma
then
322 Error_Msg
("expected comma or semi colon", Token_Ptr
);
328 end Parse_Context_Clause
;
330 --------------------------
331 -- Parse_Single_Project --
332 --------------------------
334 procedure Parse_Single_Project
335 (Project
: out Project_Node_Id
;
339 Canonical_Path_Name
: Name_Id
;
340 Project_Directory
: Name_Id
;
341 Project_Scan_State
: Saved_Project_Scan_State
;
342 Source_Index
: Source_File_Index
;
344 Modified_Project
: Project_Node_Id
:= Empty_Node
;
346 A_Project_Name_And_Node
: Tree_Private_Part
.Project_Name_And_Node
:=
347 Tree_Private_Part
.Projects_Htable
.Get_First
;
349 Name_From_Path
: constant Name_Id
:= Project_Name_From
(Path_Name
);
351 use Tree_Private_Part
;
354 Name_Len
:= Path_Name
'Length;
355 Name_Buffer
(1 .. Name_Len
) := Path_Name
;
356 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
357 Canonical_Path_Name
:= Name_Find
;
359 -- Check for a circular dependency
361 for Index
in 1 .. Project_Stack
.Last
loop
362 if Canonical_Path_Name
= Project_Stack
.Table
(Index
) then
363 Error_Msg
("circular dependency detected", Token_Ptr
);
364 Error_Msg_Name_1
:= Canonical_Path_Name
;
365 Error_Msg
("\ { is imported by", Token_Ptr
);
367 for Current
in reverse 1 .. Project_Stack
.Last
loop
368 Error_Msg_Name_1
:= Project_Stack
.Table
(Current
);
370 if Error_Msg_Name_1
/= Canonical_Path_Name
then
372 ("\ { which itself is imported by", Token_Ptr
);
375 Error_Msg
("\ {", Token_Ptr
);
380 Project
:= Empty_Node
;
385 Project_Stack
.Increment_Last
;
386 Project_Stack
.Table
(Project_Stack
.Last
) := Canonical_Path_Name
;
388 -- Check if the project file has already been parsed.
391 A_Project_Name_And_Node
/= Tree_Private_Part
.No_Project_Name_And_Node
394 Path_Name_Of
(A_Project_Name_And_Node
.Node
) = Canonical_Path_Name
398 if A_Project_Name_And_Node
.Modified
then
400 ("cannot modify the same project file several times",
405 ("cannot modify an imported project file",
409 elsif A_Project_Name_And_Node
.Modified
then
411 ("cannot imported a modified project file",
415 Project
:= A_Project_Name_And_Node
.Node
;
416 Project_Stack
.Decrement_Last
;
420 A_Project_Name_And_Node
:= Tree_Private_Part
.Projects_Htable
.Get_Next
;
423 -- We never encountered this project file
424 -- Save the scan state, load the project file and start to scan it.
426 Save_Project_Scan_State
(Project_Scan_State
);
427 Source_Index
:= Load_Project_File
(Path_Name
);
429 -- if we cannot find it, we stop
431 if Source_Index
= No_Source_File
then
432 Project
:= Empty_Node
;
433 Project_Stack
.Decrement_Last
;
437 Initialize_Scanner
(Types
.No_Unit
, Source_Index
);
439 if Name_From_Path
= No_Name
then
441 -- The project file name is not correct (no or bad extension,
442 -- or not following Ada identifier's syntax).
444 Error_Msg_Name_1
:= Canonical_Path_Name
;
445 Error_Msg
("?{ is not a valid path name for a project file",
449 if Current_Verbosity
>= Medium
then
450 Write_Str
("Parsing """);
451 Write_Str
(Path_Name
);
456 Project_Directory
:= Immediate_Directory_Of
(Canonical_Path_Name
);
457 Project
:= Default_Project_Node
(Of_Kind
=> N_Project
);
458 Set_Directory_Of
(Project
, Project_Directory
);
459 Set_Name_Of
(Project
, Simple_File_Name_Of
(Canonical_Path_Name
));
460 Set_Path_Name_Of
(Project
, Canonical_Path_Name
);
461 Set_Location_Of
(Project
, Token_Ptr
);
463 -- Is there any imported project?
466 First_With_Clause
: Project_Node_Id
:= Empty_Node
;
469 Parse_Context_Clause
(Context_Clause
=> First_With_Clause
,
470 Project_Directory
=> Project_Directory
);
471 Set_First_With_Clause_Of
(Project
, First_With_Clause
);
474 Expect
(Tok_Project
, "project");
476 -- Mark location of PROJECT token if present
478 if Token
= Tok_Project
then
479 Set_Location_Of
(Project
, Token_Ptr
);
480 Scan
; -- scan past project
483 Expect
(Tok_Identifier
, "identifier");
485 if Token
= Tok_Identifier
then
486 Set_Name_Of
(Project
, Token_Name
);
488 Get_Name_String
(Token_Name
);
489 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
492 Expected_Name
: constant Name_Id
:= Name_Find
;
495 if Name_From_Path
/= No_Name
496 and then Expected_Name
/= Name_From_Path
498 -- The project name is not the one that was expected from
499 -- the file name. Report a warning.
501 Error_Msg_Name_1
:= Expected_Name
;
502 Error_Msg
("?file name does not match unit name, " &
503 "should be `{" & Project_File_Extension
& "`",
509 Project_Name
: Name_Id
:=
510 Tree_Private_Part
.Projects_Htable
.Get_First
.Name
;
513 -- Check if we already have a project with this name
515 while Project_Name
/= No_Name
516 and then Project_Name
/= Token_Name
518 Project_Name
:= Tree_Private_Part
.Projects_Htable
.Get_Next
.Name
;
521 if Project_Name
/= No_Name
then
522 Error_Msg
("duplicate project name", Token_Ptr
);
525 Tree_Private_Part
.Projects_Htable
.Set
527 E
=> (Name
=> Token_Name
,
529 Modified
=> Modified
));
533 Scan
; -- scan past the project name
536 if Token
= Tok_Extends
then
538 -- We are extending another project
540 Scan
; -- scan past EXTENDS
541 Expect
(Tok_String_Literal
, "literal string");
543 if Token
= Tok_String_Literal
then
544 Set_Modified_Project_Path_Of
(Project
, Strval
(Token_Node
));
545 String_To_Name_Buffer
(Modified_Project_Path_Of
(Project
));
548 Original_Path_Name
: constant String :=
549 Name_Buffer
(1 .. Name_Len
);
551 Modified_Project_Path_Name
: constant String :=
555 (Project_Directory
));
558 if Modified_Project_Path_Name
= "" then
560 -- We could not find the project file to modify
562 Name_Len
:= Original_Path_Name
'Length;
563 Name_Buffer
(1 .. Name_Len
) := Original_Path_Name
;
564 Error_Msg_Name_1
:= Name_Find
;
566 Error_Msg
("unknown project file: {", Token_Ptr
);
568 -- If we are not in the main project file, display the
571 if Project_Stack
.Last
> 1 then
573 Project_Stack
.Table
(Project_Stack
.Last
);
574 Error_Msg
("\extended by {", Token_Ptr
);
576 for Index
in reverse 1 .. Project_Stack
.Last
- 1 loop
577 Error_Msg_Name_1
:= Project_Stack
.Table
(Index
);
578 Error_Msg
("\imported by {", Token_Ptr
);
584 (Project
=> Modified_Project
,
585 Path_Name
=> Modified_Project_Path_Name
,
590 Scan
; -- scan past the modified project path
594 Expect
(Tok_Is
, "is");
597 Project_Declaration
: Project_Node_Id
:= Empty_Node
;
600 -- No need to Scan past IS, Prj.Dect.Parse will do it.
603 (Declarations
=> Project_Declaration
,
604 Current_Project
=> Project
,
605 Extends
=> Modified_Project
);
606 Set_Project_Declaration_Of
(Project
, Project_Declaration
);
609 Expect
(Tok_End
, "end");
611 -- Skip END if present
613 if Token
= Tok_End
then
617 Expect
(Tok_Identifier
, "identifier");
619 if Token
= Tok_Identifier
then
621 -- We check if this is the project name
623 if To_Lower
(Get_Name_String
(Token_Name
)) /=
624 Get_Name_String
(Name_Of
(Project
))
626 Error_Msg
("Expected """ &
627 Get_Name_String
(Name_Of
(Project
)) & """",
632 if Token
/= Tok_Semicolon
then
636 Expect
(Tok_Semicolon
, ";");
638 -- Restore the scan state, in case we are not the main project
640 Restore_Project_Scan_State
(Project_Scan_State
);
642 Project_Stack
.Decrement_Last
;
643 end Parse_Single_Project
;
645 -----------------------
646 -- Project_Name_From --
647 -----------------------
649 function Project_Name_From
(Path_Name
: String) return Name_Id
is
650 Canonical
: String (1 .. Path_Name
'Length) := Path_Name
;
651 First
: Natural := Canonical
'Last;
652 Last
: Positive := First
;
659 Canonical_Case_File_Name
(Canonical
);
663 Canonical
(First
) /= '.'
668 if Canonical
(First
) = '.' then
669 if Canonical
(First
.. Last
) = Project_File_Extension
676 and then Canonical
(First
) /= '/'
677 and then Canonical
(First
) /= Dir_Sep
690 if Canonical
(First
) = '/'
691 or else Canonical
(First
) = Dir_Sep
696 Name_Len
:= Last
- First
+ 1;
697 Name_Buffer
(1 .. Name_Len
) := To_Lower
(Canonical
(First
.. Last
));
699 if not Is_Letter
(Name_Buffer
(1)) then
703 for Index
in 2 .. Name_Len
- 1 loop
704 if Name_Buffer
(Index
) = '_' then
705 if Name_Buffer
(Index
+ 1) = '_' then
709 elsif not Is_Alphanumeric
(Name_Buffer
(Index
)) then
715 if not Is_Alphanumeric
(Name_Buffer
(Name_Len
)) then
723 end Project_Name_From
;
725 --------------------------
726 -- Project_Path_Name_Of --
727 --------------------------
729 function Project_Path_Name_Of
730 (Project_File_Name
: String;
734 Result
: String_Access
;
737 -- First we try <file_name>.<extension>
739 if Current_Verbosity
= High
then
740 Write_Str
("Project_Path_Name_Of (""");
741 Write_Str
(Project_File_Name
);
742 Write_Str
(""", """);
743 Write_Str
(Directory
);
745 Write_Str
(" Trying ");
746 Write_Str
(Project_File_Name
);
747 Write_Line
(Project_File_Extension
);
752 (File_Name
=> Project_File_Name
& Project_File_Extension
,
753 Path
=> Project_Path
.all);
755 -- Then we try <file_name>
757 if Result
= null then
758 if Current_Verbosity
= High
then
759 Write_Str
(" Trying ");
760 Write_Line
(Project_File_Name
);
765 (File_Name
=> Project_File_Name
,
766 Path
=> Project_Path
.all);
768 -- The we try <directory>/<file_name>.<extension>
770 if Result
= null then
771 if Current_Verbosity
= High
then
772 Write_Str
(" Trying ");
773 Write_Str
(Directory
);
774 Write_Str
(Project_File_Name
);
775 Write_Line
(Project_File_Extension
);
780 (File_Name
=> Directory
& Project_File_Name
&
781 Project_File_Extension
,
782 Path
=> Project_Path
.all);
784 -- Then we try <directory>/<file_name>
786 if Result
= null then
787 if Current_Verbosity
= High
then
788 Write_Str
(" Trying ");
789 Write_Str
(Directory
);
790 Write_Line
(Project_File_Name
);
795 (File_Name
=> Directory
& Project_File_Name
,
796 Path
=> Project_Path
.all);
801 -- If we cannot find the project file, we return an empty string
803 if Result
= null then
808 Final_Result
: String
809 := GNAT
.OS_Lib
.Normalize_Pathname
(Result
.all);
812 Canonical_Case_File_Name
(Final_Result
);
818 end Project_Path_Name_Of
;
820 -------------------------
821 -- Simple_File_Name_Of --
822 -------------------------
824 function Simple_File_Name_Of
(Path_Name
: Name_Id
) return Name_Id
is
826 Get_Name_String
(Path_Name
);
828 for Index
in reverse 1 .. Name_Len
loop
829 if Name_Buffer
(Index
) = '/'
830 or else Name_Buffer
(Index
) = Dir_Sep
832 exit when Index
= Name_Len
;
833 Name_Buffer
(1 .. Name_Len
- Index
) :=
834 Name_Buffer
(Index
+ 1 .. Name_Len
);
835 Name_Len
:= Name_Len
- Index
;
842 end Simple_File_Name_Of
;
845 if Prj_Path
.all = "" then
846 Project_Path
:= new String'(".");
849 Project_Path := new String'("." & Path_Separator
& Prj_Path
.all);