1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2004 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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;
30 with Namet; use Namet;
31 with Output; use Output;
34 package body Prj.PP is
38 Not_Tested : array (Project_Node_Kind) of Boolean := (others => True);
40 Max_Line_Length : constant := Hostparm.Max_Line_Length - 5;
41 -- Maximum length of a line.
43 Column : Natural := 0;
44 -- Column number of the last character in the line. Used to avoid
45 -- outputing lines longer than Max_Line_Length.
47 procedure Indicate_Tested (Kind : Project_Node_Kind);
48 -- Set the corresponding component of array Not_Tested to False.
49 -- Only called by pragmas Debug.
55 procedure Indicate_Tested (Kind : Project_Node_Kind) is
57 Not_Tested (Kind) := False;
64 procedure Pretty_Print
65 (Project : Prj.Tree.Project_Node_Id;
66 Increment : Positive := 3;
67 Eliminate_Empty_Case_Constructions : Boolean := False;
68 Minimize_Empty_Lines : Boolean := False;
69 W_Char : Write_Char_Ap := null;
70 W_Eol : Write_Eol_Ap := null;
71 W_Str : Write_Str_Ap := null;
72 Backward_Compatibility : Boolean)
74 procedure Print (Node : Project_Node_Id; Indent : Natural);
75 -- A recursive procedure that traverses a project file tree and outputs
76 -- its source. Current_Prj is the project that we are printing. This
77 -- is used when printing attributes, since in nested packages they
78 -- need to use a fully qualified name.
80 procedure Output_Attribute_Name (Name : Name_Id);
81 -- Outputs an attribute name, taking into account the value of
82 -- Backward_Compatibility.
84 procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True);
87 procedure Start_Line (Indent : Natural);
88 -- Outputs the indentation at the beginning of the line.
90 procedure Output_String (S : Name_Id);
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 (S : String; Truncated : Boolean := False);
101 -- Outputs S using Write_Str, starting a new line if line would
102 -- become too long, when Truncated = False.
103 -- When Truncated = True, only the part of the string that can fit on
104 -- the line is output.
106 procedure Write_End_Of_Line_Comment (Node : Project_Node_Id);
108 Write_Char : Write_Char_Ap := Output.Write_Char'Access;
109 Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access;
110 Write_Str : Write_Str_Ap := Output.Write_Str'Access;
111 -- These three access to procedure values are used for the output.
113 Last_Line_Is_Empty : Boolean := False;
114 -- Used to avoid two consecutive empty lines.
116 ---------------------------
117 -- Output_Attribute_Name --
118 ---------------------------
120 procedure Output_Attribute_Name (Name : Name_Id) is
122 if Backward_Compatibility then
124 when Snames.Name_Spec =>
125 Output_Name (Snames.Name_Specification);
127 when Snames.Name_Spec_Suffix =>
128 Output_Name (Snames.Name_Specification_Suffix);
130 when Snames.Name_Body =>
131 Output_Name (Snames.Name_Implementation);
133 when Snames.Name_Body_Suffix =>
134 Output_Name (Snames.Name_Implementation_Suffix);
143 end Output_Attribute_Name;
149 procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True) is
150 Capital : Boolean := Capitalize;
153 Get_Name_String (Name);
155 -- If line would become too long, create new line
157 if Column + Name_Len > Max_Line_Length then
162 for J in 1 .. Name_Len loop
164 Write_Char (To_Upper (Name_Buffer (J)));
166 Write_Char (Name_Buffer (J));
171 Name_Buffer (J) = '_'
172 or else Is_Digit (Name_Buffer (J));
176 Column := Column + Name_Len;
183 procedure Output_String (S : Name_Id) is
187 -- If line could become too long, create new line.
188 -- Note that the number of characters on the line could be
189 -- twice the number of character in the string (if every
190 -- character is a '"') plus two (the initial and final '"').
192 if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
198 Column := Column + 1;
201 for J in 1 .. Name_Len loop
202 if Name_Buffer (J) = '"' then
205 Column := Column + 2;
207 Write_Char (Name_Buffer (J));
208 Column := Column + 1;
211 -- If the string does not fit on one line, cut it in parts
214 if J < Name_Len and then Column >= Max_Line_Length then
223 Column := Column + 1;
230 procedure Start_Line (Indent : Natural) is
232 if not Minimize_Empty_Lines then
233 Write_Str ((1 .. Indent => ' '));
234 Column := Column + Indent;
238 ----------------------
239 -- Write_Empty_Line --
240 ----------------------
242 procedure Write_Empty_Line (Always : Boolean := False) is
244 if (Always or else not Minimize_Empty_Lines)
245 and then not Last_Line_Is_Empty then
248 Last_Line_Is_Empty := True;
250 end Write_Empty_Line;
252 -------------------------------
253 -- Write_End_Of_Line_Comment --
254 -------------------------------
256 procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is
257 Value : constant Name_Id := End_Of_Line_Comment (Node);
260 if Value /= No_Name then
261 Write_String (" --");
262 Write_String (Get_Name_String (Value), Truncated => True);
266 end Write_End_Of_Line_Comment;
272 procedure Write_Line (S : String) is
275 Last_Line_Is_Empty := False;
284 procedure Write_String (S : String; Truncated : Boolean := False) is
285 Length : Natural := S'Length;
287 -- If the string would not fit on the line,
290 if Column + Length > Max_Line_Length then
292 Length := Max_Line_Length - Column;
300 Write_Str (S (S'First .. S'First + Length - 1));
301 Column := Column + Length;
308 procedure Print (Node : Project_Node_Id; Indent : Natural) is
310 if Node /= Empty_Node then
312 case Kind_Of (Node) is
315 pragma Debug (Indicate_Tested (N_Project));
316 if First_With_Clause_Of (Node) /= Empty_Node then
320 Print (First_With_Clause_Of (Node), Indent);
321 Write_Empty_Line (Always => True);
324 Print (First_Comment_Before (Node), Indent);
326 Write_String ("project ");
327 Output_Name (Name_Of (Node));
329 -- Check if this project extends another project
331 if Extended_Project_Path_Of (Node) /= No_Name then
332 Write_String (" extends ");
333 Output_String (Extended_Project_Path_Of (Node));
336 Write_String (" is");
337 Write_End_Of_Line_Comment (Node);
338 Print (First_Comment_After (Node), Indent + Increment);
339 Write_Empty_Line (Always => True);
341 -- Output all of the declarations in the project
343 Print (Project_Declaration_Of (Node), Indent);
344 Print (First_Comment_Before_End (Node), Indent + Increment);
346 Write_String ("end ");
347 Output_Name (Name_Of (Node));
349 Print (First_Comment_After_End (Node), Indent);
351 when N_With_Clause =>
352 pragma Debug (Indicate_Tested (N_With_Clause));
354 if Name_Of (Node) /= No_Name then
355 Print (First_Comment_Before (Node), Indent);
358 if Non_Limited_Project_Node_Of (Node) = Empty_Node then
359 Write_String ("limited ");
362 Write_String ("with ");
363 Output_String (String_Value_Of (Node));
365 Write_End_Of_Line_Comment (Node);
366 Print (First_Comment_After (Node), Indent);
369 Print (Next_With_Clause_Of (Node), Indent);
371 when N_Project_Declaration =>
372 pragma Debug (Indicate_Tested (N_Project_Declaration));
374 if First_Declarative_Item_Of (Node) /= Empty_Node then
376 (First_Declarative_Item_Of (Node), Indent + Increment);
377 Write_Empty_Line (Always => True);
380 when N_Declarative_Item =>
381 pragma Debug (Indicate_Tested (N_Declarative_Item));
382 Print (Current_Item_Node (Node), Indent);
383 Print (Next_Declarative_Item (Node), Indent);
385 when N_Package_Declaration =>
386 pragma Debug (Indicate_Tested (N_Package_Declaration));
387 Write_Empty_Line (Always => True);
388 Print (First_Comment_Before (Node), Indent);
390 Write_String ("package ");
391 Output_Name (Name_Of (Node));
393 if Project_Of_Renamed_Package_Of (Node) /= Empty_Node then
394 Write_String (" renames ");
396 (Name_Of (Project_Of_Renamed_Package_Of (Node)));
398 Output_Name (Name_Of (Node));
400 Write_End_Of_Line_Comment (Node);
401 Print (First_Comment_After_End (Node), Indent);
404 Write_String (" is");
405 Write_End_Of_Line_Comment (Node);
406 Print (First_Comment_After (Node), Indent + Increment);
408 if First_Declarative_Item_Of (Node) /= Empty_Node then
410 (First_Declarative_Item_Of (Node),
414 Print (First_Comment_Before_End (Node),
417 Write_String ("end ");
418 Output_Name (Name_Of (Node));
420 Print (First_Comment_After_End (Node), Indent);
424 when N_String_Type_Declaration =>
425 pragma Debug (Indicate_Tested (N_String_Type_Declaration));
426 Print (First_Comment_Before (Node), Indent);
428 Write_String ("type ");
429 Output_Name (Name_Of (Node));
431 Start_Line (Indent + Increment);
435 String_Node : Project_Node_Id :=
436 First_Literal_String (Node);
439 while String_Node /= Empty_Node loop
440 Output_String (String_Value_Of (String_Node));
441 String_Node := Next_Literal_String (String_Node);
443 if String_Node /= Empty_Node then
450 Write_End_Of_Line_Comment (Node);
451 Print (First_Comment_After (Node), Indent);
453 when N_Literal_String =>
454 pragma Debug (Indicate_Tested (N_Literal_String));
455 Output_String (String_Value_Of (Node));
457 if Source_Index_Of (Node) /= 0 then
458 Write_String (" at ");
459 Write_String (Source_Index_Of (Node)'Img);
462 when N_Attribute_Declaration =>
463 pragma Debug (Indicate_Tested (N_Attribute_Declaration));
464 Print (First_Comment_Before (Node), Indent);
466 Write_String ("for ");
467 Output_Attribute_Name (Name_Of (Node));
469 if Associative_Array_Index_Of (Node) /= No_Name then
471 Output_String (Associative_Array_Index_Of (Node));
473 if Source_Index_Of (Node) /= 0 then
474 Write_String (" at ");
475 Write_String (Source_Index_Of (Node)'Img);
481 Write_String (" use ");
482 Print (Expression_Of (Node), Indent);
484 Write_End_Of_Line_Comment (Node);
485 Print (First_Comment_After (Node), Indent);
487 when N_Typed_Variable_Declaration =>
489 (Indicate_Tested (N_Typed_Variable_Declaration));
490 Print (First_Comment_Before (Node), Indent);
492 Output_Name (Name_Of (Node));
493 Write_String (" : ");
494 Output_Name (Name_Of (String_Type_Of (Node)));
495 Write_String (" := ");
496 Print (Expression_Of (Node), Indent);
498 Write_End_Of_Line_Comment (Node);
499 Print (First_Comment_After (Node), Indent);
501 when N_Variable_Declaration =>
502 pragma Debug (Indicate_Tested (N_Variable_Declaration));
503 Print (First_Comment_Before (Node), Indent);
505 Output_Name (Name_Of (Node));
506 Write_String (" := ");
507 Print (Expression_Of (Node), Indent);
509 Write_End_Of_Line_Comment (Node);
510 Print (First_Comment_After (Node), Indent);
513 pragma Debug (Indicate_Tested (N_Expression));
515 Term : Project_Node_Id := First_Term (Node);
518 while Term /= Empty_Node loop
519 Print (Term, Indent);
520 Term := Next_Term (Term);
522 if Term /= Empty_Node then
523 Write_String (" & ");
529 pragma Debug (Indicate_Tested (N_Term));
530 Print (Current_Term (Node), Indent);
532 when N_Literal_String_List =>
533 pragma Debug (Indicate_Tested (N_Literal_String_List));
537 Expression : Project_Node_Id :=
538 First_Expression_In_List (Node);
541 while Expression /= Empty_Node loop
542 Print (Expression, Indent);
543 Expression := Next_Expression_In_List (Expression);
545 if Expression /= Empty_Node then
553 when N_Variable_Reference =>
554 pragma Debug (Indicate_Tested (N_Variable_Reference));
555 if Project_Node_Of (Node) /= Empty_Node then
556 Output_Name (Name_Of (Project_Node_Of (Node)));
560 if Package_Node_Of (Node) /= Empty_Node then
561 Output_Name (Name_Of (Package_Node_Of (Node)));
565 Output_Name (Name_Of (Node));
567 when N_External_Value =>
568 pragma Debug (Indicate_Tested (N_External_Value));
569 Write_String ("external (");
570 Print (External_Reference_Of (Node), Indent);
572 if External_Default_Of (Node) /= Empty_Node then
574 Print (External_Default_Of (Node), Indent);
579 when N_Attribute_Reference =>
580 pragma Debug (Indicate_Tested (N_Attribute_Reference));
582 if Project_Node_Of (Node) /= Empty_Node
583 and then Project_Node_Of (Node) /= Project
585 Output_Name (Name_Of (Project_Node_Of (Node)));
587 if Package_Node_Of (Node) /= Empty_Node then
589 Output_Name (Name_Of (Package_Node_Of (Node)));
592 elsif Package_Node_Of (Node) /= Empty_Node then
593 Output_Name (Name_Of (Package_Node_Of (Node)));
596 Write_String ("project");
600 Output_Attribute_Name (Name_Of (Node));
603 Index : constant Name_Id :=
604 Associative_Array_Index_Of (Node);
607 if Index /= No_Name then
609 Output_String (Index);
614 when N_Case_Construction =>
615 pragma Debug (Indicate_Tested (N_Case_Construction));
618 Case_Item : Project_Node_Id := First_Case_Item_Of (Node);
619 Is_Non_Empty : Boolean := False;
621 while Case_Item /= Empty_Node loop
622 if First_Declarative_Item_Of (Case_Item) /= Empty_Node
623 or else not Eliminate_Empty_Case_Constructions
625 Is_Non_Empty := True;
628 Case_Item := Next_Case_Item (Case_Item);
633 Print (First_Comment_Before (Node), Indent);
635 Write_String ("case ");
636 Print (Case_Variable_Reference_Of (Node), Indent);
637 Write_String (" is");
638 Write_End_Of_Line_Comment (Node);
639 Print (First_Comment_After (Node), Indent + Increment);
642 Case_Item : Project_Node_Id :=
643 First_Case_Item_Of (Node);
646 while Case_Item /= Empty_Node loop
648 (Kind_Of (Case_Item) = N_Case_Item);
649 Print (Case_Item, Indent + Increment);
650 Case_Item := Next_Case_Item (Case_Item);
654 Print (First_Comment_Before_End (Node),
657 Write_Line ("end case;");
658 Print (First_Comment_After_End (Node), Indent);
663 pragma Debug (Indicate_Tested (N_Case_Item));
665 if First_Declarative_Item_Of (Node) /= Empty_Node
666 or else not Eliminate_Empty_Case_Constructions
669 Print (First_Comment_Before (Node), Indent);
671 Write_String ("when ");
673 if First_Choice_Of (Node) = Empty_Node then
674 Write_String ("others");
678 Label : Project_Node_Id := First_Choice_Of (Node);
681 while Label /= Empty_Node loop
682 Print (Label, Indent);
683 Label := Next_Literal_String (Label);
685 if Label /= Empty_Node then
686 Write_String (" | ");
692 Write_String (" =>");
693 Write_End_Of_Line_Comment (Node);
694 Print (First_Comment_After (Node), Indent + Increment);
697 First : constant Project_Node_Id :=
698 First_Declarative_Item_Of (Node);
701 if First = Empty_Node then
705 Print (First, Indent + Increment);
710 when N_Comment_Zones =>
712 -- Nothing to do, because it will not be processed directly
717 pragma Debug (Indicate_Tested (N_Comment));
719 if Follows_Empty_Line (Node) then
726 (Get_Name_String (String_Value_Of (Node)),
730 if Is_Followed_By_Empty_Line (Node) then
734 Print (Next_Comment (Node), Indent);
739 -- Start of processing for Pretty_Print
742 if W_Char = null then
743 Write_Char := Output.Write_Char'Access;
745 Write_Char := W_Char;
749 Write_Eol := Output.Write_Eol'Access;
755 Write_Str := Output.Write_Str'Access;
762 if W_Char = null or else W_Str = null then
767 -----------------------
768 -- Output_Statistics --
769 -----------------------
771 procedure Output_Statistics is
773 Output.Write_Line ("Project_Node_Kinds not tested:");
775 for Kind in Project_Node_Kind loop
776 if Kind /= N_Comment_Zones and then Not_Tested (Kind) then
777 Output.Write_Str (" ");
778 Output.Write_Line (Project_Node_Kind'Image (Kind));
783 end Output_Statistics;