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 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Ada.Characters.Handling; use Ada.Characters.Handling;
29 with Output; use Output;
32 package body Prj.PP is
36 Not_Tested : array (Project_Node_Kind) of Boolean := (others => True);
38 Max_Line_Length : constant := 255;
39 -- Maximum length of a line. This is chosen to be compatible with older
40 -- versions of GNAT that had a strict limit on the maximum line length.
42 Column : Natural := 0;
43 -- Column number of the last character in the line. Used to avoid
44 -- outputing lines longer than Max_Line_Length.
46 First_With_In_List : Boolean := True;
47 -- Indicate that the next with clause is first in a list such as
49 -- First_With_In_List will be True for "A", but not for "B".
51 procedure Indicate_Tested (Kind : Project_Node_Kind);
52 -- Set the corresponding component of array Not_Tested to False.
53 -- Only called by pragmas Debug.
59 procedure Indicate_Tested (Kind : Project_Node_Kind) is
61 Not_Tested (Kind) := False;
68 procedure Pretty_Print
69 (Project : Prj.Tree.Project_Node_Id;
70 In_Tree : Prj.Tree.Project_Node_Tree_Ref;
71 Increment : Positive := 3;
72 Eliminate_Empty_Case_Constructions : Boolean := False;
73 Minimize_Empty_Lines : Boolean := False;
74 W_Char : Write_Char_Ap := null;
75 W_Eol : Write_Eol_Ap := null;
76 W_Str : Write_Str_Ap := null;
77 Backward_Compatibility : Boolean)
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 Node /= Empty_Node then
323 case Kind_Of (Node, In_Tree) is
326 pragma Debug (Indicate_Tested (N_Project));
327 if First_With_Clause_Of (Node, In_Tree) /= Empty_Node 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 ");
339 Output_Name (Name_Of (Node, In_Tree));
341 -- Check if this project extends another project
343 if Extended_Project_Path_Of (Node, In_Tree) /= No_Path then
344 Write_String (" extends ");
346 if Is_Extending_All (Node, In_Tree) then
347 Write_String ("all ");
350 Output_String (Extended_Project_Path_Of (Node, In_Tree));
353 Write_String (" is");
354 Write_End_Of_Line_Comment (Node);
356 (First_Comment_After (Node, In_Tree), Indent + Increment);
357 Write_Empty_Line (Always => True);
359 -- Output all of the declarations in the project
361 Print (Project_Declaration_Of (Node, In_Tree), Indent);
363 (First_Comment_Before_End (Node, In_Tree),
366 Write_String ("end ");
367 Output_Name (Name_Of (Node, In_Tree));
369 Print (First_Comment_After_End (Node, In_Tree), Indent);
371 when N_With_Clause =>
372 pragma Debug (Indicate_Tested (N_With_Clause));
374 -- The with clause will sometimes contain an invalid name
375 -- when we are importing a virtual project from an
376 -- extending all project. Do not output anything in this
379 if Name_Of (Node, In_Tree) /= No_Name
380 and then String_Value_Of (Node, In_Tree) /= No_Name
382 if First_With_In_List then
383 Print (First_Comment_Before (Node, In_Tree), Indent);
386 if Non_Limited_Project_Node_Of (Node, In_Tree) =
389 Write_String ("limited ");
392 Write_String ("with ");
395 Output_String (String_Value_Of (Node, In_Tree));
397 if Is_Not_Last_In_List (Node, In_Tree) then
399 First_With_In_List := False;
403 Write_End_Of_Line_Comment (Node);
404 Print (First_Comment_After (Node, In_Tree), Indent);
405 First_With_In_List := True;
409 Print (Next_With_Clause_Of (Node, In_Tree), Indent);
411 when N_Project_Declaration =>
412 pragma Debug (Indicate_Tested (N_Project_Declaration));
415 First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node
418 (First_Declarative_Item_Of (Node, In_Tree),
420 Write_Empty_Line (Always => True);
423 when N_Declarative_Item =>
424 pragma Debug (Indicate_Tested (N_Declarative_Item));
425 Print (Current_Item_Node (Node, In_Tree), Indent);
426 Print (Next_Declarative_Item (Node, In_Tree), Indent);
428 when N_Package_Declaration =>
429 pragma Debug (Indicate_Tested (N_Package_Declaration));
430 Write_Empty_Line (Always => True);
431 Print (First_Comment_Before (Node, In_Tree), Indent);
433 Write_String ("package ");
434 Output_Name (Name_Of (Node, In_Tree));
436 if Project_Of_Renamed_Package_Of (Node, In_Tree) /=
439 Write_String (" renames ");
442 (Project_Of_Renamed_Package_Of (Node, In_Tree),
445 Output_Name (Name_Of (Node, In_Tree));
447 Write_End_Of_Line_Comment (Node);
448 Print (First_Comment_After_End (Node, In_Tree), Indent);
451 Write_String (" is");
452 Write_End_Of_Line_Comment (Node);
453 Print (First_Comment_After (Node, In_Tree),
456 if First_Declarative_Item_Of (Node, In_Tree) /=
460 (First_Declarative_Item_Of (Node, In_Tree),
464 Print (First_Comment_Before_End (Node, In_Tree),
467 Write_String ("end ");
468 Output_Name (Name_Of (Node, In_Tree));
470 Print (First_Comment_After_End (Node, In_Tree), Indent);
474 when N_String_Type_Declaration =>
475 pragma Debug (Indicate_Tested (N_String_Type_Declaration));
476 Print (First_Comment_Before (Node, In_Tree), Indent);
478 Write_String ("type ");
479 Output_Name (Name_Of (Node, In_Tree));
481 Start_Line (Indent + Increment);
485 String_Node : Project_Node_Id :=
486 First_Literal_String (Node, In_Tree);
489 while String_Node /= Empty_Node loop
490 Output_String (String_Value_Of (String_Node, In_Tree));
492 Next_Literal_String (String_Node, In_Tree);
494 if String_Node /= Empty_Node then
501 Write_End_Of_Line_Comment (Node);
502 Print (First_Comment_After (Node, In_Tree), Indent);
504 when N_Literal_String =>
505 pragma Debug (Indicate_Tested (N_Literal_String));
506 Output_String (String_Value_Of (Node, In_Tree));
508 if Source_Index_Of (Node, In_Tree) /= 0 then
509 Write_String (" at ");
510 Write_String (Source_Index_Of (Node, In_Tree)'Img);
513 when N_Attribute_Declaration =>
514 pragma Debug (Indicate_Tested (N_Attribute_Declaration));
515 Print (First_Comment_Before (Node, In_Tree), Indent);
517 Write_String ("for ");
518 Output_Attribute_Name (Name_Of (Node, In_Tree));
520 if Associative_Array_Index_Of (Node, In_Tree) /= No_Name then
523 (Associative_Array_Index_Of (Node, In_Tree));
525 if Source_Index_Of (Node, In_Tree) /= 0 then
526 Write_String (" at ");
527 Write_String (Source_Index_Of (Node, In_Tree)'Img);
533 Write_String (" use ");
534 Print (Expression_Of (Node, In_Tree), Indent);
536 Write_End_Of_Line_Comment (Node);
537 Print (First_Comment_After (Node, In_Tree), Indent);
539 when N_Typed_Variable_Declaration =>
541 (Indicate_Tested (N_Typed_Variable_Declaration));
542 Print (First_Comment_Before (Node, In_Tree), Indent);
544 Output_Name (Name_Of (Node, In_Tree));
545 Write_String (" : ");
547 (Name_Of (String_Type_Of (Node, In_Tree), In_Tree));
548 Write_String (" := ");
549 Print (Expression_Of (Node, In_Tree), Indent);
551 Write_End_Of_Line_Comment (Node);
552 Print (First_Comment_After (Node, In_Tree), Indent);
554 when N_Variable_Declaration =>
555 pragma Debug (Indicate_Tested (N_Variable_Declaration));
556 Print (First_Comment_Before (Node, In_Tree), Indent);
558 Output_Name (Name_Of (Node, In_Tree));
559 Write_String (" := ");
560 Print (Expression_Of (Node, In_Tree), Indent);
562 Write_End_Of_Line_Comment (Node);
563 Print (First_Comment_After (Node, In_Tree), Indent);
566 pragma Debug (Indicate_Tested (N_Expression));
568 Term : Project_Node_Id := First_Term (Node, In_Tree);
571 while Term /= Empty_Node loop
572 Print (Term, Indent);
573 Term := Next_Term (Term, In_Tree);
575 if Term /= Empty_Node then
576 Write_String (" & ");
582 pragma Debug (Indicate_Tested (N_Term));
583 Print (Current_Term (Node, In_Tree), Indent);
585 when N_Literal_String_List =>
586 pragma Debug (Indicate_Tested (N_Literal_String_List));
590 Expression : Project_Node_Id :=
591 First_Expression_In_List (Node, In_Tree);
594 while Expression /= Empty_Node loop
595 Print (Expression, Indent);
597 Next_Expression_In_List (Expression, In_Tree);
599 if Expression /= Empty_Node then
607 when N_Variable_Reference =>
608 pragma Debug (Indicate_Tested (N_Variable_Reference));
609 if Project_Node_Of (Node, In_Tree) /= Empty_Node then
611 (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree));
615 if Package_Node_Of (Node, In_Tree) /= Empty_Node then
617 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
621 Output_Name (Name_Of (Node, In_Tree));
623 when N_External_Value =>
624 pragma Debug (Indicate_Tested (N_External_Value));
625 Write_String ("external (");
626 Print (External_Reference_Of (Node, In_Tree), Indent);
628 if External_Default_Of (Node, In_Tree) /= Empty_Node then
630 Print (External_Default_Of (Node, In_Tree), Indent);
635 when N_Attribute_Reference =>
636 pragma Debug (Indicate_Tested (N_Attribute_Reference));
638 if Project_Node_Of (Node, In_Tree) /= Empty_Node
639 and then Project_Node_Of (Node, In_Tree) /= Project
642 (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree));
644 if Package_Node_Of (Node, In_Tree) /= Empty_Node then
647 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
650 elsif Package_Node_Of (Node, In_Tree) /= Empty_Node then
652 (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree));
655 Write_String ("project");
659 Output_Attribute_Name (Name_Of (Node, In_Tree));
662 Index : constant Name_Id :=
663 Associative_Array_Index_Of (Node, In_Tree);
666 if Index /= No_Name then
668 Output_String (Index);
673 when N_Case_Construction =>
674 pragma Debug (Indicate_Tested (N_Case_Construction));
677 Case_Item : Project_Node_Id;
678 Is_Non_Empty : Boolean := False;
681 Case_Item := First_Case_Item_Of (Node, In_Tree);
682 while Case_Item /= Empty_Node loop
683 if First_Declarative_Item_Of (Case_Item, In_Tree) /=
685 or else not Eliminate_Empty_Case_Constructions
687 Is_Non_Empty := True;
691 Case_Item := Next_Case_Item (Case_Item, In_Tree);
696 Print (First_Comment_Before (Node, In_Tree), Indent);
698 Write_String ("case ");
700 (Case_Variable_Reference_Of (Node, In_Tree),
702 Write_String (" is");
703 Write_End_Of_Line_Comment (Node);
705 (First_Comment_After (Node, In_Tree),
709 Case_Item : Project_Node_Id :=
710 First_Case_Item_Of (Node, In_Tree);
712 while Case_Item /= Empty_Node loop
714 (Kind_Of (Case_Item, In_Tree) = N_Case_Item);
715 Print (Case_Item, Indent + Increment);
717 Next_Case_Item (Case_Item, In_Tree);
721 Print (First_Comment_Before_End (Node, In_Tree),
724 Write_Line ("end case;");
726 (First_Comment_After_End (Node, In_Tree), Indent);
731 pragma Debug (Indicate_Tested (N_Case_Item));
733 if First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node
734 or else not Eliminate_Empty_Case_Constructions
737 Print (First_Comment_Before (Node, In_Tree), Indent);
739 Write_String ("when ");
741 if First_Choice_Of (Node, In_Tree) = Empty_Node then
742 Write_String ("others");
746 Label : Project_Node_Id :=
747 First_Choice_Of (Node, In_Tree);
749 while Label /= Empty_Node loop
750 Print (Label, Indent);
751 Label := Next_Literal_String (Label, In_Tree);
753 if Label /= Empty_Node then
754 Write_String (" | ");
760 Write_String (" =>");
761 Write_End_Of_Line_Comment (Node);
763 (First_Comment_After (Node, In_Tree),
767 First : constant Project_Node_Id :=
768 First_Declarative_Item_Of (Node, In_Tree);
770 if First = Empty_Node then
773 Print (First, Indent + Increment);
778 when N_Comment_Zones =>
780 -- Nothing to do, because it will not be processed directly
785 pragma Debug (Indicate_Tested (N_Comment));
787 if Follows_Empty_Line (Node, In_Tree) then
794 (Get_Name_String (String_Value_Of (Node, In_Tree)),
798 if Is_Followed_By_Empty_Line (Node, In_Tree) then
802 Print (Next_Comment (Node, In_Tree), Indent);
807 -- Start of processing for Pretty_Print
810 if W_Char = null then
811 Write_Char := Output.Write_Char'Access;
813 Write_Char := W_Char;
817 Write_Eol := Output.Write_Eol'Access;
823 Write_Str := Output.Write_Str'Access;
830 if W_Char = null or else W_Str = null then
835 -----------------------
836 -- Output_Statistics --
837 -----------------------
839 procedure Output_Statistics is
841 Output.Write_Line ("Project_Node_Kinds not tested:");
843 for Kind in Project_Node_Kind loop
844 if Kind /= N_Comment_Zones and then Not_Tested (Kind) then
845 Output.Write_Str (" ");
846 Output.Write_Line (Project_Node_Kind'Image (Kind));
851 end Output_Statistics;