gcc/ada/prj-pp.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               P R J . P P                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2001-2003 Free Software Foundation, Inc.       --
  10 --                                                                          --
  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.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Ada.Characters.Handling; use Ada.Characters.Handling;
  28
  29 with Hostparm;
  30 with Namet;     use Namet;
  31 with Output;    use Output;
  32 with Snames;
  33
  34 package body Prj.PP is
  35
  36    use Prj.Tree;
  37
  38    Not_Tested : array (Project_Node_Kind) of Boolean := (others => True);
  39
  40    Max_Line_Length : constant := Hostparm.Max_Line_Length - 5;
  41    --  Maximum length of a line.
  42
  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.
  46
  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.
  50    --
  51
  52    ---------------------
  53    -- Indicate_Tested --
  54    ---------------------
  55
  56    procedure Indicate_Tested (Kind : Project_Node_Kind) is
  57    begin
  58       Not_Tested (Kind) := False;
  59    end Indicate_Tested;
  60
  61    ------------------
  62    -- Pretty_Print --
  63    ------------------
  64
  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)
  74    is
  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.
  80
  81       procedure Output_Attribute_Name (Name : Name_Id);
  82       --  Outputs an attribute name, taking into account the value of
  83       --  Backward_Compatibility.
  84
  85       procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True);
  86       --  Outputs a name
  87
  88       procedure Start_Line (Indent : Natural);
  89       --  Outputs the indentation at the beginning of the line.
  90
  91       procedure Output_String (S : Name_Id);
  92       --  Outputs a string using the default output procedures
  93
  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.
  97
  98       procedure Write_Line (S : String);
  99       --  Outputs S followed by a new line
 100
 101       procedure Write_String (S : String);
 102       --  Outputs S using Write_Str, starting a new line if line would
 103       --  become too long.
 104
 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.
 109
 110       Last_Line_Is_Empty : Boolean := False;
 111       --  Used to avoid two consecutive empty lines.
 112
 113       ---------------------------
 114       -- Output_Attribute_Name --
 115       ---------------------------
 116
 117       procedure Output_Attribute_Name (Name : Name_Id) is
 118       begin
 119          if Backward_Compatibility then
 120             case Name is
 121                when Snames.Name_Spec =>
 122                   Output_Name (Snames.Name_Specification);
 123
 124                when Snames.Name_Spec_Suffix =>
 125                   Output_Name (Snames.Name_Specification_Suffix);
 126
 127                when Snames.Name_Body =>
 128                   Output_Name (Snames.Name_Implementation);
 129
 130                when Snames.Name_Body_Suffix =>
 131                   Output_Name (Snames.Name_Implementation_Suffix);
 132
 133                when others =>
 134                   Output_Name (Name);
 135             end case;
 136
 137          else
 138             Output_Name (Name);
 139          end if;
 140       end Output_Attribute_Name;
 141
 142       -----------------
 143       -- Output_Name --
 144       -----------------
 145
 146       procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True) is
 147          Capital : Boolean := Capitalize;
 148
 149       begin
 150          Get_Name_String (Name);
 151
 152          --  If line would become too long, create new line
 153
 154          if Column + Name_Len > Max_Line_Length then
 155             Write_Eol.all;
 156             Column := 0;
 157          end if;
 158
 159          for J in 1 .. Name_Len loop
 160             if Capital then
 161                Write_Char (To_Upper (Name_Buffer (J)));
 162             else
 163                Write_Char (Name_Buffer (J));
 164             end if;
 165
 166             if Capitalize then
 167                Capital :=
 168                  Name_Buffer (J) = '_'
 169                  or else Is_Digit (Name_Buffer (J));
 170             end if;
 171          end loop;
 172
 173          Column := Column + Name_Len;
 174       end Output_Name;
 175
 176       -------------------
 177       -- Output_String --
 178       -------------------
 179
 180       procedure Output_String (S : Name_Id) is
 181       begin
 182          Get_Name_String (S);
 183
 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 '"').
 188
 189          if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
 190             Write_Eol.all;
 191             Column := 0;
 192          end if;
 193
 194          Write_Char ('"');
 195          Column := Column + 1;
 196          Get_Name_String (S);
 197
 198          for J in 1 .. Name_Len loop
 199             if Name_Buffer (J) = '"' then
 200                Write_Char ('"');
 201                Write_Char ('"');
 202                Column := Column + 2;
 203             else
 204                Write_Char (Name_Buffer (J));
 205                Column := Column + 1;
 206             end if;
 207
 208             --  If the string does not fit on one line, cut it in parts
 209             --  and concatenate.
 210
 211             if J < Name_Len and then Column >= Max_Line_Length then
 212                Write_Str (""" &");
 213                Write_Eol.all;
 214                Write_Char ('"');
 215                Column := 1;
 216             end if;
 217          end loop;
 218
 219          Write_Char ('"');
 220          Column := Column + 1;
 221       end Output_String;
 222
 223       ----------------
 224       -- Start_Line --
 225       ----------------
 226
 227       procedure Start_Line (Indent : Natural) is
 228       begin
 229          if not Minimize_Empty_Lines then
 230             Write_Str ((1 .. Indent => ' '));
 231             Column := Column + Indent;
 232          end if;
 233       end Start_Line;
 234
 235       ----------------------
 236       -- Write_Empty_Line --
 237       ----------------------
 238
 239       procedure Write_Empty_Line (Always : Boolean := False) is
 240       begin
 241          if (Always or else not Minimize_Empty_Lines)
 242            and then not Last_Line_Is_Empty then
 243             Write_Eol.all;
 244             Column := 0;
 245             Last_Line_Is_Empty := True;
 246          end if;
 247       end Write_Empty_Line;
 248
 249       ----------------
 250       -- Write_Line --
 251       ----------------
 252
 253       procedure Write_Line (S : String) is
 254       begin
 255          Write_String (S);
 256          Last_Line_Is_Empty := False;
 257          Write_Eol.all;
 258          Column := 0;
 259       end Write_Line;
 260
 261       ------------------
 262       -- Write_String --
 263       ------------------
 264
 265       procedure Write_String (S : String) is
 266       begin
 267          --  If the string would not fit on the line,
 268          --  start a new line.
 269
 270          if Column + S'Length > Max_Line_Length then
 271             Write_Eol.all;
 272             Column := 0;
 273          end if;
 274
 275          Write_Str (S);
 276          Column := Column + S'Length;
 277       end Write_String;
 278
 279       -----------
 280       -- Print --
 281       -----------
 282
 283       procedure Print (Node   : Project_Node_Id; Indent : Natural) is
 284       begin
 285          if Node /= Empty_Node then
 286
 287             case Kind_Of (Node) is
 288
 289                when N_Project  =>
 290                   pragma Debug (Indicate_Tested (N_Project));
 291                   if First_With_Clause_Of (Node) /= Empty_Node then
 292
 293                      --  with clause(s)
 294
 295                      Print (First_With_Clause_Of (Node), Indent);
 296                      Write_Empty_Line (Always => True);
 297                   end if;
 298
 299                   Start_Line (Indent);
 300                   Write_String ("project ");
 301                   Output_Name (Name_Of (Node));
 302
 303                   --  Check if this project extends another project
 304
 305                   if Extended_Project_Path_Of (Node) /= No_Name then
 306                      Write_String (" extends ");
 307                      Output_String (Extended_Project_Path_Of (Node));
 308                   end if;
 309
 310                   Write_Line (" is");
 311                   Write_Empty_Line (Always => True);
 312
 313                   --  Output all of the declarations in the project
 314
 315                   Print (Project_Declaration_Of (Node), Indent);
 316                   Start_Line (Indent);
 317                   Write_String ("end ");
 318                   Output_Name (Name_Of (Node));
 319                   Write_Line (";");
 320
 321                when N_With_Clause =>
 322                   pragma Debug (Indicate_Tested (N_With_Clause));
 323
 324                   if Name_Of (Node) /= No_Name then
 325                      Start_Line (Indent);
 326
 327                      if Non_Limited_Project_Node_Of (Node) = Empty_Node then
 328                         Write_String ("limited ");
 329                      end if;
 330
 331                      Write_String ("with ");
 332                      Output_String (String_Value_Of (Node));
 333                      Write_Line (";");
 334                   end if;
 335
 336                   Print (Next_With_Clause_Of (Node), Indent);
 337
 338                when N_Project_Declaration =>
 339                   pragma Debug (Indicate_Tested (N_Project_Declaration));
 340
 341                   if First_Declarative_Item_Of (Node) /= Empty_Node then
 342                      Print
 343                        (First_Declarative_Item_Of (Node), Indent + Increment);
 344                      Write_Empty_Line (Always => True);
 345                   end if;
 346
 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);
 351
 352                when N_Package_Declaration =>
 353                   pragma Debug (Indicate_Tested (N_Package_Declaration));
 354                   Write_Empty_Line (Always => True);
 355                   Start_Line (Indent);
 356                   Write_String ("package ");
 357                   Output_Name (Name_Of (Node));
 358
 359                   if Project_Of_Renamed_Package_Of (Node) /= Empty_Node then
 360                      Write_String (" renames ");
 361                      Output_Name
 362                        (Name_Of (Project_Of_Renamed_Package_Of (Node)));
 363                      Write_String (".");
 364                      Output_Name (Name_Of (Node));
 365                      Write_Line (";");
 366
 367                   else
 368                      Write_Line (" is");
 369
 370                      if First_Declarative_Item_Of (Node) /= Empty_Node then
 371                         Print
 372                           (First_Declarative_Item_Of (Node),
 373                            Indent + Increment);
 374                      end if;
 375
 376                      Start_Line (Indent);
 377                      Write_String ("end ");
 378                      Output_Name (Name_Of (Node));
 379                      Write_Line (";");
 380                      Write_Empty_Line;
 381                   end if;
 382
 383                when N_String_Type_Declaration =>
 384                   pragma Debug (Indicate_Tested (N_String_Type_Declaration));
 385                   Start_Line (Indent);
 386                   Write_String ("type ");
 387                   Output_Name (Name_Of (Node));
 388                   Write_Line (" is");
 389                   Start_Line (Indent + Increment);
 390                   Write_String ("(");
 391
 392                   declare
 393                      String_Node : Project_Node_Id :=
 394                        First_Literal_String (Node);
 395
 396                   begin
 397                      while String_Node /= Empty_Node loop
 398                         Output_String (String_Value_Of (String_Node));
 399                         String_Node := Next_Literal_String (String_Node);
 400
 401                         if String_Node /= Empty_Node then
 402                            Write_String (", ");
 403                         end if;
 404                      end loop;
 405                   end;
 406
 407                   Write_Line (");");
 408
 409                when N_Literal_String =>
 410                   pragma Debug (Indicate_Tested (N_Literal_String));
 411                   Output_String (String_Value_Of (Node));
 412
 413                when N_Attribute_Declaration =>
 414                   pragma Debug (Indicate_Tested (N_Attribute_Declaration));
 415                   Start_Line (Indent);
 416                   Write_String ("for ");
 417                   Output_Attribute_Name (Name_Of (Node));
 418
 419                   if Associative_Array_Index_Of (Node) /= No_Name then
 420                      Write_String (" (");
 421                      Output_String (Associative_Array_Index_Of (Node));
 422                      Write_String (")");
 423                   end if;
 424
 425                   Write_String (" use ");
 426                   Print (Expression_Of (Node), Indent);
 427                   Write_Line (";");
 428
 429                when N_Typed_Variable_Declaration =>
 430                   pragma Debug
 431                     (Indicate_Tested (N_Typed_Variable_Declaration));
 432                   Start_Line (Indent);
 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);
 438                   Write_Line (";");
 439
 440                when N_Variable_Declaration =>
 441                   pragma Debug (Indicate_Tested (N_Variable_Declaration));
 442                   Start_Line (Indent);
 443                   Output_Name (Name_Of (Node));
 444                   Write_String (" := ");
 445                   Print (Expression_Of (Node), Indent);
 446                   Write_Line (";");
 447
 448                when N_Expression =>
 449                   pragma Debug (Indicate_Tested (N_Expression));
 450                   declare
 451                      Term : Project_Node_Id := First_Term (Node);
 452
 453                   begin
 454                      while Term /= Empty_Node loop
 455                         Print (Term, Indent);
 456                         Term := Next_Term (Term);
 457
 458                         if Term /= Empty_Node then
 459                            Write_String (" & ");
 460                         end if;
 461                      end loop;
 462                   end;
 463
 464                when N_Term =>
 465                   pragma Debug (Indicate_Tested (N_Term));
 466                   Print (Current_Term (Node), Indent);
 467
 468                when N_Literal_String_List =>
 469                   pragma Debug (Indicate_Tested (N_Literal_String_List));
 470                   Write_String ("(");
 471
 472                   declare
 473                      Expression : Project_Node_Id :=
 474                        First_Expression_In_List (Node);
 475
 476                   begin
 477                      while Expression /= Empty_Node loop
 478                         Print (Expression, Indent);
 479                         Expression := Next_Expression_In_List (Expression);
 480
 481                         if Expression /= Empty_Node then
 482                            Write_String (", ");
 483                         end if;
 484                      end loop;
 485                   end;
 486
 487                   Write_String (")");
 488
 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)));
 493                      Write_String (".");
 494                   end if;
 495
 496                   if Package_Node_Of (Node) /= Empty_Node then
 497                      Output_Name (Name_Of (Package_Node_Of (Node)));
 498                      Write_String (".");
 499                   end if;
 500
 501                   Output_Name (Name_Of (Node));
 502
 503                when N_External_Value =>
 504                   pragma Debug (Indicate_Tested (N_External_Value));
 505                   Write_String ("external (");
 506                   Print (External_Reference_Of (Node), Indent);
 507
 508                   if External_Default_Of (Node) /= Empty_Node then
 509                      Write_String (", ");
 510                      Print (External_Default_Of (Node), Indent);
 511                   end if;
 512
 513                   Write_String (")");
 514
 515                when N_Attribute_Reference =>
 516                   pragma Debug (Indicate_Tested (N_Attribute_Reference));
 517
 518                   if Project_Node_Of (Node) /= Empty_Node
 519                     and then Project_Node_Of (Node) /= Project
 520                   then
 521                      Output_Name (Name_Of (Project_Node_Of (Node)));
 522
 523                      if Package_Node_Of (Node) /= Empty_Node then
 524                         Write_String (".");
 525                         Output_Name (Name_Of (Package_Node_Of (Node)));
 526                      end if;
 527
 528                   elsif Package_Node_Of (Node) /= Empty_Node then
 529                      Output_Name (Name_Of (Package_Node_Of (Node)));
 530
 531                   else
 532                      Write_String ("project");
 533                   end if;
 534
 535                   Write_String ("'");
 536                   Output_Attribute_Name (Name_Of (Node));
 537
 538                   declare
 539                      Index : constant Name_Id :=
 540                        Associative_Array_Index_Of (Node);
 541
 542                   begin
 543                      if Index /= No_Name then
 544                         Write_String (" (");
 545                         Output_String (Index);
 546                         Write_String (")");
 547                      end if;
 548                   end;
 549
 550                when N_Case_Construction =>
 551                   pragma Debug (Indicate_Tested (N_Case_Construction));
 552
 553                   declare
 554                      Case_Item : Project_Node_Id := First_Case_Item_Of (Node);
 555                      Is_Non_Empty : Boolean := False;
 556                   begin
 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
 560                         then
 561                            Is_Non_Empty := True;
 562                            exit;
 563                         end if;
 564                         Case_Item := Next_Case_Item (Case_Item);
 565                      end loop;
 566
 567                      if Is_Non_Empty then
 568                         Write_Empty_Line;
 569                         Start_Line (Indent);
 570                         Write_String ("case ");
 571                         Print (Case_Variable_Reference_Of (Node), Indent);
 572                         Write_Line (" is");
 573
 574                         declare
 575                            Case_Item : Project_Node_Id :=
 576                              First_Case_Item_Of (Node);
 577
 578                         begin
 579                            while Case_Item /= Empty_Node loop
 580                               pragma Assert
 581                                 (Kind_Of (Case_Item) = N_Case_Item);
 582                               Print (Case_Item, Indent + Increment);
 583                               Case_Item := Next_Case_Item (Case_Item);
 584                            end loop;
 585                         end;
 586
 587                         Start_Line (Indent);
 588                         Write_Line ("end case;");
 589                      end if;
 590                   end;
 591
 592                when N_Case_Item =>
 593                   pragma Debug (Indicate_Tested (N_Case_Item));
 594
 595                   if First_Declarative_Item_Of (Node) /= Empty_Node
 596                     or else not Eliminate_Empty_Case_Constructions
 597                   then
 598                      Write_Empty_Line;
 599                      Start_Line (Indent);
 600                      Write_String ("when ");
 601
 602                      if First_Choice_Of (Node) = Empty_Node then
 603                         Write_String ("others");
 604
 605                      else
 606                         declare
 607                            Label : Project_Node_Id := First_Choice_Of (Node);
 608
 609                         begin
 610                            while Label /= Empty_Node loop
 611                               Print (Label, Indent);
 612                               Label := Next_Literal_String (Label);
 613
 614                               if Label /= Empty_Node then
 615                                  Write_String (" | ");
 616                               end if;
 617                            end loop;
 618                         end;
 619                      end if;
 620
 621                      Write_Line (" =>");
 622
 623                      declare
 624                         First : constant Project_Node_Id :=
 625                                   First_Declarative_Item_Of (Node);
 626
 627                      begin
 628                         if First = Empty_Node then
 629                            Write_Eol.all;
 630
 631                         else
 632                            Print (First, Indent + Increment);
 633                         end if;
 634                      end;
 635                   end if;
 636             end case;
 637          end if;
 638       end Print;
 639
 640    --  Start of processing for Pretty_Print
 641
 642    begin
 643       if W_Char = null then
 644          Write_Char := Output.Write_Char'Access;
 645       else
 646          Write_Char := W_Char;
 647       end if;
 648
 649       if W_Eol = null then
 650          Write_Eol := Output.Write_Eol'Access;
 651       else
 652          Write_Eol := W_Eol;
 653       end if;
 654
 655       if W_Str = null then
 656          Write_Str := Output.Write_Str'Access;
 657       else
 658          Write_Str := W_Str;
 659       end if;
 660
 661       Print (Project, 0);
 662
 663       if W_Char = null or else W_Str = null then
 664          Output.Write_Eol;
 665       end if;
 666    end Pretty_Print;
 667
 668    -----------------------
 669    -- Output_Statistics --
 670    -----------------------
 671
 672    procedure Output_Statistics is
 673    begin
 674       Output.Write_Line ("Project_Node_Kinds not tested:");
 675
 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));
 680          end if;
 681       end loop;
 682
 683       Output.Write_Eol;
 684    end Output_Statistics;
 685
 686 end Prj.PP;