1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2008, 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 Max_Line_Length : constant := 255;
38 -- Maximum length of a line. This is chosen to be compatible with older
39 -- versions of GNAT that had a strict limit on the maximum line length.
41 Column : Natural := 0;
42 -- Column number of the last character in the line. Used to avoid
43 -- outputting lines longer than Max_Line_Length.
45 First_With_In_List : Boolean := True;
46 -- Indicate that the next with clause is first in a list such as
48 -- First_With_In_List will be True for "A", but not for "B".
50 procedure Indicate_Tested (Kind : Project_Node_Kind);
51 -- Set the corresponding component of array Not_Tested to False.
52 -- Only called by pragmas Debug.
58 procedure Indicate_Tested (Kind : Project_Node_Kind) is
60 Not_Tested (Kind) := False;
67 procedure Pretty_Print
68 (Project : Prj.Tree.Project_Node_Id;
69 In_Tree : Prj.Tree.Project_Node_Tree_Ref;
70 Increment : Positive := 3;
71 Eliminate_Empty_Case_Constructions : Boolean := False;
72 Minimize_Empty_Lines : Boolean := False;
73 W_Char : Write_Char_Ap := null;
74 W_Eol : Write_Eol_Ap := null;
75 W_Str : Write_Str_Ap := null;
76 Backward_Compatibility : Boolean;
77 Id : Prj.Project_Id := Prj.No_Project;
78 Id_Tree : Prj.Project_Tree_Ref := null)
80 procedure Print (Node : Project_Node_Id; Indent : Natural);
81 -- A recursive procedure that traverses a project file tree and outputs
82 -- its source. Current_Prj is the project that we are printing. This
83 -- is used when printing attributes, since in nested packages they
84 -- need to use a fully qualified name.
86 procedure Output_Attribute_Name (Name : Name_Id);
87 -- Outputs an attribute name, taking into account the value of
88 -- Backward_Compatibility.
90 procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True);
93 procedure Start_Line (Indent : Natural);
94 -- Outputs the indentation at the beginning of the line
96 procedure Output_String (S : Name_Id);
97 procedure Output_String (S : Path_Name_Type);
98 -- Outputs a string using the default output procedures
100 procedure Write_Empty_Line (Always : Boolean := False);
101 -- Outputs an empty line, only if the previous line was not empty
102 -- already and either Always is True or Minimize_Empty_Lines is False.
104 procedure Write_Line (S : String);
105 -- Outputs S followed by a new line
107 procedure Write_String (S : String; Truncated : Boolean := False);
108 -- Outputs S using Write_Str, starting a new line if line would
109 -- become too long, when Truncated = False.
110 -- When Truncated = True, only the part of the string that can fit on
111 -- the line is output.
113 procedure Write_End_Of_Line_Comment (Node : Project_Node_Id);
115 Write_Char : Write_Char_Ap := Output.Write_Char'Access;
116 Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access;
117 Write_Str : Write_Str_Ap := Output.Write_Str'Access;
118 -- These three access to procedure values are used for the output
120 Last_Line_Is_Empty : Boolean := False;
121 -- Used to avoid two consecutive empty lines
123 ---------------------------
124 -- Output_Attribute_Name --
125 ---------------------------
127 procedure Output_Attribute_Name (Name : Name_Id) is
129 if Backward_Compatibility then
131 when Snames.Name_Spec =>
132 Output_Name (Snames.Name_Specification);
134 when Snames.Name_Spec_Suffix =>
135 Output_Name (Snames.Name_Specification_Suffix);
137 when Snames.Name_Body =>
138 Output_Name (Snames.Name_Implementation);
140 when Snames.Name_Body_Suffix =>
141 Output_Name (Snames.Name_Implementation_Suffix);
150 end Output_Attribute_Name;
156 procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True) is
157 Capital : Boolean := Capitalize;
160 Get_Name_String (Name);
162 -- If line would become too long, create new line
164 if Column + Name_Len > Max_Line_Length then
169 for J in 1 .. Name_Len loop
171 Write_Char (To_Upper (Name_Buffer (J)));
173 Write_Char (Name_Buffer (J));
178 Name_Buffer (J) = '_'
179 or else Is_Digit (Name_Buffer (J));
183 Column := Column + Name_Len;
190 procedure Output_String (S : Name_Id) is
194 -- If line could become too long, create new line.
195 -- Note that the number of characters on the line could be
196 -- twice the number of character in the string (if every
197 -- character is a '"') plus two (the initial and final '"').
199 if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
205 Column := Column + 1;
208 for J in 1 .. Name_Len loop
209 if Name_Buffer (J) = '"' then
212 Column := Column + 2;
214 Write_Char (Name_Buffer (J));
215 Column := Column + 1;
218 -- If the string does not fit on one line, cut it in parts
221 if J < Name_Len and then Column >= Max_Line_Length then
230 Column := Column + 1;
233 procedure Output_String (S : Path_Name_Type) is
235 Output_String (Name_Id (S));
242 procedure Start_Line (Indent : Natural) is
244 if not Minimize_Empty_Lines then
245 Write_Str ((1 .. Indent => ' '));
246 Column := Column + Indent;
250 ----------------------
251 -- Write_Empty_Line --
252 ----------------------
254 procedure Write_Empty_Line (Always : Boolean := False) is
256 if (Always or else not Minimize_Empty_Lines)
257 and then not Last_Line_Is_Empty then
260 Last_Line_Is_Empty := True;
262 end Write_Empty_Line;
264 -------------------------------
265 -- Write_End_Of_Line_Comment --
266 -------------------------------
268 procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is
269 Value : constant Name_Id := End_Of_Line_Comment (Node, In_Tree);
272 if Value /= No_Name then
273 Write_String (" --");
274 Write_String (Get_Name_String (Value), Truncated => True);
278 end Write_End_Of_Line_Comment;
284 procedure Write_Line (S : String) is
287 Last_Line_Is_Empty := False;
296 procedure Write_String (S : String; Truncated : Boolean := False) is
297 Length : Natural := S'Length;
299 -- If the string would not fit on the line,
302 if Column + Length > Max_Line_Length then
304 Length := Max_Line_Length - Column;
312 Write_Str (S (S'First .. S'First + Length - 1));
313 Column := Column + Length;
320 procedure Print (Node : Project_Node_Id; Indent : Natural) is
322 if Node /= Empty_Node then
324 case Kind_Of (Node, In_Tree) is
327 pragma Debug (Indicate_Tested (N_Project));
328 if First_With_Clause_Of (Node, In_Tree) /= Empty_Node then
332 First_With_In_List := True;
333 Print (First_With_Clause_Of (Node, In_Tree), Indent);
334 Write_Empty_Line (Always => True);
337 Print (First_Comment_Before (Node, In_Tree), Indent);
339 Write_String ("project ");
341 if Id /= Prj.No_Project then
342 Output_Name (Id_Tree.Projects.Table (Id).Display_Name);
344 Output_Name (Name_Of (Node, In_Tree));
347 -- Check if this project extends another project
349 if Extended_Project_Path_Of (Node, In_Tree) /= No_Path then
350 Write_String (" extends ");
352 if Is_Extending_All (Node, In_Tree) then
353 Write_String ("all ");
356 Output_String (Extended_Project_Path_Of (Node, In_Tree));
359 Write_String (" is");
360 Write_End_Of_Line_Comment (Node);
362 (First_Comment_After (Node, In_Tree), Indent + Increment);
363 Write_Empty_Line (Always => True);
365 -- Output all of the declarations in the project
367 Print (Project_Declaration_Of (Node, In_Tree), Indent);
369 (First_Comment_Before_End (Node, In_Tree),
372 Write_String ("end ");
374 if Id /= Prj.No_Project then
375 Output_Name (Id_Tree.Projects.Table (Id).Display_Name);
377 Output_Name (Name_Of (Node, In_Tree));
381 Print (First_Comment_After_End (Node, In_Tree), Indent);
383 when N_With_Clause =>
384 pragma Debug (Indicate_Tested (N_With_Clause));
386 -- The with clause will sometimes contain an invalid name
387 -- when we are importing a virtual project from an
388 -- extending all project. Do not output anything in this
391 if Name_Of (Node, In_Tree) /= No_Name
392 and then String_Value_Of (Node, In_Tree) /= No_Name
394 if First_With_In_List then
395 Print (First_Comment_Before (Node, In_Tree), Indent);
398 if Non_Limited_Project_Node_Of (Node, In_Tree) =
401 Write_String ("limited ");
404 Write_String ("with ");
407 Output_String (String_Value_Of (Node, In_Tree));
409 if Is_Not_Last_In_List (Node, In_Tree) then
411 First_With_In_List := False;
415 Write_End_Of_Line_Comment (Node);
416 Print (First_Comment_After (Node, In_Tree), Indent);
417 First_With_In_List := True;
421 Print (Next_With_Clause_Of (Node, In_Tree), Indent);
423 when N_Project_Declaration =>
424 pragma Debug (Indicate_Tested (N_Project_Declaration));
427 First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node
430 (First_Declarative_Item_Of (Node, In_Tree),
432 Write_Empty_Line (Always => True);
435 when N_Declarative_Item =>
436 pragma Debug (Indicate_Tested (N_Declarative_Item));
437 Print (Current_Item_Node (Node, In_Tree), Indent);
438 Print (Next_Declarative_Item (Node, In_Tree), Indent);
440 when N_Package_Declaration =>
441 pragma Debug (Indicate_Tested (N_Package_Declaration));
442 Write_Empty_Line (Always => True);
443 Print (First_Comment_Before (Node, In_Tree), Indent);
445 Write_String ("package ");
446 Output_Name (Name_Of (Node, In_Tree));
448 if Project_Of_Renamed_Package_Of (Node, In_Tree) /=
451 Write_String (" renames ");
454 (Project_Of_Renamed_Package_Of (Node, In_Tree),
457 Output_Name (Name_Of (Node, In_Tree));
459 Write_End_Of_Line_Comment (Node);
460 Print (First_Comment_After_End (Node, In_Tree), Indent);
463 Write_String (" is");
464 Write_End_Of_Line_Comment (Node);
465 Print (First_Comment_After (Node, In_Tree),
468 if First_Declarative_Item_Of (Node, In_Tree) /=
472 (First_Declarative_Item_Of (Node, In_Tree),
476 Print (First_Comment_Before_End (Node, In_Tree),
479 Write_String ("end ");
480 Output_Name (Name_Of (Node, In_Tree));
482 Print (First_Comment_After_End (Node, In_Tree), Indent);
486 when N_String_Type_Declaration =>
487 pragma Debug (Indicate_Tested (N_String_Type_Declaration));
488 Print (First_Comment_Before (Node, In_Tree), Indent);
490 Write_String ("type ");
491 Output_Name (Name_Of (Node, In_Tree));
493 Start_Line (Indent + Increment);
497 String_Node : Project_Node_Id :=
498 First_Literal_String (Node, In_Tree);
501 while String_Node /= Empty_Node loop
502 Output_String (String_Value_Of (String_Node, In_Tree));
504 Next_Literal_String (String_Node, In_Tree);
506 if String_Node /= Empty_Node then
513 Write_End_Of_Line_Comment (Node);
514 Print (First_Comment_After (Node, In_Tree), Indent);
516 when N_Literal_String =>
517 pragma Debug (Indicate_Tested (N_Literal_String));
518 Output_String (String_Value_Of (Node, In_Tree));
520 if Source_Index_Of (Node, In_Tree) /= 0 then
521 Write_String (" at ");
522 Write_String (Source_Index_Of (Node, In_Tree)'Img);
525 when N_Attribute_Declaration =>
526 pragma Debug (Indicate_Tested (N_Attribute_Declaration));
527 Print (First_Comment_Before (Node, In_Tree), Indent);
529 Write_String ("for ");
530 Output_Attribute_Name (Name_Of (Node, In_Tree));
532 if Associative_Array_Index_Of (Node, In_Tree) /= No_Name then
535 (Associative_Array_Index_Of (Node, In_Tree));
537 if Source_Index_Of (Node, In_Tree) /= 0 then
538 Write_String (" at ");
539 Write_String (Source_Index_Of (Node, In_Tree)'Img);
545 Write_String (" use ");
546 Print (Expression_Of (Node, In_Tree), Indent);
548 Write_End_Of_Line_Comment (Node);
549 Print (First_Comment_After (Node, In_Tree), Indent);
551 when N_Typed_Variable_Declaration =>
553 (Indicate_Tested (N_Typed_Variable_Declaration));
554 Print (First_Comment_Before (Node, In_Tree), Indent);
556 Output_Name (Name_Of (Node, In_Tree));
557 Write_String (" : ");
559 (Name_Of (String_Type_Of (Node, In_Tree), In_Tree));
560 Write_String (" := ");
561 Print (Expression_Of (Node, In_Tree), Indent);
563 Write_End_Of_Line_Comment (Node);
564 Print (First_Comment_After (Node, In_Tree), Indent);
566 when N_Variable_Declaration =>
567 pragma Debug (Indicate_Tested (N_Variable_Declaration));
568 Print (First_Comment_Before (Node, In_Tree), Indent);
570 Output_Name (Name_Of (Node, In_Tree));
571 Write_String (" := ");
572 Print (Expression_Of (Node, In_Tree), Indent);
574 Write_End_Of_Line_Comment (Node);
575 Print (First_Comment_After (Node, In_Tree), Indent);
578 pragma Debug (Indicate_Tested (N_Expression));
580 Term : Project_Node_Id := First_Term (Node, In_Tree);
583 while Term /= Empty_Node loop
584 Print (Term, Indent);
585 Term := Next_Term (Term, In_Tree);
587 if Term /= Empty_Node then
588 Write_String (" & ");
594 pragma Debug (Indicate_Tested (N_Term));
595 Print (Current_Term (Node, In_Tree), Indent);
597 when N_Literal_String_List =>
598 pragma Debug (Indicate_Tested (N_Literal_String_List));
602 Expression : Project_Node_Id :=
603 First_Expression_In_List (Node, In_Tree);
606 while Expression /= Empty_Node loop
607 Print (Expression, Indent);
609 Next_Expression_In_List (Expression, In_Tree);
611 if Expression /= Empty_Node then
619 when N_Variable_Reference =>
620 pragma Debug (Indicate_Tested (N_Variable_Reference));
621 if Project_Node_Of (Node, In_Tree) /= Empty_Node then
623 (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree));
627 if Package_Node_Of (Node, In_Tree) /= Empty_Node then
629 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
633 Output_Name (Name_Of (Node, In_Tree));
635 when N_External_Value =>
636 pragma Debug (Indicate_Tested (N_External_Value));
637 Write_String ("external (");
638 Print (External_Reference_Of (Node, In_Tree), Indent);
640 if External_Default_Of (Node, In_Tree) /= Empty_Node then
642 Print (External_Default_Of (Node, In_Tree), Indent);
647 when N_Attribute_Reference =>
648 pragma Debug (Indicate_Tested (N_Attribute_Reference));
650 if Project_Node_Of (Node, In_Tree) /= Empty_Node
651 and then Project_Node_Of (Node, In_Tree) /= Project
654 (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree));
656 if Package_Node_Of (Node, In_Tree) /= Empty_Node then
659 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
662 elsif Package_Node_Of (Node, In_Tree) /= Empty_Node then
664 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
667 Write_String ("project");
671 Output_Attribute_Name (Name_Of (Node, In_Tree));
674 Index : constant Name_Id :=
675 Associative_Array_Index_Of (Node, In_Tree);
678 if Index /= No_Name then
680 Output_String (Index);
685 when N_Case_Construction =>
686 pragma Debug (Indicate_Tested (N_Case_Construction));
689 Case_Item : Project_Node_Id;
690 Is_Non_Empty : Boolean := False;
693 Case_Item := First_Case_Item_Of (Node, In_Tree);
694 while Case_Item /= Empty_Node loop
695 if First_Declarative_Item_Of (Case_Item, In_Tree) /=
697 or else not Eliminate_Empty_Case_Constructions
699 Is_Non_Empty := True;
703 Case_Item := Next_Case_Item (Case_Item, In_Tree);
708 Print (First_Comment_Before (Node, In_Tree), Indent);
710 Write_String ("case ");
712 (Case_Variable_Reference_Of (Node, In_Tree),
714 Write_String (" is");
715 Write_End_Of_Line_Comment (Node);
717 (First_Comment_After (Node, In_Tree),
721 Case_Item : Project_Node_Id :=
722 First_Case_Item_Of (Node, In_Tree);
724 while Case_Item /= Empty_Node loop
726 (Kind_Of (Case_Item, In_Tree) = N_Case_Item);
727 Print (Case_Item, Indent + Increment);
729 Next_Case_Item (Case_Item, In_Tree);
733 Print (First_Comment_Before_End (Node, In_Tree),
736 Write_Line ("end case;");
738 (First_Comment_After_End (Node, In_Tree), Indent);
743 pragma Debug (Indicate_Tested (N_Case_Item));
745 if First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node
746 or else not Eliminate_Empty_Case_Constructions
749 Print (First_Comment_Before (Node, In_Tree), Indent);
751 Write_String ("when ");
753 if First_Choice_Of (Node, In_Tree) = Empty_Node then
754 Write_String ("others");
758 Label : Project_Node_Id :=
759 First_Choice_Of (Node, In_Tree);
761 while Label /= Empty_Node loop
762 Print (Label, Indent);
763 Label := Next_Literal_String (Label, In_Tree);
765 if Label /= Empty_Node then
766 Write_String (" | ");
772 Write_String (" =>");
773 Write_End_Of_Line_Comment (Node);
775 (First_Comment_After (Node, In_Tree),
779 First : constant Project_Node_Id :=
780 First_Declarative_Item_Of (Node, In_Tree);
782 if First = Empty_Node then
785 Print (First, Indent + Increment);
790 when N_Comment_Zones =>
792 -- Nothing to do, because it will not be processed directly
797 pragma Debug (Indicate_Tested (N_Comment));
799 if Follows_Empty_Line (Node, In_Tree) then
806 (Get_Name_String (String_Value_Of (Node, In_Tree)),
810 if Is_Followed_By_Empty_Line (Node, In_Tree) then
814 Print (Next_Comment (Node, In_Tree), Indent);
819 -- Start of processing for Pretty_Print
822 if W_Char = null then
823 Write_Char := Output.Write_Char'Access;
825 Write_Char := W_Char;
829 Write_Eol := Output.Write_Eol'Access;
835 Write_Str := Output.Write_Str'Access;
842 if W_Char = null or else W_Str = null then
847 -----------------------
848 -- Output_Statistics --
849 -----------------------
851 procedure Output_Statistics is
853 Output.Write_Line ("Project_Node_Kinds not tested:");
855 for Kind in Project_Node_Kind loop
856 if Kind /= N_Comment_Zones and then Not_Tested (Kind) then
857 Output.Write_Str (" ");
858 Output.Write_Line (Project_Node_Kind'Image (Kind));
863 end Output_Statistics;