1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2009, 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)
79 procedure Print (Node : Project_Node_Id; Indent : Natural);
80 -- A recursive procedure that traverses a project file tree and outputs
81 -- its source. Current_Prj is the project that we are printing. This
82 -- is used when printing attributes, since in nested packages they
83 -- need to use a fully qualified name.
85 procedure Output_Attribute_Name (Name : Name_Id);
86 -- Outputs an attribute name, taking into account the value of
87 -- Backward_Compatibility.
89 procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True);
92 procedure Start_Line (Indent : Natural);
93 -- Outputs the indentation at the beginning of the line
95 procedure Output_String (S : Name_Id);
96 procedure Output_String (S : Path_Name_Type);
97 -- Outputs a string using the default output procedures
99 procedure Write_Empty_Line (Always : Boolean := False);
100 -- Outputs an empty line, only if the previous line was not empty
101 -- already and either Always is True or Minimize_Empty_Lines is False.
103 procedure Write_Line (S : String);
104 -- Outputs S followed by a new line
106 procedure Write_String (S : String; Truncated : Boolean := False);
107 -- Outputs S using Write_Str, starting a new line if line would
108 -- become too long, when Truncated = False.
109 -- When Truncated = True, only the part of the string that can fit on
110 -- the line is output.
112 procedure Write_End_Of_Line_Comment (Node : Project_Node_Id);
114 Write_Char : Write_Char_Ap := Output.Write_Char'Access;
115 Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access;
116 Write_Str : Write_Str_Ap := Output.Write_Str'Access;
117 -- These three access to procedure values are used for the output
119 Last_Line_Is_Empty : Boolean := False;
120 -- Used to avoid two consecutive empty lines
122 ---------------------------
123 -- Output_Attribute_Name --
124 ---------------------------
126 procedure Output_Attribute_Name (Name : Name_Id) is
128 if Backward_Compatibility then
130 when Snames.Name_Spec =>
131 Output_Name (Snames.Name_Specification);
133 when Snames.Name_Spec_Suffix =>
134 Output_Name (Snames.Name_Specification_Suffix);
136 when Snames.Name_Body =>
137 Output_Name (Snames.Name_Implementation);
139 when Snames.Name_Body_Suffix =>
140 Output_Name (Snames.Name_Implementation_Suffix);
149 end Output_Attribute_Name;
155 procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True) is
156 Capital : Boolean := Capitalize;
159 Get_Name_String (Name);
161 -- If line would become too long, create new line
163 if Column + Name_Len > Max_Line_Length then
168 for J in 1 .. Name_Len loop
170 Write_Char (To_Upper (Name_Buffer (J)));
172 Write_Char (Name_Buffer (J));
177 Name_Buffer (J) = '_'
178 or else Is_Digit (Name_Buffer (J));
182 Column := Column + Name_Len;
189 procedure Output_String (S : Name_Id) is
193 -- If line could become too long, create new line.
194 -- Note that the number of characters on the line could be
195 -- twice the number of character in the string (if every
196 -- character is a '"') plus two (the initial and final '"').
198 if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
204 Column := Column + 1;
207 for J in 1 .. Name_Len loop
208 if Name_Buffer (J) = '"' then
211 Column := Column + 2;
213 Write_Char (Name_Buffer (J));
214 Column := Column + 1;
217 -- If the string does not fit on one line, cut it in parts
220 if J < Name_Len and then Column >= Max_Line_Length then
229 Column := Column + 1;
232 procedure Output_String (S : Path_Name_Type) is
234 Output_String (Name_Id (S));
241 procedure Start_Line (Indent : Natural) is
243 if not Minimize_Empty_Lines then
244 Write_Str ((1 .. Indent => ' '));
245 Column := Column + Indent;
249 ----------------------
250 -- Write_Empty_Line --
251 ----------------------
253 procedure Write_Empty_Line (Always : Boolean := False) is
255 if (Always or else not Minimize_Empty_Lines)
256 and then not Last_Line_Is_Empty then
259 Last_Line_Is_Empty := True;
261 end Write_Empty_Line;
263 -------------------------------
264 -- Write_End_Of_Line_Comment --
265 -------------------------------
267 procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is
268 Value : constant Name_Id := End_Of_Line_Comment (Node, In_Tree);
271 if Value /= No_Name then
272 Write_String (" --");
273 Write_String (Get_Name_String (Value), Truncated => True);
277 end Write_End_Of_Line_Comment;
283 procedure Write_Line (S : String) is
286 Last_Line_Is_Empty := False;
295 procedure Write_String (S : String; Truncated : Boolean := False) is
296 Length : Natural := S'Length;
298 -- If the string would not fit on the line,
301 if Column + Length > Max_Line_Length then
303 Length := Max_Line_Length - Column;
311 Write_Str (S (S'First .. S'First + Length - 1));
312 Column := Column + Length;
319 procedure Print (Node : Project_Node_Id; Indent : Natural) is
321 if Present (Node) then
323 case Kind_Of (Node, In_Tree) is
326 pragma Debug (Indicate_Tested (N_Project));
327 if Present (First_With_Clause_Of (Node, In_Tree)) then
331 First_With_In_List := True;
332 Print (First_With_Clause_Of (Node, In_Tree), Indent);
333 Write_Empty_Line (Always => True);
336 Print (First_Comment_Before (Node, In_Tree), Indent);
338 Write_String ("project ");
340 if Id /= Prj.No_Project then
341 Output_Name (Id.Display_Name);
343 Output_Name (Name_Of (Node, In_Tree));
346 -- Check if this project extends another project
348 if Extended_Project_Path_Of (Node, In_Tree) /= No_Path then
349 Write_String (" extends ");
351 if Is_Extending_All (Node, In_Tree) then
352 Write_String ("all ");
355 Output_String (Extended_Project_Path_Of (Node, In_Tree));
358 Write_String (" is");
359 Write_End_Of_Line_Comment (Node);
361 (First_Comment_After (Node, In_Tree), Indent + Increment);
362 Write_Empty_Line (Always => True);
364 -- Output all of the declarations in the project
366 Print (Project_Declaration_Of (Node, In_Tree), Indent);
368 (First_Comment_Before_End (Node, In_Tree),
371 Write_String ("end ");
373 if Id /= Prj.No_Project then
374 Output_Name (Id.Display_Name);
376 Output_Name (Name_Of (Node, In_Tree));
380 Print (First_Comment_After_End (Node, In_Tree), Indent);
382 when N_With_Clause =>
383 pragma Debug (Indicate_Tested (N_With_Clause));
385 -- The with clause will sometimes contain an invalid name
386 -- when we are importing a virtual project from an
387 -- extending all project. Do not output anything in this
390 if Name_Of (Node, In_Tree) /= No_Name
391 and then String_Value_Of (Node, In_Tree) /= No_Name
393 if First_With_In_List then
394 Print (First_Comment_Before (Node, In_Tree), Indent);
397 if Non_Limited_Project_Node_Of (Node, In_Tree) =
400 Write_String ("limited ");
403 Write_String ("with ");
406 Output_String (String_Value_Of (Node, In_Tree));
408 if Is_Not_Last_In_List (Node, In_Tree) then
410 First_With_In_List := False;
414 Write_End_Of_Line_Comment (Node);
415 Print (First_Comment_After (Node, In_Tree), Indent);
416 First_With_In_List := True;
420 Print (Next_With_Clause_Of (Node, In_Tree), Indent);
422 when N_Project_Declaration =>
423 pragma Debug (Indicate_Tested (N_Project_Declaration));
426 Present (First_Declarative_Item_Of (Node, In_Tree))
429 (First_Declarative_Item_Of (Node, In_Tree),
431 Write_Empty_Line (Always => True);
434 when N_Declarative_Item =>
435 pragma Debug (Indicate_Tested (N_Declarative_Item));
436 Print (Current_Item_Node (Node, In_Tree), Indent);
437 Print (Next_Declarative_Item (Node, In_Tree), Indent);
439 when N_Package_Declaration =>
440 pragma Debug (Indicate_Tested (N_Package_Declaration));
441 Write_Empty_Line (Always => True);
442 Print (First_Comment_Before (Node, In_Tree), Indent);
444 Write_String ("package ");
445 Output_Name (Name_Of (Node, In_Tree));
447 if Project_Of_Renamed_Package_Of (Node, In_Tree) /=
450 Write_String (" renames ");
453 (Project_Of_Renamed_Package_Of (Node, In_Tree),
456 Output_Name (Name_Of (Node, In_Tree));
458 Write_End_Of_Line_Comment (Node);
459 Print (First_Comment_After_End (Node, In_Tree), Indent);
462 Write_String (" is");
463 Write_End_Of_Line_Comment (Node);
464 Print (First_Comment_After (Node, In_Tree),
467 if First_Declarative_Item_Of (Node, In_Tree) /=
471 (First_Declarative_Item_Of (Node, In_Tree),
475 Print (First_Comment_Before_End (Node, In_Tree),
478 Write_String ("end ");
479 Output_Name (Name_Of (Node, In_Tree));
481 Print (First_Comment_After_End (Node, In_Tree), Indent);
485 when N_String_Type_Declaration =>
486 pragma Debug (Indicate_Tested (N_String_Type_Declaration));
487 Print (First_Comment_Before (Node, In_Tree), Indent);
489 Write_String ("type ");
490 Output_Name (Name_Of (Node, In_Tree));
492 Start_Line (Indent + Increment);
496 String_Node : Project_Node_Id :=
497 First_Literal_String (Node, In_Tree);
500 while Present (String_Node) loop
501 Output_String (String_Value_Of (String_Node, In_Tree));
503 Next_Literal_String (String_Node, In_Tree);
505 if Present (String_Node) then
512 Write_End_Of_Line_Comment (Node);
513 Print (First_Comment_After (Node, In_Tree), Indent);
515 when N_Literal_String =>
516 pragma Debug (Indicate_Tested (N_Literal_String));
517 Output_String (String_Value_Of (Node, In_Tree));
519 if Source_Index_Of (Node, In_Tree) /= 0 then
520 Write_String (" at");
521 Write_String (Source_Index_Of (Node, In_Tree)'Img);
524 when N_Attribute_Declaration =>
525 pragma Debug (Indicate_Tested (N_Attribute_Declaration));
526 Print (First_Comment_Before (Node, In_Tree), Indent);
528 Write_String ("for ");
529 Output_Attribute_Name (Name_Of (Node, In_Tree));
531 if Associative_Array_Index_Of (Node, In_Tree) /= No_Name then
534 (Associative_Array_Index_Of (Node, In_Tree));
536 if Source_Index_Of (Node, In_Tree) /= 0 then
537 Write_String (" at");
538 Write_String (Source_Index_Of (Node, In_Tree)'Img);
544 Write_String (" use ");
546 if Present (Expression_Of (Node, In_Tree)) then
547 Print (Expression_Of (Node, In_Tree), Indent);
550 -- Full associative array declaration
553 Present (Associative_Project_Of (Node, In_Tree))
557 (Associative_Project_Of (Node, In_Tree),
561 Present (Associative_Package_Of (Node, In_Tree))
566 (Associative_Package_Of (Node, In_Tree),
571 Present (Associative_Package_Of (Node, In_Tree))
575 (Associative_Package_Of (Node, In_Tree),
580 Output_Attribute_Name (Name_Of (Node, In_Tree));
584 Write_End_Of_Line_Comment (Node);
585 Print (First_Comment_After (Node, In_Tree), Indent);
587 when N_Typed_Variable_Declaration =>
589 (Indicate_Tested (N_Typed_Variable_Declaration));
590 Print (First_Comment_Before (Node, In_Tree), Indent);
592 Output_Name (Name_Of (Node, In_Tree));
593 Write_String (" : ");
595 (Name_Of (String_Type_Of (Node, In_Tree), In_Tree));
596 Write_String (" := ");
597 Print (Expression_Of (Node, In_Tree), Indent);
599 Write_End_Of_Line_Comment (Node);
600 Print (First_Comment_After (Node, In_Tree), Indent);
602 when N_Variable_Declaration =>
603 pragma Debug (Indicate_Tested (N_Variable_Declaration));
604 Print (First_Comment_Before (Node, In_Tree), Indent);
606 Output_Name (Name_Of (Node, In_Tree));
607 Write_String (" := ");
608 Print (Expression_Of (Node, In_Tree), Indent);
610 Write_End_Of_Line_Comment (Node);
611 Print (First_Comment_After (Node, In_Tree), Indent);
614 pragma Debug (Indicate_Tested (N_Expression));
616 Term : Project_Node_Id := First_Term (Node, In_Tree);
619 while Present (Term) loop
620 Print (Term, Indent);
621 Term := Next_Term (Term, In_Tree);
623 if Present (Term) then
624 Write_String (" & ");
630 pragma Debug (Indicate_Tested (N_Term));
631 Print (Current_Term (Node, In_Tree), Indent);
633 when N_Literal_String_List =>
634 pragma Debug (Indicate_Tested (N_Literal_String_List));
638 Expression : Project_Node_Id :=
639 First_Expression_In_List (Node, In_Tree);
642 while Present (Expression) loop
643 Print (Expression, Indent);
645 Next_Expression_In_List (Expression, In_Tree);
647 if Present (Expression) then
655 when N_Variable_Reference =>
656 pragma Debug (Indicate_Tested (N_Variable_Reference));
657 if Present (Project_Node_Of (Node, In_Tree)) then
659 (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree));
663 if Present (Package_Node_Of (Node, In_Tree)) then
665 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
669 Output_Name (Name_Of (Node, In_Tree));
671 when N_External_Value =>
672 pragma Debug (Indicate_Tested (N_External_Value));
673 Write_String ("external (");
674 Print (External_Reference_Of (Node, In_Tree), Indent);
676 if Present (External_Default_Of (Node, In_Tree)) then
678 Print (External_Default_Of (Node, In_Tree), Indent);
683 when N_Attribute_Reference =>
684 pragma Debug (Indicate_Tested (N_Attribute_Reference));
686 if Present (Project_Node_Of (Node, In_Tree))
687 and then Project_Node_Of (Node, In_Tree) /= Project
690 (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree));
692 if Present (Package_Node_Of (Node, In_Tree)) then
695 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
698 elsif Present (Package_Node_Of (Node, In_Tree)) then
700 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
703 Write_String ("project");
707 Output_Attribute_Name (Name_Of (Node, In_Tree));
710 Index : constant Name_Id :=
711 Associative_Array_Index_Of (Node, In_Tree);
714 if Index /= No_Name then
716 Output_String (Index);
721 when N_Case_Construction =>
722 pragma Debug (Indicate_Tested (N_Case_Construction));
725 Case_Item : Project_Node_Id;
726 Is_Non_Empty : Boolean := False;
729 Case_Item := First_Case_Item_Of (Node, In_Tree);
730 while Present (Case_Item) loop
732 (First_Declarative_Item_Of (Case_Item, In_Tree))
733 or else not Eliminate_Empty_Case_Constructions
735 Is_Non_Empty := True;
739 Case_Item := Next_Case_Item (Case_Item, In_Tree);
744 Print (First_Comment_Before (Node, In_Tree), Indent);
746 Write_String ("case ");
748 (Case_Variable_Reference_Of (Node, In_Tree),
750 Write_String (" is");
751 Write_End_Of_Line_Comment (Node);
753 (First_Comment_After (Node, In_Tree),
757 Case_Item : Project_Node_Id :=
758 First_Case_Item_Of (Node, In_Tree);
760 while Present (Case_Item) loop
762 (Kind_Of (Case_Item, In_Tree) = N_Case_Item);
763 Print (Case_Item, Indent + Increment);
765 Next_Case_Item (Case_Item, In_Tree);
769 Print (First_Comment_Before_End (Node, In_Tree),
772 Write_Line ("end case;");
774 (First_Comment_After_End (Node, In_Tree), Indent);
779 pragma Debug (Indicate_Tested (N_Case_Item));
781 if Present (First_Declarative_Item_Of (Node, In_Tree))
782 or else not Eliminate_Empty_Case_Constructions
785 Print (First_Comment_Before (Node, In_Tree), Indent);
787 Write_String ("when ");
789 if No (First_Choice_Of (Node, In_Tree)) then
790 Write_String ("others");
794 Label : Project_Node_Id :=
795 First_Choice_Of (Node, In_Tree);
797 while Present (Label) loop
798 Print (Label, Indent);
799 Label := Next_Literal_String (Label, In_Tree);
801 if Present (Label) then
802 Write_String (" | ");
808 Write_String (" =>");
809 Write_End_Of_Line_Comment (Node);
811 (First_Comment_After (Node, In_Tree),
815 First : constant Project_Node_Id :=
816 First_Declarative_Item_Of (Node, In_Tree);
821 Print (First, Indent + Increment);
826 when N_Comment_Zones =>
828 -- Nothing to do, because it will not be processed directly
833 pragma Debug (Indicate_Tested (N_Comment));
835 if Follows_Empty_Line (Node, In_Tree) then
842 (Get_Name_String (String_Value_Of (Node, In_Tree)),
846 if Is_Followed_By_Empty_Line (Node, In_Tree) then
850 Print (Next_Comment (Node, In_Tree), Indent);
855 -- Start of processing for Pretty_Print
858 if W_Char = null then
859 Write_Char := Output.Write_Char'Access;
861 Write_Char := W_Char;
865 Write_Eol := Output.Write_Eol'Access;
871 Write_Str := Output.Write_Str'Access;
878 if W_Char = null or else W_Str = null then
883 -----------------------
884 -- Output_Statistics --
885 -----------------------
887 procedure Output_Statistics is
889 Output.Write_Line ("Project_Node_Kinds not tested:");
891 for Kind in Project_Node_Kind loop
892 if Kind /= N_Comment_Zones and then Not_Tested (Kind) then
893 Output.Write_Str (" ");
894 Output.Write_Line (Project_Node_Kind'Image (Kind));
899 end Output_Statistics;