1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2003 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.
56 procedure Indicate_Tested
(Kind
: Project_Node_Kind
) is
58 Not_Tested
(Kind
) := False;
65 procedure Pretty_Print
66 (Project
: Prj
.Tree
.Project_Node_Id
;
67 Increment
: Positive := 3;
68 Eliminate_Empty_Case_Constructions
: Boolean := False;
69 Minimize_Empty_Lines
: Boolean := False;
70 W_Char
: Write_Char_Ap
:= null;
71 W_Eol
: Write_Eol_Ap
:= null;
72 W_Str
: Write_Str_Ap
:= null;
73 Backward_Compatibility
: Boolean)
75 procedure Print
(Node
: Project_Node_Id
; Indent
: Natural);
76 -- A recursive procedure that traverses a project file tree and outputs
77 -- its source. Current_Prj is the project that we are printing. This
78 -- is used when printing attributes, since in nested packages they
79 -- need to use a fully qualified name.
81 procedure Output_Attribute_Name
(Name
: Name_Id
);
82 -- Outputs an attribute name, taking into account the value of
83 -- Backward_Compatibility.
85 procedure Output_Name
(Name
: Name_Id
; Capitalize
: Boolean := True);
88 procedure Start_Line
(Indent
: Natural);
89 -- Outputs the indentation at the beginning of the line.
91 procedure Output_String
(S
: Name_Id
);
92 -- Outputs a string using the default output procedures
94 procedure Write_Empty_Line
(Always
: Boolean := False);
95 -- Outputs an empty line, only if the previous line was not empty
96 -- already and either Always is True or Minimize_Empty_Lines is False.
98 procedure Write_Line
(S
: String);
99 -- Outputs S followed by a new line
101 procedure Write_String
(S
: String);
102 -- Outputs S using Write_Str, starting a new line if line would
105 Write_Char
: Write_Char_Ap
:= Output
.Write_Char
'Access;
106 Write_Eol
: Write_Eol_Ap
:= Output
.Write_Eol
'Access;
107 Write_Str
: Write_Str_Ap
:= Output
.Write_Str
'Access;
108 -- These three access to procedure values are used for the output.
110 Last_Line_Is_Empty
: Boolean := False;
111 -- Used to avoid two consecutive empty lines.
113 ---------------------------
114 -- Output_Attribute_Name --
115 ---------------------------
117 procedure Output_Attribute_Name
(Name
: Name_Id
) is
119 if Backward_Compatibility
then
121 when Snames
.Name_Spec
=>
122 Output_Name
(Snames
.Name_Specification
);
124 when Snames
.Name_Spec_Suffix
=>
125 Output_Name
(Snames
.Name_Specification_Suffix
);
127 when Snames
.Name_Body
=>
128 Output_Name
(Snames
.Name_Implementation
);
130 when Snames
.Name_Body_Suffix
=>
131 Output_Name
(Snames
.Name_Implementation_Suffix
);
140 end Output_Attribute_Name
;
146 procedure Output_Name
(Name
: Name_Id
; Capitalize
: Boolean := True) is
147 Capital
: Boolean := Capitalize
;
150 Get_Name_String
(Name
);
152 -- If line would become too long, create new line
154 if Column
+ Name_Len
> Max_Line_Length
then
159 for J
in 1 .. Name_Len
loop
161 Write_Char
(To_Upper
(Name_Buffer
(J
)));
163 Write_Char
(Name_Buffer
(J
));
168 Name_Buffer
(J
) = '_'
169 or else Is_Digit
(Name_Buffer
(J
));
173 Column
:= Column
+ Name_Len
;
180 procedure Output_String
(S
: Name_Id
) is
184 -- If line could become too long, create new line.
185 -- Note that the number of characters on the line could be
186 -- twice the number of character in the string (if every
187 -- character is a '"') plus two (the initial and final '"').
189 if Column
+ Name_Len
+ Name_Len
+ 2 > Max_Line_Length
then
195 Column
:= Column
+ 1;
198 for J
in 1 .. Name_Len
loop
199 if Name_Buffer
(J
) = '"' then
202 Column
:= Column
+ 2;
204 Write_Char
(Name_Buffer
(J
));
205 Column
:= Column
+ 1;
208 -- If the string does not fit on one line, cut it in parts
211 if J
< Name_Len
and then Column
>= Max_Line_Length
then
220 Column
:= Column
+ 1;
227 procedure Start_Line
(Indent
: Natural) is
229 if not Minimize_Empty_Lines
then
230 Write_Str
((1 .. Indent
=> ' '));
231 Column
:= Column
+ Indent
;
235 ----------------------
236 -- Write_Empty_Line --
237 ----------------------
239 procedure Write_Empty_Line
(Always
: Boolean := False) is
241 if (Always
or else not Minimize_Empty_Lines
)
242 and then not Last_Line_Is_Empty
then
245 Last_Line_Is_Empty
:= True;
247 end Write_Empty_Line
;
253 procedure Write_Line
(S
: String) is
256 Last_Line_Is_Empty
:= False;
265 procedure Write_String
(S
: String) is
267 -- If the string would not fit on the line,
270 if Column
+ S
'Length > Max_Line_Length
then
276 Column
:= Column
+ S
'Length;
283 procedure Print
(Node
: Project_Node_Id
; Indent
: Natural) is
285 if Node
/= Empty_Node
then
287 case Kind_Of
(Node
) is
290 pragma Debug
(Indicate_Tested
(N_Project
));
291 if First_With_Clause_Of
(Node
) /= Empty_Node
then
295 Print
(First_With_Clause_Of
(Node
), Indent
);
296 Write_Empty_Line
(Always
=> True);
300 Write_String
("project ");
301 Output_Name
(Name_Of
(Node
));
303 -- Check if this project extends another project
305 if Extended_Project_Path_Of
(Node
) /= No_Name
then
306 Write_String
(" extends ");
307 Output_String
(Extended_Project_Path_Of
(Node
));
311 Write_Empty_Line
(Always
=> True);
313 -- Output all of the declarations in the project
315 Print
(Project_Declaration_Of
(Node
), Indent
);
317 Write_String
("end ");
318 Output_Name
(Name_Of
(Node
));
321 when N_With_Clause
=>
322 pragma Debug
(Indicate_Tested
(N_With_Clause
));
324 if Name_Of
(Node
) /= No_Name
then
327 if Non_Limited_Project_Node_Of
(Node
) = Empty_Node
then
328 Write_String
("limited ");
331 Write_String
("with ");
332 Output_String
(String_Value_Of
(Node
));
336 Print
(Next_With_Clause_Of
(Node
), Indent
);
338 when N_Project_Declaration
=>
339 pragma Debug
(Indicate_Tested
(N_Project_Declaration
));
341 if First_Declarative_Item_Of
(Node
) /= Empty_Node
then
343 (First_Declarative_Item_Of
(Node
), Indent
+ Increment
);
344 Write_Empty_Line
(Always
=> True);
347 when N_Declarative_Item
=>
348 pragma Debug
(Indicate_Tested
(N_Declarative_Item
));
349 Print
(Current_Item_Node
(Node
), Indent
);
350 Print
(Next_Declarative_Item
(Node
), Indent
);
352 when N_Package_Declaration
=>
353 pragma Debug
(Indicate_Tested
(N_Package_Declaration
));
354 Write_Empty_Line
(Always
=> True);
356 Write_String
("package ");
357 Output_Name
(Name_Of
(Node
));
359 if Project_Of_Renamed_Package_Of
(Node
) /= Empty_Node
then
360 Write_String
(" renames ");
362 (Name_Of
(Project_Of_Renamed_Package_Of
(Node
)));
364 Output_Name
(Name_Of
(Node
));
370 if First_Declarative_Item_Of
(Node
) /= Empty_Node
then
372 (First_Declarative_Item_Of
(Node
),
377 Write_String
("end ");
378 Output_Name
(Name_Of
(Node
));
383 when N_String_Type_Declaration
=>
384 pragma Debug
(Indicate_Tested
(N_String_Type_Declaration
));
386 Write_String
("type ");
387 Output_Name
(Name_Of
(Node
));
389 Start_Line
(Indent
+ Increment
);
393 String_Node
: Project_Node_Id
:=
394 First_Literal_String
(Node
);
397 while String_Node
/= Empty_Node
loop
398 Output_String
(String_Value_Of
(String_Node
));
399 String_Node
:= Next_Literal_String
(String_Node
);
401 if String_Node
/= Empty_Node
then
409 when N_Literal_String
=>
410 pragma Debug
(Indicate_Tested
(N_Literal_String
));
411 Output_String
(String_Value_Of
(Node
));
413 when N_Attribute_Declaration
=>
414 pragma Debug
(Indicate_Tested
(N_Attribute_Declaration
));
416 Write_String
("for ");
417 Output_Attribute_Name
(Name_Of
(Node
));
419 if Associative_Array_Index_Of
(Node
) /= No_Name
then
421 Output_String
(Associative_Array_Index_Of
(Node
));
425 Write_String
(" use ");
426 Print
(Expression_Of
(Node
), Indent
);
429 when N_Typed_Variable_Declaration
=>
431 (Indicate_Tested
(N_Typed_Variable_Declaration
));
433 Output_Name
(Name_Of
(Node
));
434 Write_String
(" : ");
435 Output_Name
(Name_Of
(String_Type_Of
(Node
)));
436 Write_String
(" := ");
437 Print
(Expression_Of
(Node
), Indent
);
440 when N_Variable_Declaration
=>
441 pragma Debug
(Indicate_Tested
(N_Variable_Declaration
));
443 Output_Name
(Name_Of
(Node
));
444 Write_String
(" := ");
445 Print
(Expression_Of
(Node
), Indent
);
449 pragma Debug
(Indicate_Tested
(N_Expression
));
451 Term
: Project_Node_Id
:= First_Term
(Node
);
454 while Term
/= Empty_Node
loop
455 Print
(Term
, Indent
);
456 Term
:= Next_Term
(Term
);
458 if Term
/= Empty_Node
then
459 Write_String
(" & ");
465 pragma Debug
(Indicate_Tested
(N_Term
));
466 Print
(Current_Term
(Node
), Indent
);
468 when N_Literal_String_List
=>
469 pragma Debug
(Indicate_Tested
(N_Literal_String_List
));
473 Expression
: Project_Node_Id
:=
474 First_Expression_In_List
(Node
);
477 while Expression
/= Empty_Node
loop
478 Print
(Expression
, Indent
);
479 Expression
:= Next_Expression_In_List
(Expression
);
481 if Expression
/= Empty_Node
then
489 when N_Variable_Reference
=>
490 pragma Debug
(Indicate_Tested
(N_Variable_Reference
));
491 if Project_Node_Of
(Node
) /= Empty_Node
then
492 Output_Name
(Name_Of
(Project_Node_Of
(Node
)));
496 if Package_Node_Of
(Node
) /= Empty_Node
then
497 Output_Name
(Name_Of
(Package_Node_Of
(Node
)));
501 Output_Name
(Name_Of
(Node
));
503 when N_External_Value
=>
504 pragma Debug
(Indicate_Tested
(N_External_Value
));
505 Write_String
("external (");
506 Print
(External_Reference_Of
(Node
), Indent
);
508 if External_Default_Of
(Node
) /= Empty_Node
then
510 Print
(External_Default_Of
(Node
), Indent
);
515 when N_Attribute_Reference
=>
516 pragma Debug
(Indicate_Tested
(N_Attribute_Reference
));
518 if Project_Node_Of
(Node
) /= Empty_Node
519 and then Project_Node_Of
(Node
) /= Project
521 Output_Name
(Name_Of
(Project_Node_Of
(Node
)));
523 if Package_Node_Of
(Node
) /= Empty_Node
then
525 Output_Name
(Name_Of
(Package_Node_Of
(Node
)));
528 elsif Package_Node_Of
(Node
) /= Empty_Node
then
529 Output_Name
(Name_Of
(Package_Node_Of
(Node
)));
532 Write_String
("project");
536 Output_Attribute_Name
(Name_Of
(Node
));
539 Index
: constant Name_Id
:=
540 Associative_Array_Index_Of
(Node
);
543 if Index
/= No_Name
then
545 Output_String
(Index
);
550 when N_Case_Construction
=>
551 pragma Debug
(Indicate_Tested
(N_Case_Construction
));
554 Case_Item
: Project_Node_Id
:= First_Case_Item_Of
(Node
);
555 Is_Non_Empty
: Boolean := False;
557 while Case_Item
/= Empty_Node
loop
558 if First_Declarative_Item_Of
(Case_Item
) /= Empty_Node
559 or else not Eliminate_Empty_Case_Constructions
561 Is_Non_Empty
:= True;
564 Case_Item
:= Next_Case_Item
(Case_Item
);
570 Write_String
("case ");
571 Print
(Case_Variable_Reference_Of
(Node
), Indent
);
575 Case_Item
: Project_Node_Id
:=
576 First_Case_Item_Of
(Node
);
579 while Case_Item
/= Empty_Node
loop
581 (Kind_Of
(Case_Item
) = N_Case_Item
);
582 Print
(Case_Item
, Indent
+ Increment
);
583 Case_Item
:= Next_Case_Item
(Case_Item
);
588 Write_Line
("end case;");
593 pragma Debug
(Indicate_Tested
(N_Case_Item
));
595 if First_Declarative_Item_Of
(Node
) /= Empty_Node
596 or else not Eliminate_Empty_Case_Constructions
600 Write_String
("when ");
602 if First_Choice_Of
(Node
) = Empty_Node
then
603 Write_String
("others");
607 Label
: Project_Node_Id
:= First_Choice_Of
(Node
);
610 while Label
/= Empty_Node
loop
611 Print
(Label
, Indent
);
612 Label
:= Next_Literal_String
(Label
);
614 if Label
/= Empty_Node
then
615 Write_String
(" | ");
624 First
: constant Project_Node_Id
:=
625 First_Declarative_Item_Of
(Node
);
628 if First
= Empty_Node
then
632 Print
(First
, Indent
+ Increment
);
640 -- Start of processing for Pretty_Print
643 if W_Char
= null then
644 Write_Char
:= Output
.Write_Char
'Access;
646 Write_Char
:= W_Char
;
650 Write_Eol
:= Output
.Write_Eol
'Access;
656 Write_Str
:= Output
.Write_Str
'Access;
663 if W_Char
= null or else W_Str
= null then
668 -----------------------
669 -- Output_Statistics --
670 -----------------------
672 procedure Output_Statistics
is
674 Output
.Write_Line
("Project_Node_Kinds not tested:");
676 for Kind
in Project_Node_Kind
loop
677 if Not_Tested
(Kind
) then
678 Output
.Write_Str
(" ");
679 Output
.Write_Line
(Project_Node_Kind
'Image (Kind
));
684 end Output_Statistics
;