1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2007, 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 -- outputing 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)
78 procedure Print (Node : Project_Node_Id; Indent : Natural);
79 -- A recursive procedure that traverses a project file tree and outputs
80 -- its source. Current_Prj is the project that we are printing. This
81 -- is used when printing attributes, since in nested packages they
82 -- need to use a fully qualified name.
84 procedure Output_Attribute_Name (Name : Name_Id);
85 -- Outputs an attribute name, taking into account the value of
86 -- Backward_Compatibility.
88 procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True);
91 procedure Start_Line (Indent : Natural);
92 -- Outputs the indentation at the beginning of the line
94 procedure Output_String (S : Name_Id);
95 procedure Output_String (S : Path_Name_Type);
96 -- Outputs a string using the default output procedures
98 procedure Write_Empty_Line (Always : Boolean := False);
99 -- Outputs an empty line, only if the previous line was not empty
100 -- already and either Always is True or Minimize_Empty_Lines is False.
102 procedure Write_Line (S : String);
103 -- Outputs S followed by a new line
105 procedure Write_String (S : String; Truncated : Boolean := False);
106 -- Outputs S using Write_Str, starting a new line if line would
107 -- become too long, when Truncated = False.
108 -- When Truncated = True, only the part of the string that can fit on
109 -- the line is output.
111 procedure Write_End_Of_Line_Comment (Node : Project_Node_Id);
113 Write_Char : Write_Char_Ap := Output.Write_Char'Access;
114 Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access;
115 Write_Str : Write_Str_Ap := Output.Write_Str'Access;
116 -- These three access to procedure values are used for the output
118 Last_Line_Is_Empty : Boolean := False;
119 -- Used to avoid two consecutive empty lines
121 ---------------------------
122 -- Output_Attribute_Name --
123 ---------------------------
125 procedure Output_Attribute_Name (Name : Name_Id) is
127 if Backward_Compatibility then
129 when Snames.Name_Spec =>
130 Output_Name (Snames.Name_Specification);
132 when Snames.Name_Spec_Suffix =>
133 Output_Name (Snames.Name_Specification_Suffix);
135 when Snames.Name_Body =>
136 Output_Name (Snames.Name_Implementation);
138 when Snames.Name_Body_Suffix =>
139 Output_Name (Snames.Name_Implementation_Suffix);
148 end Output_Attribute_Name;
154 procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True) is
155 Capital : Boolean := Capitalize;
158 Get_Name_String (Name);
160 -- If line would become too long, create new line
162 if Column + Name_Len > Max_Line_Length then
167 for J in 1 .. Name_Len loop
169 Write_Char (To_Upper (Name_Buffer (J)));
171 Write_Char (Name_Buffer (J));
176 Name_Buffer (J) = '_'
177 or else Is_Digit (Name_Buffer (J));
181 Column := Column + Name_Len;
188 procedure Output_String (S : Name_Id) is
192 -- If line could become too long, create new line.
193 -- Note that the number of characters on the line could be
194 -- twice the number of character in the string (if every
195 -- character is a '"') plus two (the initial and final '"').
197 if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
203 Column := Column + 1;
206 for J in 1 .. Name_Len loop
207 if Name_Buffer (J) = '"' then
210 Column := Column + 2;
212 Write_Char (Name_Buffer (J));
213 Column := Column + 1;
216 -- If the string does not fit on one line, cut it in parts
219 if J < Name_Len and then Column >= Max_Line_Length then
228 Column := Column + 1;
231 procedure Output_String (S : Path_Name_Type) is
233 Output_String (Name_Id (S));
240 procedure Start_Line (Indent : Natural) is
242 if not Minimize_Empty_Lines then
243 Write_Str ((1 .. Indent => ' '));
244 Column := Column + Indent;
248 ----------------------
249 -- Write_Empty_Line --
250 ----------------------
252 procedure Write_Empty_Line (Always : Boolean := False) is
254 if (Always or else not Minimize_Empty_Lines)
255 and then not Last_Line_Is_Empty then
258 Last_Line_Is_Empty := True;
260 end Write_Empty_Line;
262 -------------------------------
263 -- Write_End_Of_Line_Comment --
264 -------------------------------
266 procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is
267 Value : constant Name_Id := End_Of_Line_Comment (Node, In_Tree);
270 if Value /= No_Name then
271 Write_String (" --");
272 Write_String (Get_Name_String (Value), Truncated => True);
276 end Write_End_Of_Line_Comment;
282 procedure Write_Line (S : String) is
285 Last_Line_Is_Empty := False;
294 procedure Write_String (S : String; Truncated : Boolean := False) is
295 Length : Natural := S'Length;
297 -- If the string would not fit on the line,
300 if Column + Length > Max_Line_Length then
302 Length := Max_Line_Length - Column;
310 Write_Str (S (S'First .. S'First + Length - 1));
311 Column := Column + Length;
318 procedure Print (Node : Project_Node_Id; Indent : Natural) is
320 if Node /= Empty_Node then
322 case Kind_Of (Node, In_Tree) is
325 pragma Debug (Indicate_Tested (N_Project));
326 if First_With_Clause_Of (Node, In_Tree) /= Empty_Node then
330 First_With_In_List := True;
331 Print (First_With_Clause_Of (Node, In_Tree), Indent);
332 Write_Empty_Line (Always => True);
335 Print (First_Comment_Before (Node, In_Tree), Indent);
337 Write_String ("project ");
338 Output_Name (Name_Of (Node, In_Tree));
340 -- Check if this project extends another project
342 if Extended_Project_Path_Of (Node, In_Tree) /= No_Path then
343 Write_String (" extends ");
345 if Is_Extending_All (Node, In_Tree) then
346 Write_String ("all ");
349 Output_String (Extended_Project_Path_Of (Node, In_Tree));
352 Write_String (" is");
353 Write_End_Of_Line_Comment (Node);
355 (First_Comment_After (Node, In_Tree), Indent + Increment);
356 Write_Empty_Line (Always => True);
358 -- Output all of the declarations in the project
360 Print (Project_Declaration_Of (Node, In_Tree), Indent);
362 (First_Comment_Before_End (Node, In_Tree),
365 Write_String ("end ");
366 Output_Name (Name_Of (Node, In_Tree));
368 Print (First_Comment_After_End (Node, In_Tree), Indent);
370 when N_With_Clause =>
371 pragma Debug (Indicate_Tested (N_With_Clause));
373 -- The with clause will sometimes contain an invalid name
374 -- when we are importing a virtual project from an
375 -- extending all project. Do not output anything in this
378 if Name_Of (Node, In_Tree) /= No_Name
379 and then String_Value_Of (Node, In_Tree) /= No_Name
381 if First_With_In_List then
382 Print (First_Comment_Before (Node, In_Tree), Indent);
385 if Non_Limited_Project_Node_Of (Node, In_Tree) =
388 Write_String ("limited ");
391 Write_String ("with ");
394 Output_String (String_Value_Of (Node, In_Tree));
396 if Is_Not_Last_In_List (Node, In_Tree) then
398 First_With_In_List := False;
402 Write_End_Of_Line_Comment (Node);
403 Print (First_Comment_After (Node, In_Tree), Indent);
404 First_With_In_List := True;
408 Print (Next_With_Clause_Of (Node, In_Tree), Indent);
410 when N_Project_Declaration =>
411 pragma Debug (Indicate_Tested (N_Project_Declaration));
414 First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node
417 (First_Declarative_Item_Of (Node, In_Tree),
419 Write_Empty_Line (Always => True);
422 when N_Declarative_Item =>
423 pragma Debug (Indicate_Tested (N_Declarative_Item));
424 Print (Current_Item_Node (Node, In_Tree), Indent);
425 Print (Next_Declarative_Item (Node, In_Tree), Indent);
427 when N_Package_Declaration =>
428 pragma Debug (Indicate_Tested (N_Package_Declaration));
429 Write_Empty_Line (Always => True);
430 Print (First_Comment_Before (Node, In_Tree), Indent);
432 Write_String ("package ");
433 Output_Name (Name_Of (Node, In_Tree));
435 if Project_Of_Renamed_Package_Of (Node, In_Tree) /=
438 Write_String (" renames ");
441 (Project_Of_Renamed_Package_Of (Node, In_Tree),
444 Output_Name (Name_Of (Node, In_Tree));
446 Write_End_Of_Line_Comment (Node);
447 Print (First_Comment_After_End (Node, In_Tree), Indent);
450 Write_String (" is");
451 Write_End_Of_Line_Comment (Node);
452 Print (First_Comment_After (Node, In_Tree),
455 if First_Declarative_Item_Of (Node, In_Tree) /=
459 (First_Declarative_Item_Of (Node, In_Tree),
463 Print (First_Comment_Before_End (Node, In_Tree),
466 Write_String ("end ");
467 Output_Name (Name_Of (Node, In_Tree));
469 Print (First_Comment_After_End (Node, In_Tree), Indent);
473 when N_String_Type_Declaration =>
474 pragma Debug (Indicate_Tested (N_String_Type_Declaration));
475 Print (First_Comment_Before (Node, In_Tree), Indent);
477 Write_String ("type ");
478 Output_Name (Name_Of (Node, In_Tree));
480 Start_Line (Indent + Increment);
484 String_Node : Project_Node_Id :=
485 First_Literal_String (Node, In_Tree);
488 while String_Node /= Empty_Node loop
489 Output_String (String_Value_Of (String_Node, In_Tree));
491 Next_Literal_String (String_Node, In_Tree);
493 if String_Node /= Empty_Node then
500 Write_End_Of_Line_Comment (Node);
501 Print (First_Comment_After (Node, In_Tree), Indent);
503 when N_Literal_String =>
504 pragma Debug (Indicate_Tested (N_Literal_String));
505 Output_String (String_Value_Of (Node, In_Tree));
507 if Source_Index_Of (Node, In_Tree) /= 0 then
508 Write_String (" at ");
509 Write_String (Source_Index_Of (Node, In_Tree)'Img);
512 when N_Attribute_Declaration =>
513 pragma Debug (Indicate_Tested (N_Attribute_Declaration));
514 Print (First_Comment_Before (Node, In_Tree), Indent);
516 Write_String ("for ");
517 Output_Attribute_Name (Name_Of (Node, In_Tree));
519 if Associative_Array_Index_Of (Node, In_Tree) /= No_Name then
522 (Associative_Array_Index_Of (Node, In_Tree));
524 if Source_Index_Of (Node, In_Tree) /= 0 then
525 Write_String (" at ");
526 Write_String (Source_Index_Of (Node, In_Tree)'Img);
532 Write_String (" use ");
533 Print (Expression_Of (Node, In_Tree), Indent);
535 Write_End_Of_Line_Comment (Node);
536 Print (First_Comment_After (Node, In_Tree), Indent);
538 when N_Typed_Variable_Declaration =>
540 (Indicate_Tested (N_Typed_Variable_Declaration));
541 Print (First_Comment_Before (Node, In_Tree), Indent);
543 Output_Name (Name_Of (Node, In_Tree));
544 Write_String (" : ");
546 (Name_Of (String_Type_Of (Node, In_Tree), In_Tree));
547 Write_String (" := ");
548 Print (Expression_Of (Node, In_Tree), Indent);
550 Write_End_Of_Line_Comment (Node);
551 Print (First_Comment_After (Node, In_Tree), Indent);
553 when N_Variable_Declaration =>
554 pragma Debug (Indicate_Tested (N_Variable_Declaration));
555 Print (First_Comment_Before (Node, In_Tree), Indent);
557 Output_Name (Name_Of (Node, In_Tree));
558 Write_String (" := ");
559 Print (Expression_Of (Node, In_Tree), Indent);
561 Write_End_Of_Line_Comment (Node);
562 Print (First_Comment_After (Node, In_Tree), Indent);
565 pragma Debug (Indicate_Tested (N_Expression));
567 Term : Project_Node_Id := First_Term (Node, In_Tree);
570 while Term /= Empty_Node loop
571 Print (Term, Indent);
572 Term := Next_Term (Term, In_Tree);
574 if Term /= Empty_Node then
575 Write_String (" & ");
581 pragma Debug (Indicate_Tested (N_Term));
582 Print (Current_Term (Node, In_Tree), Indent);
584 when N_Literal_String_List =>
585 pragma Debug (Indicate_Tested (N_Literal_String_List));
589 Expression : Project_Node_Id :=
590 First_Expression_In_List (Node, In_Tree);
593 while Expression /= Empty_Node loop
594 Print (Expression, Indent);
596 Next_Expression_In_List (Expression, In_Tree);
598 if Expression /= Empty_Node then
606 when N_Variable_Reference =>
607 pragma Debug (Indicate_Tested (N_Variable_Reference));
608 if Project_Node_Of (Node, In_Tree) /= Empty_Node then
610 (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree));
614 if Package_Node_Of (Node, In_Tree) /= Empty_Node then
616 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
620 Output_Name (Name_Of (Node, In_Tree));
622 when N_External_Value =>
623 pragma Debug (Indicate_Tested (N_External_Value));
624 Write_String ("external (");
625 Print (External_Reference_Of (Node, In_Tree), Indent);
627 if External_Default_Of (Node, In_Tree) /= Empty_Node then
629 Print (External_Default_Of (Node, In_Tree), Indent);
634 when N_Attribute_Reference =>
635 pragma Debug (Indicate_Tested (N_Attribute_Reference));
637 if Project_Node_Of (Node, In_Tree) /= Empty_Node
638 and then Project_Node_Of (Node, In_Tree) /= Project
641 (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree));
643 if Package_Node_Of (Node, In_Tree) /= Empty_Node then
646 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
649 elsif Package_Node_Of (Node, In_Tree) /= Empty_Node then
651 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
654 Write_String ("project");
658 Output_Attribute_Name (Name_Of (Node, In_Tree));
661 Index : constant Name_Id :=
662 Associative_Array_Index_Of (Node, In_Tree);
665 if Index /= No_Name then
667 Output_String (Index);
672 when N_Case_Construction =>
673 pragma Debug (Indicate_Tested (N_Case_Construction));
676 Case_Item : Project_Node_Id;
677 Is_Non_Empty : Boolean := False;
680 Case_Item := First_Case_Item_Of (Node, In_Tree);
681 while Case_Item /= Empty_Node loop
682 if First_Declarative_Item_Of (Case_Item, In_Tree) /=
684 or else not Eliminate_Empty_Case_Constructions
686 Is_Non_Empty := True;
690 Case_Item := Next_Case_Item (Case_Item, In_Tree);
695 Print (First_Comment_Before (Node, In_Tree), Indent);
697 Write_String ("case ");
699 (Case_Variable_Reference_Of (Node, In_Tree),
701 Write_String (" is");
702 Write_End_Of_Line_Comment (Node);
704 (First_Comment_After (Node, In_Tree),
708 Case_Item : Project_Node_Id :=
709 First_Case_Item_Of (Node, In_Tree);
711 while Case_Item /= Empty_Node loop
713 (Kind_Of (Case_Item, In_Tree) = N_Case_Item);
714 Print (Case_Item, Indent + Increment);
716 Next_Case_Item (Case_Item, In_Tree);
720 Print (First_Comment_Before_End (Node, In_Tree),
723 Write_Line ("end case;");
725 (First_Comment_After_End (Node, In_Tree), Indent);
730 pragma Debug (Indicate_Tested (N_Case_Item));
732 if First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node
733 or else not Eliminate_Empty_Case_Constructions
736 Print (First_Comment_Before (Node, In_Tree), Indent);
738 Write_String ("when ");
740 if First_Choice_Of (Node, In_Tree) = Empty_Node then
741 Write_String ("others");
745 Label : Project_Node_Id :=
746 First_Choice_Of (Node, In_Tree);
748 while Label /= Empty_Node loop
749 Print (Label, Indent);
750 Label := Next_Literal_String (Label, In_Tree);
752 if Label /= Empty_Node then
753 Write_String (" | ");
759 Write_String (" =>");
760 Write_End_Of_Line_Comment (Node);
762 (First_Comment_After (Node, In_Tree),
766 First : constant Project_Node_Id :=
767 First_Declarative_Item_Of (Node, In_Tree);
769 if First = Empty_Node then
772 Print (First, Indent + Increment);
777 when N_Comment_Zones =>
779 -- Nothing to do, because it will not be processed directly
784 pragma Debug (Indicate_Tested (N_Comment));
786 if Follows_Empty_Line (Node, In_Tree) then
793 (Get_Name_String (String_Value_Of (Node, In_Tree)),
797 if Is_Followed_By_Empty_Line (Node, In_Tree) then
801 Print (Next_Comment (Node, In_Tree), Indent);
806 -- Start of processing for Pretty_Print
809 if W_Char = null then
810 Write_Char := Output.Write_Char'Access;
812 Write_Char := W_Char;
816 Write_Eol := Output.Write_Eol'Access;
822 Write_Str := Output.Write_Str'Access;
829 if W_Char = null or else W_Str = null then
834 -----------------------
835 -- Output_Statistics --
836 -----------------------
838 procedure Output_Statistics is
840 Output.Write_Line ("Project_Node_Kinds not tested:");
842 for Kind in Project_Node_Kind loop
843 if Kind /= N_Comment_Zones and then Not_Tested (Kind) then
844 Output.Write_Str (" ");
845 Output.Write_Line (Project_Node_Kind'Image (Kind));
850 end Output_Statistics;