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-2002 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 Stringt;   use Stringt;
  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    --  outputting 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) is
  73
  74       procedure Print (Node : Project_Node_Id; Indent : Natural);
  75       --  A recursive procedure that traverses a project file tree
  76       --  and outputs its source.
  77       --  Current_Prj is the project that we are printing. This
  78       --  is used when printing attributes, since in nested packages they need
  79       --  to use a fully qualified name.
  80
  81       procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True);
  82       --  Outputs a name
  83
  84       procedure Start_Line (Indent : Natural);
  85       --  Outputs the indentation at the beginning of the line.
  86
  87       procedure Output_String (S : String_Id);
  88       --  Outputs a string using the default output procedures
  89
  90       procedure Write_Empty_Line (Always : Boolean := False);
  91       --  Outputs an empty line, only if the previous line was not
  92       --  empty already and either Always is True or Minimize_Empty_Lines
  93       --  is False.
  94
  95       procedure Write_Line (S : String);
  96       --  Outputs S followed by a new line
  97
  98       procedure Write_String (S : String);
  99       --  Outputs S using Write_Str, starting a new line if line would
 100       --  become too long.
 101
 102       Write_Char : Write_Char_Ap := Output.Write_Char'Access;
 103       Write_Eol  : Write_Eol_Ap  := Output.Write_Eol'Access;
 104       Write_Str  : Write_Str_Ap  := Output.Write_Str'Access;
 105       --  These two access to procedure values are used for the output.
 106
 107       Last_Line_Is_Empty : Boolean := False;
 108       --  Used to avoid two consecutive empty lines.
 109
 110       -----------------
 111       -- Output_Name --
 112       -----------------
 113
 114       procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True) is
 115          Capital : Boolean := Capitalize;
 116
 117       begin
 118          Get_Name_String (Name);
 119
 120          --  If line would become too long, create new line
 121
 122          if Column + Name_Len > Max_Line_Length then
 123             Write_Eol.all;
 124             Column := 0;
 125          end if;
 126
 127          for J in 1 .. Name_Len loop
 128             if Capital then
 129                Write_Char (To_Upper (Name_Buffer (J)));
 130             else
 131                Write_Char (Name_Buffer (J));
 132             end if;
 133
 134             if Capitalize then
 135                Capital :=
 136                  Name_Buffer (J) = '_'
 137                  or else Is_Digit (Name_Buffer (J));
 138             end if;
 139          end loop;
 140       end Output_Name;
 141
 142       -------------------
 143       -- Output_String --
 144       -------------------
 145
 146       procedure Output_String (S : String_Id) is
 147       begin
 148          String_To_Name_Buffer (S);
 149
 150          --  If line could become too long, create new line.
 151          --  Note that the number of characters on the line could be
 152          --  twice the number of character in the string (if every
 153          --  character is a '"') plus two (the initial and final '"').
 154
 155          if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
 156             Write_Eol.all;
 157             Column := 0;
 158          end if;
 159
 160          Write_Char ('"');
 161          Column := Column + 1;
 162          String_To_Name_Buffer (S);
 163
 164          for J in 1 .. Name_Len loop
 165             if Name_Buffer (J) = '"' then
 166                Write_Char ('"');
 167                Write_Char ('"');
 168                Column := Column + 2;
 169             else
 170                Write_Char (Name_Buffer (J));
 171                Column := Column + 1;
 172             end if;
 173
 174             --  If the string does not fit on one line, cut it in parts
 175             --  and concatenate.
 176
 177             if J < Name_Len and then Column >= Max_Line_Length then
 178                Write_Str (""" &");
 179                Write_Eol.all;
 180                Write_Char ('"');
 181                Column := 1;
 182             end if;
 183          end loop;
 184
 185          Write_Char ('"');
 186          Column := Column + 1;
 187       end Output_String;
 188
 189       ----------------
 190       -- Start_Line --
 191       ----------------
 192
 193       procedure Start_Line (Indent : Natural) is
 194       begin
 195          if not Minimize_Empty_Lines then
 196             Write_Str ((1 .. Indent => ' '));
 197             Column := Column + Indent;
 198          end if;
 199       end Start_Line;
 200
 201       ----------------------
 202       -- Write_Empty_Line --
 203       ----------------------
 204
 205       procedure Write_Empty_Line (Always : Boolean := False) is
 206       begin
 207          if (Always or else not Minimize_Empty_Lines)
 208            and then not Last_Line_Is_Empty then
 209             Write_Eol.all;
 210             Column := 0;
 211             Last_Line_Is_Empty := True;
 212          end if;
 213       end Write_Empty_Line;
 214
 215       ----------------
 216       -- Write_Line --
 217       ----------------
 218
 219       procedure Write_Line (S : String) is
 220       begin
 221          Write_String (S);
 222          Last_Line_Is_Empty := False;
 223          Write_Eol.all;
 224          Column := 0;
 225       end Write_Line;
 226
 227       ------------------
 228       -- Write_String --
 229       ------------------
 230
 231       procedure Write_String (S : String) is
 232       begin
 233          --  If the string would not fit on the line,
 234          --  start a new line.
 235
 236          if Column + S'Length > Max_Line_Length then
 237             Write_Eol.all;
 238             Column := 0;
 239          end if;
 240
 241          Write_Str (S);
 242          Column := Column + S'Length;
 243       end Write_String;
 244
 245       -----------
 246       -- Print --
 247       -----------
 248
 249       procedure Print (Node   : Project_Node_Id; Indent : Natural) is
 250       begin
 251          if Node /= Empty_Node then
 252
 253             case Kind_Of (Node) is
 254
 255                when N_Project  =>
 256                   pragma Debug (Indicate_Tested (N_Project));
 257                   if First_With_Clause_Of (Node) /= Empty_Node then
 258
 259                      --  with clause(s)
 260
 261                      Print (First_With_Clause_Of (Node), Indent);
 262                      Write_Empty_Line (Always => True);
 263                   end if;
 264
 265                   Start_Line (Indent);
 266                   Write_String ("project ");
 267                   Output_Name (Name_Of (Node));
 268
 269                   --  Check if this project modifies another project
 270
 271                   if Modified_Project_Path_Of (Node) /= No_String then
 272                      Write_String (" extends ");
 273                      Output_String (Modified_Project_Path_Of (Node));
 274                   end if;
 275
 276                   Write_Line (" is");
 277                   Write_Empty_Line (Always => True);
 278
 279                   --  Output all of the declarations in the project
 280
 281                   Print (Project_Declaration_Of (Node), Indent);
 282                   Start_Line (Indent);
 283                   Write_String ("end ");
 284                   Output_Name (Name_Of (Node));
 285                   Write_Line (";");
 286
 287                when N_With_Clause =>
 288                   pragma Debug (Indicate_Tested (N_With_Clause));
 289
 290                   if Name_Of (Node) /= No_Name then
 291                      Start_Line (Indent);
 292                      Write_String ("with ");
 293                      Output_String (String_Value_Of (Node));
 294                      Write_Line (";");
 295                   end if;
 296
 297                   Print (Next_With_Clause_Of (Node), Indent);
 298
 299                when N_Project_Declaration =>
 300                   pragma Debug (Indicate_Tested (N_Project_Declaration));
 301
 302                   if First_Declarative_Item_Of (Node) /= Empty_Node then
 303                      Print
 304                        (First_Declarative_Item_Of (Node), Indent + Increment);
 305                      Write_Empty_Line (Always => True);
 306                   end if;
 307
 308                when N_Declarative_Item =>
 309                   pragma Debug (Indicate_Tested (N_Declarative_Item));
 310                   Print (Current_Item_Node (Node), Indent);
 311                   Print (Next_Declarative_Item (Node), Indent);
 312
 313                when N_Package_Declaration =>
 314                   pragma Debug (Indicate_Tested (N_Package_Declaration));
 315                   Write_Empty_Line (Always => True);
 316                   Start_Line (Indent);
 317                   Write_String ("package ");
 318                   Output_Name (Name_Of (Node));
 319
 320                   if Project_Of_Renamed_Package_Of (Node) /= Empty_Node then
 321                      Write_String (" renames ");
 322                      Output_Name
 323                        (Name_Of (Project_Of_Renamed_Package_Of (Node)));
 324                      Write_String (".");
 325                      Output_Name (Name_Of (Node));
 326                      Write_Line (";");
 327
 328                   else
 329                      Write_Line (" is");
 330
 331                      if First_Declarative_Item_Of (Node) /= Empty_Node then
 332                         Print
 333                           (First_Declarative_Item_Of (Node),
 334                            Indent + Increment);
 335                      end if;
 336
 337                      Start_Line (Indent);
 338                      Write_String ("end ");
 339                      Output_Name (Name_Of (Node));
 340                      Write_Line (";");
 341                      Write_Empty_Line;
 342                   end if;
 343
 344                when N_String_Type_Declaration =>
 345                   pragma Debug (Indicate_Tested (N_String_Type_Declaration));
 346                   Start_Line (Indent);
 347                   Write_String ("type ");
 348                   Output_Name (Name_Of (Node));
 349                   Write_Line (" is");
 350                   Start_Line (Indent + Increment);
 351                   Write_String ("(");
 352
 353                   declare
 354                      String_Node : Project_Node_Id :=
 355                        First_Literal_String (Node);
 356
 357                   begin
 358                      while String_Node /= Empty_Node loop
 359                         Output_String (String_Value_Of (String_Node));
 360                         String_Node := Next_Literal_String (String_Node);
 361
 362                         if String_Node /= Empty_Node then
 363                            Write_String (", ");
 364                         end if;
 365                      end loop;
 366                   end;
 367
 368                   Write_Line (");");
 369
 370                when N_Literal_String =>
 371                   pragma Debug (Indicate_Tested (N_Literal_String));
 372                   Output_String (String_Value_Of (Node));
 373
 374                when N_Attribute_Declaration =>
 375                   pragma Debug (Indicate_Tested (N_Attribute_Declaration));
 376                   Start_Line (Indent);
 377                   Write_String ("for ");
 378                   Output_Name (Name_Of (Node));
 379
 380                   if Associative_Array_Index_Of (Node) /= No_String then
 381                      Write_String (" (");
 382                      Output_String (Associative_Array_Index_Of (Node));
 383                      Write_String (")");
 384                   end if;
 385
 386                   Write_String (" use ");
 387                   Print (Expression_Of (Node), Indent);
 388                   Write_Line (";");
 389
 390                when N_Typed_Variable_Declaration =>
 391                   pragma Debug
 392                     (Indicate_Tested (N_Typed_Variable_Declaration));
 393                   Start_Line (Indent);
 394                   Output_Name (Name_Of (Node));
 395                   Write_String (" : ");
 396                   Output_Name (Name_Of (String_Type_Of (Node)));
 397                   Write_String (" := ");
 398                   Print (Expression_Of (Node), Indent);
 399                   Write_Line (";");
 400
 401                when N_Variable_Declaration =>
 402                   pragma Debug (Indicate_Tested (N_Variable_Declaration));
 403                   Start_Line (Indent);
 404                   Output_Name (Name_Of (Node));
 405                   Write_String (" := ");
 406                   Print (Expression_Of (Node), Indent);
 407                   Write_Line (";");
 408
 409                when N_Expression =>
 410                   pragma Debug (Indicate_Tested (N_Expression));
 411                   declare
 412                      Term : Project_Node_Id := First_Term (Node);
 413
 414                   begin
 415                      while Term /= Empty_Node loop
 416                         Print (Term, Indent);
 417                         Term := Next_Term (Term);
 418
 419                         if Term /= Empty_Node then
 420                            Write_String (" & ");
 421                         end if;
 422                      end loop;
 423                   end;
 424
 425                when N_Term =>
 426                   pragma Debug (Indicate_Tested (N_Term));
 427                   Print (Current_Term (Node), Indent);
 428
 429                when N_Literal_String_List =>
 430                   pragma Debug (Indicate_Tested (N_Literal_String_List));
 431                   Write_String ("(");
 432
 433                   declare
 434                      Expression : Project_Node_Id :=
 435                        First_Expression_In_List (Node);
 436
 437                   begin
 438                      while Expression /= Empty_Node loop
 439                         Print (Expression, Indent);
 440                         Expression := Next_Expression_In_List (Expression);
 441
 442                         if Expression /= Empty_Node then
 443                            Write_String (", ");
 444                         end if;
 445                      end loop;
 446                   end;
 447
 448                   Write_String (")");
 449
 450                when N_Variable_Reference =>
 451                   pragma Debug (Indicate_Tested (N_Variable_Reference));
 452                   if Project_Node_Of (Node) /= Empty_Node then
 453                      Output_Name (Name_Of (Project_Node_Of (Node)));
 454                      Write_String (".");
 455                   end if;
 456
 457                   if Package_Node_Of (Node) /= Empty_Node then
 458                      Output_Name (Name_Of (Package_Node_Of (Node)));
 459                      Write_String (".");
 460                   end if;
 461
 462                   Output_Name (Name_Of (Node));
 463
 464                when N_External_Value =>
 465                   pragma Debug (Indicate_Tested (N_External_Value));
 466                   Write_String ("external (");
 467                   Print (External_Reference_Of (Node), Indent);
 468
 469                   if External_Default_Of (Node) /= Empty_Node then
 470                      Write_String (", ");
 471                      Print (External_Default_Of (Node), Indent);
 472                   end if;
 473
 474                   Write_String (")");
 475
 476                when N_Attribute_Reference =>
 477                   pragma Debug (Indicate_Tested (N_Attribute_Reference));
 478
 479                   if Project_Node_Of (Node) /= Empty_Node
 480                     and then Project_Node_Of (Node) /= Project
 481                   then
 482                      Output_Name (Name_Of (Project_Node_Of (Node)));
 483
 484                      if Package_Node_Of (Node) /= Empty_Node then
 485                         Write_String (".");
 486                         Output_Name (Name_Of (Package_Node_Of (Node)));
 487                      end if;
 488
 489                   elsif Package_Node_Of (Node) /= Empty_Node then
 490                      Output_Name (Name_Of (Package_Node_Of (Node)));
 491
 492                   else
 493                      Write_String ("project");
 494                   end if;
 495
 496                   Write_String ("'");
 497                   Output_Name (Name_Of (Node));
 498
 499                   declare
 500                      Index : constant String_Id :=
 501                        Associative_Array_Index_Of (Node);
 502
 503                   begin
 504                      if Index /= No_String then
 505                         Write_String (" (");
 506                         Output_String (Index);
 507                         Write_String (")");
 508                      end if;
 509                   end;
 510
 511                when N_Case_Construction =>
 512                   pragma Debug (Indicate_Tested (N_Case_Construction));
 513
 514                   declare
 515                      Case_Item : Project_Node_Id := First_Case_Item_Of (Node);
 516                      Is_Non_Empty : Boolean := False;
 517                   begin
 518                      while Case_Item /= Empty_Node loop
 519                         if First_Declarative_Item_Of (Case_Item) /= Empty_Node
 520                           or else not Eliminate_Empty_Case_Constructions
 521                         then
 522                            Is_Non_Empty := True;
 523                            exit;
 524                         end if;
 525                         Case_Item := Next_Case_Item (Case_Item);
 526                      end loop;
 527
 528                      if Is_Non_Empty then
 529                         Write_Empty_Line;
 530                         Start_Line (Indent);
 531                         Write_String ("case ");
 532                         Print (Case_Variable_Reference_Of (Node), Indent);
 533                         Write_Line (" is");
 534
 535                         declare
 536                            Case_Item : Project_Node_Id :=
 537                              First_Case_Item_Of (Node);
 538
 539                         begin
 540                            while Case_Item /= Empty_Node loop
 541                               pragma Assert
 542                                 (Kind_Of (Case_Item) = N_Case_Item);
 543                               Print (Case_Item, Indent + Increment);
 544                               Case_Item := Next_Case_Item (Case_Item);
 545                            end loop;
 546                         end;
 547
 548                         Start_Line (Indent);
 549                         Write_Line ("end case;");
 550                      end if;
 551                   end;
 552
 553                when N_Case_Item =>
 554                   pragma Debug (Indicate_Tested (N_Case_Item));
 555
 556                   if First_Declarative_Item_Of (Node) /= Empty_Node
 557                     or else not Eliminate_Empty_Case_Constructions
 558                   then
 559                      Write_Empty_Line;
 560                      Start_Line (Indent);
 561                      Write_String ("when ");
 562
 563                      if First_Choice_Of (Node) = Empty_Node then
 564                         Write_String ("others");
 565
 566                      else
 567                         declare
 568                            Label : Project_Node_Id := First_Choice_Of (Node);
 569
 570                         begin
 571                            while Label /= Empty_Node loop
 572                               Print (Label, Indent);
 573                               Label := Next_Literal_String (Label);
 574
 575                               if Label /= Empty_Node then
 576                                  Write_String (" | ");
 577                               end if;
 578                            end loop;
 579                         end;
 580                      end if;
 581
 582                      Write_Line (" =>");
 583
 584                      declare
 585                         First : Project_Node_Id :=
 586                           First_Declarative_Item_Of (Node);
 587
 588                      begin
 589                         if First = Empty_Node then
 590                            Write_Eol.all;
 591
 592                         else
 593                            Print (First, Indent + Increment);
 594                         end if;
 595                      end;
 596                   end if;
 597             end case;
 598          end if;
 599       end Print;
 600
 601    begin
 602       if W_Char = null then
 603          Write_Char := Output.Write_Char'Access;
 604       else
 605          Write_Char := W_Char;
 606       end if;
 607
 608       if W_Eol = null then
 609          Write_Eol := Output.Write_Eol'Access;
 610       else
 611          Write_Eol := W_Eol;
 612       end if;
 613
 614       if W_Str = null then
 615          Write_Str := Output.Write_Str'Access;
 616       else
 617          Write_Str := W_Str;
 618       end if;
 619
 620       Print (Project, 0);
 621
 622       if W_Char = null or else W_Str = null then
 623          Output.Write_Eol;
 624       end if;
 625    end Pretty_Print;
 626
 627    -----------------------
 628    -- Output_Statistics --
 629    -----------------------
 630
 631    procedure Output_Statistics is
 632    begin
 633       Output.Write_Line ("Project_Node_Kinds not tested:");
 634
 635       for Kind in Project_Node_Kind loop
 636          if Not_Tested (Kind) then
 637             Output.Write_Str ("   ");
 638             Output.Write_Line (Project_Node_Kind'Image (Kind));
 639          end if;
 640       end loop;
 641
 642       Output.Write_Eol;
 643    end Output_Statistics;
 644
 645 end Prj.PP;