include/ChangeLog:
[official-gcc.git] / gcc / ada / prj-part.adb
blob114f18539b16944a2f8435640f4acd1701c51280
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P R J . P A R T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 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. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
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;
36 with Prj.Dect;
37 with Scans; use Scans;
38 with Scn; use Scn;
39 with Sinfo; use Sinfo;
40 with Sinput; use Sinput;
41 with Sinput.P; use Sinput.P;
42 with Stringt; use Stringt;
43 with Table;
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,
65 Table_Low_Bound => 1,
66 Table_Initial => 10,
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;
81 Path_Name : String;
82 Modified : Boolean);
83 -- Parse a project file.
84 -- Recursive procedure: it calls itself for imported and
85 -- modified projects.
87 function Project_Path_Name_Of
88 (Project_File_Name : String;
89 Directory : String)
90 return 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
113 begin
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
119 then
120 -- Remove from name all characters after the last
121 -- directory separator.
123 Name_Len := Index;
124 return Name_Find;
125 end if;
126 end loop;
128 -- There is no directory separator in name. Return "./" or ".\"
130 Name_Len := 2;
131 Name_Buffer (1) := '.';
132 Name_Buffer (2) := Dir_Sep;
133 return Name_Find;
134 end Immediate_Directory_Of;
136 -----------
137 -- Parse --
138 -----------
140 procedure Parse
141 (Project : out Project_Node_Id;
142 Project_File_Name : String;
143 Always_Errout_Finalize : Boolean)
145 Current_Directory : constant String := Get_Current_Dir;
147 begin
148 Project := Empty_Node;
150 if Current_Verbosity >= Medium then
151 Write_Str ("ADA_PROJECT_PATH=""");
152 Write_Str (Project_Path.all);
153 Write_Line ("""");
154 end if;
156 declare
157 Path_Name : constant String :=
158 Project_Path_Name_Of (Project_File_Name,
159 Directory => Current_Directory);
161 begin
162 Errout.Initialize;
164 -- Parse the main project file
166 if Path_Name = "" then
167 Fail ("project file """ & Project_File_Name & """ not found");
168 end if;
170 Parse_Single_Project
171 (Project => Project,
172 Path_Name => Path_Name,
173 Modified => False);
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;
180 end if;
182 if Project = Empty_Node or else Always_Errout_Finalize then
183 Errout.Finalize;
184 end if;
185 end;
187 exception
188 when X : others =>
190 -- Internal error
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;
197 end Parse;
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;
212 begin
213 -- Assume no context clause
215 Context_Clause := Empty_Node;
216 With_Loop :
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
222 Comma_Loop :
223 loop
224 Scan; -- scan past WITH or ","
226 Expect (Tok_String_Literal, "literal string");
228 if Token /= Tok_String_Literal then
229 return;
230 end if;
232 String_To_Name_Buffer (Strval (Token_Node));
234 declare
235 Original_Path : constant String :=
236 Name_Buffer (1 .. Name_Len);
238 Imported_Path_Name : constant String :=
239 Project_Path_Name_Of
240 (Original_Path,
241 Project_Directory_Path);
243 Withed_Project : Project_Node_Id := Empty_Node;
245 begin
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);
263 end loop;
264 end if;
266 else
267 -- New with clause
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;
277 else
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;
283 end if;
285 Set_String_Value_Of
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
293 Parse_Single_Project
294 (Project => Withed_Project,
295 Path_Name => Imported_Path_Name,
296 Modified => False);
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);
309 end if;
310 end if;
311 end;
313 Scan;
314 if Token = Tok_Semicolon then
316 -- End of (possibly multiple) with clause;
318 Scan; -- scan past the semicolon.
319 exit Comma_Loop;
321 elsif Token /= Tok_Comma then
322 Error_Msg ("expected comma or semi colon", Token_Ptr);
323 exit Comma_Loop;
324 end if;
325 end loop Comma_Loop;
326 end loop With_Loop;
328 end Parse_Context_Clause;
330 --------------------------
331 -- Parse_Single_Project --
332 --------------------------
334 procedure Parse_Single_Project
335 (Project : out Project_Node_Id;
336 Path_Name : String;
337 Modified : Boolean)
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;
353 begin
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
371 Error_Msg
372 ("\ { which itself is imported by", Token_Ptr);
374 else
375 Error_Msg ("\ {", Token_Ptr);
376 exit;
377 end if;
378 end loop;
380 Project := Empty_Node;
381 return;
382 end if;
383 end loop;
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.
390 while
391 A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node
392 loop
394 Path_Name_Of (A_Project_Name_And_Node.Node) = Canonical_Path_Name
395 then
396 if Modified then
398 if A_Project_Name_And_Node.Modified then
399 Error_Msg
400 ("cannot modify the same project file several times",
401 Token_Ptr);
403 else
404 Error_Msg
405 ("cannot modify an imported project file",
406 Token_Ptr);
407 end if;
409 elsif A_Project_Name_And_Node.Modified then
410 Error_Msg
411 ("cannot imported a modified project file",
412 Token_Ptr);
413 end if;
415 Project := A_Project_Name_And_Node.Node;
416 Project_Stack.Decrement_Last;
417 return;
418 end if;
420 A_Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_Next;
421 end loop;
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;
434 return;
435 end if;
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",
446 Token_Ptr);
447 end if;
449 if Current_Verbosity >= Medium then
450 Write_Str ("Parsing """);
451 Write_Str (Path_Name);
452 Write_Char ('"');
453 Write_Eol;
454 end if;
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?
465 declare
466 First_With_Clause : Project_Node_Id := Empty_Node;
468 begin
469 Parse_Context_Clause (Context_Clause => First_With_Clause,
470 Project_Directory => Project_Directory);
471 Set_First_With_Clause_Of (Project, First_With_Clause);
472 end;
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
481 end if;
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));
491 declare
492 Expected_Name : constant Name_Id := Name_Find;
494 begin
495 if Name_From_Path /= No_Name
496 and then Expected_Name /= Name_From_Path
497 then
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 & "`",
504 Token_Ptr);
505 end if;
506 end;
508 declare
509 Project_Name : Name_Id :=
510 Tree_Private_Part.Projects_Htable.Get_First.Name;
512 begin
513 -- Check if we already have a project with this name
515 while Project_Name /= No_Name
516 and then Project_Name /= Token_Name
517 loop
518 Project_Name := Tree_Private_Part.Projects_Htable.Get_Next.Name;
519 end loop;
521 if Project_Name /= No_Name then
522 Error_Msg ("duplicate project name", Token_Ptr);
524 else
525 Tree_Private_Part.Projects_Htable.Set
526 (K => Token_Name,
527 E => (Name => Token_Name,
528 Node => Project,
529 Modified => Modified));
530 end if;
531 end;
533 Scan; -- scan past the project name
534 end if;
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));
547 declare
548 Original_Path_Name : constant String :=
549 Name_Buffer (1 .. Name_Len);
551 Modified_Project_Path_Name : constant String :=
552 Project_Path_Name_Of
553 (Original_Path_Name,
554 Get_Name_String
555 (Project_Directory));
557 begin
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
569 -- import path.
571 if Project_Stack.Last > 1 then
572 Error_Msg_Name_1 :=
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);
579 end loop;
580 end if;
582 else
583 Parse_Single_Project
584 (Project => Modified_Project,
585 Path_Name => Modified_Project_Path_Name,
586 Modified => True);
587 end if;
588 end;
590 Scan; -- scan past the modified project path
591 end if;
592 end if;
594 Expect (Tok_Is, "is");
596 declare
597 Project_Declaration : Project_Node_Id := Empty_Node;
599 begin
600 -- No need to Scan past IS, Prj.Dect.Parse will do it.
602 Prj.Dect.Parse
603 (Declarations => Project_Declaration,
604 Current_Project => Project,
605 Extends => Modified_Project);
606 Set_Project_Declaration_Of (Project, Project_Declaration);
607 end;
609 Expect (Tok_End, "end");
611 -- Skip END if present
613 if Token = Tok_End then
614 Scan;
615 end if;
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))
625 then
626 Error_Msg ("Expected """ &
627 Get_Name_String (Name_Of (Project)) & """",
628 Token_Ptr);
629 end if;
630 end if;
632 if Token /= Tok_Semicolon then
633 Scan;
634 end if;
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;
654 begin
655 if First = 0 then
656 return No_Name;
657 end if;
659 Canonical_Case_File_Name (Canonical);
661 while First > 0
662 and then
663 Canonical (First) /= '.'
664 loop
665 First := First - 1;
666 end loop;
668 if Canonical (First) = '.' then
669 if Canonical (First .. Last) = Project_File_Extension
670 and then First /= 1
671 then
672 First := First - 1;
673 Last := First;
675 while First > 0
676 and then Canonical (First) /= '/'
677 and then Canonical (First) /= Dir_Sep
678 loop
679 First := First - 1;
680 end loop;
682 else
683 return No_Name;
684 end if;
686 else
687 return No_Name;
688 end if;
690 if Canonical (First) = '/'
691 or else Canonical (First) = Dir_Sep
692 then
693 First := First + 1;
694 end if;
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
700 return No_Name;
702 else
703 for Index in 2 .. Name_Len - 1 loop
704 if Name_Buffer (Index) = '_' then
705 if Name_Buffer (Index + 1) = '_' then
706 return No_Name;
707 end if;
709 elsif not Is_Alphanumeric (Name_Buffer (Index)) then
710 return No_Name;
711 end if;
713 end loop;
715 if not Is_Alphanumeric (Name_Buffer (Name_Len)) then
716 return No_Name;
718 else
719 return Name_Find;
720 end if;
722 end if;
723 end Project_Name_From;
725 --------------------------
726 -- Project_Path_Name_Of --
727 --------------------------
729 function Project_Path_Name_Of
730 (Project_File_Name : String;
731 Directory : String)
732 return String
734 Result : String_Access;
736 begin
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);
744 Write_Line (""");");
745 Write_Str (" Trying ");
746 Write_Str (Project_File_Name);
747 Write_Line (Project_File_Extension);
748 end if;
750 Result :=
751 Locate_Regular_File
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);
761 end if;
763 Result :=
764 Locate_Regular_File
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);
776 end if;
778 Result :=
779 Locate_Regular_File
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);
791 end if;
793 Result :=
794 Locate_Regular_File
795 (File_Name => Directory & Project_File_Name,
796 Path => Project_Path.all);
797 end if;
798 end if;
799 end if;
801 -- If we cannot find the project file, we return an empty string
803 if Result = null then
804 return "";
806 else
807 declare
808 Final_Result : String
809 := GNAT.OS_Lib.Normalize_Pathname (Result.all);
810 begin
811 Free (Result);
812 Canonical_Case_File_Name (Final_Result);
813 return Final_Result;
814 end;
816 end if;
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
825 begin
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
831 then
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;
836 return Name_Find;
837 end if;
838 end loop;
840 return No_Name;
842 end Simple_File_Name_Of;
844 begin
845 if Prj_Path.all = "" then
846 Project_Path := new String'(".");
848 else
849 Project_Path := new String'("." & Path_Separator & Prj_Path.all);
850 end if;
852 end Prj.Part;