1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2014, 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 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Ada.Characters.Handling; use Ada.Characters.Handling;
28 with Output; use Output;
31 package body Prj.PP is
35 Not_Tested : array (Project_Node_Kind) of Boolean := (others => True);
37 procedure Indicate_Tested (Kind : Project_Node_Kind);
38 -- Set the corresponding component of array Not_Tested to False. Only
39 -- called by Debug pragmas.
45 procedure Indicate_Tested (Kind : Project_Node_Kind) is
47 Not_Tested (Kind) := False;
54 procedure Pretty_Print
55 (Project : Prj.Tree.Project_Node_Id;
56 In_Tree : Prj.Tree.Project_Node_Tree_Ref;
57 Increment : Positive := 3;
58 Eliminate_Empty_Case_Constructions : Boolean := False;
59 Minimize_Empty_Lines : Boolean := False;
60 W_Char : Write_Char_Ap := null;
61 W_Eol : Write_Eol_Ap := null;
62 W_Str : Write_Str_Ap := null;
63 Backward_Compatibility : Boolean;
64 Id : Prj.Project_Id := Prj.No_Project;
65 Max_Line_Length : Max_Length_Of_Line :=
66 Max_Length_Of_Line'Last)
68 procedure Print (Node : Project_Node_Id; Indent : Natural);
69 -- A recursive procedure that traverses a project file tree and outputs
70 -- its source. Current_Prj is the project that we are printing. This
71 -- is used when printing attributes, since in nested packages they
72 -- need to use a fully qualified name.
74 procedure Output_Attribute_Name (Name : Name_Id; Indent : Natural);
75 -- Outputs an attribute name, taking into account the value of
76 -- Backward_Compatibility.
81 Capitalize : Boolean := True);
84 procedure Start_Line (Indent : Natural);
85 -- Outputs the indentation at the beginning of the line
87 procedure Output_Project_File (S : Name_Id);
88 -- Output a project file name in one single string literal
90 procedure Output_String (S : Name_Id; Indent : Natural);
91 -- Outputs a string using the default output procedures
93 procedure Write_Empty_Line (Always : Boolean := False);
94 -- Outputs an empty line, only if the previous line was not empty
95 -- already and either Always is True or Minimize_Empty_Lines is False.
97 procedure Write_Line (S : String);
98 -- Outputs S followed by a new line
100 procedure Write_String
103 Truncated : Boolean := False);
104 -- Outputs S using Write_Str, starting a new line if line would become
105 -- too long, when Truncated = False. When Truncated = True, only the
106 -- part of the string that can fit on the line is output.
108 procedure Write_End_Of_Line_Comment (Node : Project_Node_Id);
111 Write_Char : Write_Char_Ap := Output.Write_Char'Access;
112 Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access;
113 Write_Str : Write_Str_Ap := Output.Write_Str'Access;
114 -- These three access to procedure values are used for the output
116 Last_Line_Is_Empty : Boolean := False;
117 -- Used to avoid two consecutive empty lines
119 Column : Natural := 0;
120 -- Column number of the last character in the line. Used to avoid
121 -- outputting lines longer than Max_Line_Length.
123 First_With_In_List : Boolean := True;
124 -- Indicate that the next with clause is first in a list such as
126 -- First_With_In_List will be True for "A", but not for "B".
128 ---------------------------
129 -- Output_Attribute_Name --
130 ---------------------------
132 procedure Output_Attribute_Name (Name : Name_Id; Indent : Natural) is
134 if Backward_Compatibility then
136 when Snames.Name_Spec =>
137 Output_Name (Snames.Name_Specification, Indent);
139 when Snames.Name_Spec_Suffix =>
140 Output_Name (Snames.Name_Specification_Suffix, Indent);
142 when Snames.Name_Body =>
143 Output_Name (Snames.Name_Implementation, Indent);
145 when Snames.Name_Body_Suffix =>
146 Output_Name (Snames.Name_Implementation_Suffix, Indent);
149 Output_Name (Name, Indent);
153 Output_Name (Name, Indent);
155 end Output_Attribute_Name;
161 procedure Output_Name
164 Capitalize : Boolean := True)
166 Capital : Boolean := Capitalize;
169 if Column = 0 and then Indent /= 0 then
170 Start_Line (Indent + Increment);
173 Get_Name_String (Name);
175 -- If line would become too long, create new line
177 if Column + Name_Len > Max_Line_Length then
182 Start_Line (Indent + Increment);
186 for J in 1 .. Name_Len loop
188 Write_Char (To_Upper (Name_Buffer (J)));
190 Write_Char (Name_Buffer (J));
195 Name_Buffer (J) = '_'
196 or else Is_Digit (Name_Buffer (J));
200 Column := Column + Name_Len;
203 -------------------------
204 -- Output_Project_File --
205 -------------------------
207 procedure Output_Project_File (S : Name_Id) is
208 File_Name : constant String := Get_Name_String (S);
213 for J in File_Name'Range loop
214 if File_Name (J) = '"' then
218 Write_Char (File_Name (J));
223 end Output_Project_File;
229 procedure Output_String (S : Name_Id; Indent : Natural) is
231 if Column = 0 and then Indent /= 0 then
232 Start_Line (Indent + Increment);
237 -- If line could become too long, create new line. Note that the
238 -- number of characters on the line could be twice the number of
239 -- character in the string (if every character is a '"') plus two
240 -- (the initial and final '"').
242 if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
247 Start_Line (Indent + Increment);
252 Column := Column + 1;
255 for J in 1 .. Name_Len loop
256 if Name_Buffer (J) = '"' then
259 Column := Column + 2;
261 Write_Char (Name_Buffer (J));
262 Column := Column + 1;
265 -- If the string does not fit on one line, cut it in parts and
268 if J < Name_Len and then Column >= Max_Line_Length then
272 Start_Line (Indent + Increment);
274 Column := Column + 1;
279 Column := Column + 1;
286 procedure Start_Line (Indent : Natural) is
288 if not Minimize_Empty_Lines then
289 Write_Str ((1 .. Indent => ' '));
290 Column := Column + Indent;
294 ----------------------
295 -- Write_Empty_Line --
296 ----------------------
298 procedure Write_Empty_Line (Always : Boolean := False) is
300 if (Always or else not Minimize_Empty_Lines)
301 and then not Last_Line_Is_Empty
305 Last_Line_Is_Empty := True;
307 end Write_Empty_Line;
309 -------------------------------
310 -- Write_End_Of_Line_Comment --
311 -------------------------------
313 procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is
314 Value : constant Name_Id := End_Of_Line_Comment (Node, In_Tree);
317 if Value /= No_Name then
318 Write_String (" --", 0);
319 Write_String (Get_Name_String (Value), 0, Truncated => True);
323 end Write_End_Of_Line_Comment;
329 procedure Write_Line (S : String) is
332 Last_Line_Is_Empty := False;
341 procedure Write_String
344 Truncated : Boolean := False)
346 Length : Natural := S'Length;
349 if Column = 0 and then Indent /= 0 then
350 Start_Line (Indent + Increment);
353 -- If the string would not fit on the line, start a new line
355 if Column + Length > Max_Line_Length then
357 Length := Max_Line_Length - Column;
364 Start_Line (Indent + Increment);
369 Write_Str (S (S'First .. S'First + Length - 1));
370 Column := Column + Length;
377 procedure Print (Node : Project_Node_Id; Indent : Natural) is
379 if Present (Node) then
380 case Kind_Of (Node, In_Tree) is
382 pragma Debug (Indicate_Tested (N_Project));
383 if Present (First_With_Clause_Of (Node, In_Tree)) then
387 First_With_In_List := True;
388 Print (First_With_Clause_Of (Node, In_Tree), Indent);
389 Write_Empty_Line (Always => True);
392 Print (First_Comment_Before (Node, In_Tree), Indent);
395 case Project_Qualifier_Of (Node, In_Tree) is
396 when Unspecified | Standard =>
399 Write_String ("aggregate ", Indent);
400 when Aggregate_Library =>
401 Write_String ("aggregate library ", Indent);
403 Write_String ("library ", Indent);
404 when Configuration =>
405 Write_String ("configuration ", Indent);
406 when Abstract_Project =>
407 Write_String ("abstract ", Indent);
410 Write_String ("project ", Indent);
412 if Id /= Prj.No_Project then
413 Output_Name (Id.Display_Name, Indent);
415 Output_Name (Name_Of (Node, In_Tree), Indent);
418 -- Check if this project extends another project
420 if Extended_Project_Path_Of (Node, In_Tree) /= No_Path then
421 Write_String (" extends ", Indent);
423 if Is_Extending_All (Node, In_Tree) then
424 Write_String ("all ", Indent);
428 (Name_Id (Extended_Project_Path_Of (Node, In_Tree)));
431 Write_String (" is", Indent);
432 Write_End_Of_Line_Comment (Node);
434 (First_Comment_After (Node, In_Tree), Indent + Increment);
435 Write_Empty_Line (Always => True);
437 -- Output all of the declarations in the project
439 Print (Project_Declaration_Of (Node, In_Tree), Indent);
441 (First_Comment_Before_End (Node, In_Tree),
444 Write_String ("end ", Indent);
446 if Id /= Prj.No_Project then
447 Output_Name (Id.Display_Name, Indent);
449 Output_Name (Name_Of (Node, In_Tree), Indent);
453 Print (First_Comment_After_End (Node, In_Tree), Indent);
455 when N_With_Clause =>
456 pragma Debug (Indicate_Tested (N_With_Clause));
458 -- The with clause will sometimes contain an invalid name
459 -- when we are importing a virtual project from an extending
460 -- all project. Do not output anything in this case.
462 if Name_Of (Node, In_Tree) /= No_Name
463 and then String_Value_Of (Node, In_Tree) /= No_Name
465 if First_With_In_List then
466 Print (First_Comment_Before (Node, In_Tree), Indent);
469 if Non_Limited_Project_Node_Of (Node, In_Tree) =
472 Write_String ("limited ", Indent);
475 Write_String ("with ", Indent);
478 -- Output the project name without concatenation, even if
479 -- the line is too long.
481 Output_Project_File (String_Value_Of (Node, In_Tree));
483 if Is_Not_Last_In_List (Node, In_Tree) then
484 Write_String (", ", Indent);
485 First_With_In_List := False;
488 Write_String (";", Indent);
489 Write_End_Of_Line_Comment (Node);
490 Print (First_Comment_After (Node, In_Tree), Indent);
491 First_With_In_List := True;
495 Print (Next_With_Clause_Of (Node, In_Tree), Indent);
497 when N_Project_Declaration =>
498 pragma Debug (Indicate_Tested (N_Project_Declaration));
501 Present (First_Declarative_Item_Of (Node, In_Tree))
504 (First_Declarative_Item_Of (Node, In_Tree),
506 Write_Empty_Line (Always => True);
509 when N_Declarative_Item =>
510 pragma Debug (Indicate_Tested (N_Declarative_Item));
511 Print (Current_Item_Node (Node, In_Tree), Indent);
512 Print (Next_Declarative_Item (Node, In_Tree), Indent);
514 when N_Package_Declaration =>
515 pragma Debug (Indicate_Tested (N_Package_Declaration));
516 Write_Empty_Line (Always => True);
517 Print (First_Comment_Before (Node, In_Tree), Indent);
519 Write_String ("package ", Indent);
520 Output_Name (Name_Of (Node, In_Tree), Indent);
522 if Project_Of_Renamed_Package_Of (Node, In_Tree) /=
525 Write_String (" renames ", Indent);
528 (Project_Of_Renamed_Package_Of (Node, In_Tree),
531 Write_String (".", Indent);
532 Output_Name (Name_Of (Node, In_Tree), Indent);
533 Write_String (";", Indent);
534 Write_End_Of_Line_Comment (Node);
535 Print (First_Comment_After_End (Node, In_Tree), Indent);
538 Write_String (" is", Indent);
539 Write_End_Of_Line_Comment (Node);
540 Print (First_Comment_After (Node, In_Tree),
543 if First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node
546 (First_Declarative_Item_Of (Node, In_Tree),
550 Print (First_Comment_Before_End (Node, In_Tree),
553 Write_String ("end ", Indent);
554 Output_Name (Name_Of (Node, In_Tree), Indent);
556 Print (First_Comment_After_End (Node, In_Tree), Indent);
560 when N_String_Type_Declaration =>
561 pragma Debug (Indicate_Tested (N_String_Type_Declaration));
562 Print (First_Comment_Before (Node, In_Tree), Indent);
564 Write_String ("type ", Indent);
565 Output_Name (Name_Of (Node, In_Tree), Indent);
567 Start_Line (Indent + Increment);
568 Write_String ("(", Indent);
571 String_Node : Project_Node_Id :=
572 First_Literal_String (Node, In_Tree);
575 while Present (String_Node) loop
577 (String_Value_Of (String_Node, In_Tree), Indent);
579 Next_Literal_String (String_Node, In_Tree);
581 if Present (String_Node) then
582 Write_String (", ", Indent);
587 Write_String (");", Indent);
588 Write_End_Of_Line_Comment (Node);
589 Print (First_Comment_After (Node, In_Tree), Indent);
591 when N_Literal_String =>
592 pragma Debug (Indicate_Tested (N_Literal_String));
593 Output_String (String_Value_Of (Node, In_Tree), Indent);
595 if Source_Index_Of (Node, In_Tree) /= 0 then
596 Write_String (" at", Indent);
598 (Source_Index_Of (Node, In_Tree)'Img, Indent);
601 when N_Attribute_Declaration =>
602 pragma Debug (Indicate_Tested (N_Attribute_Declaration));
603 Print (First_Comment_Before (Node, In_Tree), Indent);
605 Write_String ("for ", Indent);
606 Output_Attribute_Name (Name_Of (Node, In_Tree), Indent);
608 if Associative_Array_Index_Of (Node, In_Tree) /= No_Name then
609 Write_String (" (", Indent);
611 (Associative_Array_Index_Of (Node, In_Tree), Indent);
613 if Source_Index_Of (Node, In_Tree) /= 0 then
614 Write_String (" at", Indent);
616 (Source_Index_Of (Node, In_Tree)'Img, Indent);
619 Write_String (")", Indent);
622 Write_String (" use ", Indent);
624 if Present (Expression_Of (Node, In_Tree)) then
625 Print (Expression_Of (Node, In_Tree), Indent);
628 -- Full associative array declaration
630 if Present (Associative_Project_Of (Node, In_Tree)) then
633 (Associative_Project_Of (Node, In_Tree),
637 if Present (Associative_Package_Of (Node, In_Tree))
639 Write_String (".", Indent);
642 (Associative_Package_Of (Node, In_Tree),
647 elsif Present (Associative_Package_Of (Node, In_Tree))
651 (Associative_Package_Of (Node, In_Tree),
656 Write_String ("'", Indent);
657 Output_Attribute_Name (Name_Of (Node, In_Tree), Indent);
660 Write_String (";", Indent);
661 Write_End_Of_Line_Comment (Node);
662 Print (First_Comment_After (Node, In_Tree), Indent);
664 when N_Typed_Variable_Declaration =>
666 (Indicate_Tested (N_Typed_Variable_Declaration));
667 Print (First_Comment_Before (Node, In_Tree), Indent);
669 Output_Name (Name_Of (Node, In_Tree), Indent);
670 Write_String (" : ", Indent);
672 (Name_Of (String_Type_Of (Node, In_Tree), In_Tree),
674 Write_String (" := ", Indent);
675 Print (Expression_Of (Node, In_Tree), Indent);
676 Write_String (";", Indent);
677 Write_End_Of_Line_Comment (Node);
678 Print (First_Comment_After (Node, In_Tree), Indent);
680 when N_Variable_Declaration =>
681 pragma Debug (Indicate_Tested (N_Variable_Declaration));
682 Print (First_Comment_Before (Node, In_Tree), Indent);
684 Output_Name (Name_Of (Node, In_Tree), Indent);
685 Write_String (" := ", Indent);
686 Print (Expression_Of (Node, In_Tree), Indent);
687 Write_String (";", Indent);
688 Write_End_Of_Line_Comment (Node);
689 Print (First_Comment_After (Node, In_Tree), Indent);
692 pragma Debug (Indicate_Tested (N_Expression));
694 Term : Project_Node_Id := First_Term (Node, In_Tree);
697 while Present (Term) loop
698 Print (Term, Indent);
699 Term := Next_Term (Term, In_Tree);
701 if Present (Term) then
702 Write_String (" & ", Indent);
708 pragma Debug (Indicate_Tested (N_Term));
709 Print (Current_Term (Node, In_Tree), Indent);
711 when N_Literal_String_List =>
712 pragma Debug (Indicate_Tested (N_Literal_String_List));
713 Write_String ("(", Indent);
716 Expression : Project_Node_Id :=
717 First_Expression_In_List (Node, In_Tree);
720 while Present (Expression) loop
721 Print (Expression, Indent);
723 Next_Expression_In_List (Expression, In_Tree);
725 if Present (Expression) then
726 Write_String (", ", Indent);
731 Write_String (")", Indent);
733 when N_Variable_Reference =>
734 pragma Debug (Indicate_Tested (N_Variable_Reference));
735 if Present (Project_Node_Of (Node, In_Tree)) then
737 (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree),
739 Write_String (".", Indent);
742 if Present (Package_Node_Of (Node, In_Tree)) then
744 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree),
746 Write_String (".", Indent);
749 Output_Name (Name_Of (Node, In_Tree), Indent);
751 when N_External_Value =>
752 pragma Debug (Indicate_Tested (N_External_Value));
753 Write_String ("external (", Indent);
754 Print (External_Reference_Of (Node, In_Tree), Indent);
756 if Present (External_Default_Of (Node, In_Tree)) then
757 Write_String (", ", Indent);
758 Print (External_Default_Of (Node, In_Tree), Indent);
761 Write_String (")", Indent);
763 when N_Attribute_Reference =>
764 pragma Debug (Indicate_Tested (N_Attribute_Reference));
766 if Present (Project_Node_Of (Node, In_Tree))
767 and then Project_Node_Of (Node, In_Tree) /= Project
770 (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree),
773 if Present (Package_Node_Of (Node, In_Tree)) then
774 Write_String (".", Indent);
776 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree),
780 elsif Present (Package_Node_Of (Node, In_Tree)) then
782 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree),
786 Write_String ("project", Indent);
789 Write_String ("'", Indent);
790 Output_Attribute_Name (Name_Of (Node, In_Tree), Indent);
793 Index : constant Name_Id :=
794 Associative_Array_Index_Of (Node, In_Tree);
796 if Index /= No_Name then
797 Write_String (" (", Indent);
798 Output_String (Index, Indent);
799 Write_String (")", Indent);
803 when N_Case_Construction =>
804 pragma Debug (Indicate_Tested (N_Case_Construction));
807 Case_Item : Project_Node_Id;
808 Is_Non_Empty : Boolean := False;
811 Case_Item := First_Case_Item_Of (Node, In_Tree);
812 while Present (Case_Item) loop
814 (First_Declarative_Item_Of (Case_Item, In_Tree))
815 or else not Eliminate_Empty_Case_Constructions
817 Is_Non_Empty := True;
821 Case_Item := Next_Case_Item (Case_Item, In_Tree);
826 Print (First_Comment_Before (Node, In_Tree), Indent);
828 Write_String ("case ", Indent);
830 (Case_Variable_Reference_Of (Node, In_Tree), Indent);
831 Write_String (" is", Indent);
832 Write_End_Of_Line_Comment (Node);
834 (First_Comment_After (Node, In_Tree),
838 Case_Item : Project_Node_Id :=
839 First_Case_Item_Of (Node, In_Tree);
841 while Present (Case_Item) loop
843 (Kind_Of (Case_Item, In_Tree) = N_Case_Item);
844 Print (Case_Item, Indent + Increment);
846 Next_Case_Item (Case_Item, In_Tree);
850 Print (First_Comment_Before_End (Node, In_Tree),
853 Write_Line ("end case;");
855 (First_Comment_After_End (Node, In_Tree), Indent);
860 pragma Debug (Indicate_Tested (N_Case_Item));
862 if Present (First_Declarative_Item_Of (Node, In_Tree))
863 or else not Eliminate_Empty_Case_Constructions
866 Print (First_Comment_Before (Node, In_Tree), Indent);
868 Write_String ("when ", Indent);
870 if No (First_Choice_Of (Node, In_Tree)) then
871 Write_String ("others", Indent);
875 Label : Project_Node_Id :=
876 First_Choice_Of (Node, In_Tree);
879 while Present (Label) loop
880 Print (Label, Indent);
881 Label := Next_Literal_String (Label, In_Tree);
883 if Present (Label) then
884 Write_String (" | ", Indent);
890 Write_String (" =>", Indent);
891 Write_End_Of_Line_Comment (Node);
893 (First_Comment_After (Node, In_Tree),
897 First : constant Project_Node_Id :=
898 First_Declarative_Item_Of (Node, In_Tree);
903 Print (First, Indent + Increment);
908 when N_Comment_Zones =>
910 -- Nothing to do, because it will not be processed directly
915 pragma Debug (Indicate_Tested (N_Comment));
917 if Follows_Empty_Line (Node, In_Tree) then
922 Write_String ("--", Indent);
924 (Get_Name_String (String_Value_Of (Node, In_Tree)),
929 if Is_Followed_By_Empty_Line (Node, In_Tree) then
933 Print (Next_Comment (Node, In_Tree), Indent);
938 -- Start of processing for Pretty_Print
941 if W_Char = null then
942 Write_Char := Output.Write_Char'Access;
944 Write_Char := W_Char;
948 Write_Eol := Output.Write_Eol'Access;
954 Write_Str := Output.Write_Str'Access;
962 -----------------------
963 -- Output_Statistics --
964 -----------------------
966 procedure Output_Statistics is
968 Output.Write_Line ("Project_Node_Kinds not tested:");
970 for Kind in Project_Node_Kind loop
971 if Kind /= N_Comment_Zones and then Not_Tested (Kind) then
972 Output.Write_Str (" ");
973 Output.Write_Line (Project_Node_Kind'Image (Kind));
978 end Output_Statistics;
985 (Project : Prj.Tree.Project_Node_Id;
986 In_Tree : Prj.Tree.Project_Node_Tree_Ref)
989 Pretty_Print (Project, In_Tree, Backward_Compatibility => False);