gcc/ada/xnmake.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                          GNAT SYSTEM UTILITIES                           --
   4 --                                                                          --
   5 --                               X N M A K E                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2007, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 --  Program to construct the spec and body of the Nmake package
  27
  28 --    Input files:
  29
  30 --       sinfo.ads     Spec of Sinfo package
  31 --       nmake.adt     Template for Nmake package
  32
  33 --    Output files:
  34
  35 --       nmake.ads     Spec of Nmake package
  36 --       nmake.adb     Body of Nmake package
  37
  38 --  Note: this program assumes that sinfo.ads has passed the error checks that
  39 --  are carried out by the csinfo utility, so it does not duplicate these
  40 --  checks and assumes that sinfo.ads has the correct form.
  41
  42 --   In the absence of any switches, both the ads and adb files are output.
  43 --   The switch -s or /s indicates that only the ads file is to be output.
  44 --   The switch -b or /b indicates that only the adb file is to be output.
  45
  46 --   If a file name argument is given, then the output is written to this file
  47 --   rather than to nmake.ads or nmake.adb. A file name can only be given if
  48 --   exactly one of the -s or -b options is present.
  49
  50 with Ada.Command_Line;              use Ada.Command_Line;
  51 with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
  52 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
  53 with Ada.Strings.Maps;              use Ada.Strings.Maps;
  54 with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
  55 with Ada.Streams.Stream_IO;         use Ada.Streams.Stream_IO;
  56 with Ada.Text_IO;                   use Ada.Text_IO;
  57
  58 with GNAT.Spitbol;                  use GNAT.Spitbol;
  59 with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
  60
  61 procedure XNmake is
  62
  63    Err : exception;
  64    --  Raised to terminate execution
  65
  66    pragma Warnings (Off);
  67    --  The following are modified by * operator
  68
  69    A        : VString := Nul;
  70    Arg      : VString := Nul;
  71    Arg_List : VString := Nul;
  72    Comment  : VString := Nul;
  73    Default  : VString := Nul;
  74    Field    : VString := Nul;
  75    Line     : VString := Nul;
  76    Node     : VString := Nul;
  77    Op_Name  : VString := Nul;
  78    Prevl    : VString := Nul;
  79    Synonym  : VString := Nul;
  80    X        : VString := Nul;
  81
  82    NWidth : Natural;
  83
  84    FileS : VString := V ("nmake.ads");
  85    FileB : VString := V ("nmake.adb");
  86    --  Set to null if corresponding file not to be generated
  87
  88    Given_File : VString := Nul;
  89    --  File name given by command line argument
  90
  91    subtype Sfile is Ada.Streams.Stream_IO.File_Type;
  92
  93    InS,  InT  : Ada.Text_IO.File_Type;
  94    OutS, OutB : Sfile;
  95
  96    wsp : constant Pattern := Span (' ' & ASCII.HT);
  97
  98    Body_Only : constant Pattern := BreakX (' ') * X
  99                                    & Span (' ') & "--  body only";
 100    Spec_Only : constant Pattern := BreakX (' ') * X
 101                                    & Span (' ') & "--  spec only";
 102
 103    Node_Hdr  : constant Pattern := wsp & "--  N_" & Rest * Node;
 104    Punc      : constant Pattern := BreakX (" .,");
 105
 106    Binop     : constant Pattern := wsp
 107                                    & "--  plus fields for binary operator";
 108    Unop      : constant Pattern := wsp
 109                                    & "--  plus fields for unary operator";
 110    Syn       : constant Pattern := wsp & "--  " & Break (' ') * Synonym
 111                                    & " (" & Break (')') * Field
 112                                    & Rest * Comment;
 113
 114    Templ     : constant Pattern := BreakX ('T') * A & "T e m p l a t e";
 115    Spec      : constant Pattern := BreakX ('S') * A & "S p e c";
 116
 117    Sem_Field : constant Pattern := BreakX ('-') & "-Sem";
 118    Lib_Field : constant Pattern := BreakX ('-') & "-Lib";
 119
 120    Get_Field : constant Pattern := BreakX (Decimal_Digit_Set) * Field;
 121
 122    Get_Dflt  : constant Pattern := BreakX ('(') & "(set to "
 123                                    & Break (" ") * Default & " if";
 124
 125    Next_Arg  : constant Pattern := Break (',') * Arg & ',';
 126
 127    Op_Node   : constant Pattern := "Op_" & Rest * Op_Name;
 128
 129    Shft_Rot  : constant Pattern := "Shift_" or "Rotate_";
 130
 131    No_Ent    : constant Pattern := "Or_Else" or "And_Then"
 132                                      or "In" or "Not_In";
 133
 134    M : Match_Result;
 135
 136    V_String_Id : constant VString := V ("String_Id");
 137    V_Node_Id   : constant VString := V ("Node_Id");
 138    V_Name_Id   : constant VString := V ("Name_Id");
 139    V_List_Id   : constant VString := V ("List_Id");
 140    V_Elist_Id  : constant VString := V ("Elist_Id");
 141    V_Boolean   : constant VString := V ("Boolean");
 142
 143    procedure Put_Line (F : Sfile; S : String);
 144    procedure Put_Line (F : Sfile; S : VString);
 145    --  Local version of Put_Line ensures Unix style line endings
 146
 147    procedure WriteS  (S : String);
 148    procedure WriteB  (S : String);
 149    procedure WriteBS (S : String);
 150    procedure WriteS  (S : VString);
 151    procedure WriteB  (S : VString);
 152    procedure WriteBS (S : VString);
 153    --  Write given line to spec or body file or both if active
 154
 155    procedure WriteB (S : String) is
 156    begin
 157       if FileB /= Nul then
 158          Put_Line (OutB, S);
 159       end if;
 160    end WriteB;
 161
 162    procedure WriteB (S : VString) is
 163    begin
 164       if FileB /= Nul then
 165          Put_Line (OutB, S);
 166       end if;
 167    end WriteB;
 168
 169    procedure WriteBS (S : String) is
 170    begin
 171       if FileB /= Nul then
 172          Put_Line (OutB, S);
 173       end if;
 174
 175       if FileS /= Nul then
 176          Put_Line (OutS, S);
 177       end if;
 178    end WriteBS;
 179
 180    procedure WriteBS (S : VString) is
 181    begin
 182       if FileB /= Nul then
 183          Put_Line (OutB, S);
 184       end if;
 185
 186       if FileS /= Nul then
 187          Put_Line (OutS, S);
 188       end if;
 189    end WriteBS;
 190
 191    procedure WriteS (S : String) is
 192    begin
 193       if FileS /= Nul then
 194          Put_Line (OutS, S);
 195       end if;
 196    end WriteS;
 197
 198    procedure WriteS (S : VString) is
 199    begin
 200       if FileS /= Nul then
 201          Put_Line (OutS, S);
 202       end if;
 203    end WriteS;
 204
 205    procedure Put_Line (F : Sfile; S : String) is
 206    begin
 207       String'Write (Stream (F), S);
 208       Character'Write (Stream (F), ASCII.LF);
 209    end Put_Line;
 210
 211    procedure Put_Line (F : Sfile; S : VString) is
 212    begin
 213       Put_Line (F, To_String (S));
 214    end Put_Line;
 215
 216 --  Start of processing for XNmake
 217
 218 begin
 219    NWidth := 28;
 220    Anchored_Mode := True;
 221
 222    for ArgN in 1 .. Argument_Count loop
 223       declare
 224          Arg : constant String := Argument (ArgN);
 225
 226       begin
 227          if Arg (1) = '-' then
 228             if Arg'Length = 2
 229               and then (Arg (2) = 'b' or else Arg (2) = 'B')
 230             then
 231                FileS := Nul;
 232
 233             elsif Arg'Length = 2
 234               and then (Arg (2) = 's' or else Arg (2) = 'S')
 235             then
 236                FileB := Nul;
 237
 238             else
 239                raise Err;
 240             end if;
 241
 242          else
 243             if Given_File /= Nul then
 244                raise Err;
 245             else
 246                Given_File := V (Arg);
 247             end if;
 248          end if;
 249       end;
 250    end loop;
 251
 252    if FileS = Nul and then FileB = Nul then
 253       raise Err;
 254
 255    elsif Given_File /= Nul then
 256       if FileB = Nul then
 257          FileS := Given_File;
 258
 259       elsif FileS = Nul then
 260          FileB := Given_File;
 261
 262       else
 263          raise Err;
 264       end if;
 265    end if;
 266
 267    Open (InS, In_File, "sinfo.ads");
 268    Open (InT, In_File, "nmake.adt");
 269
 270    if FileS /= Nul then
 271       Create (OutS, Out_File, S (FileS));
 272    end if;
 273
 274    if FileB /= Nul then
 275       Create (OutB, Out_File, S (FileB));
 276    end if;
 277
 278    Anchored_Mode := True;
 279
 280    --  Copy initial part of template to spec and body
 281
 282    loop
 283       Line := Get_Line (InT);
 284
 285       --  Skip lines describing the template
 286
 287       if Match (Line, "--  This file is a template") then
 288          loop
 289             Line := Get_Line (InT);
 290             exit when Line = "";
 291          end loop;
 292       end if;
 293
 294       --  Loop keeps going until "package" keyword written
 295
 296       exit when Match (Line, "package");
 297
 298       --  Deal with WITH lines, writing to body or spec as appropriate
 299
 300       if Match (Line, Body_Only, M) then
 301          Replace (M, X);
 302          WriteB (Line);
 303
 304       elsif Match (Line, Spec_Only, M) then
 305          Replace (M, X);
 306          WriteS (Line);
 307
 308       --  Change header from Template to Spec and write to spec file
 309
 310       else
 311          if Match (Line, Templ, M) then
 312             Replace (M, A &  "    S p e c    ");
 313          end if;
 314
 315          WriteS (Line);
 316
 317          --  Write header line to body file
 318
 319          if Match (Line, Spec, M) then
 320             Replace (M, A &  "B o d y");
 321          end if;
 322
 323          WriteB (Line);
 324       end if;
 325    end loop;
 326
 327    --  Package line reached
 328
 329    WriteS ("package Nmake is");
 330    WriteB ("package body Nmake is");
 331    WriteB ("");
 332
 333    --  Copy rest of lines up to template insert point to spec only
 334
 335    loop
 336       Line := Get_Line (InT);
 337       exit when Match (Line, "!!TEMPLATE INSERTION POINT");
 338       WriteS (Line);
 339    end loop;
 340
 341    --  Here we are doing the actual insertions, loop through node types
 342
 343    loop
 344       Line := Get_Line (InS);
 345
 346       if Match (Line, Node_Hdr)
 347         and then not Match (Node, Punc)
 348         and then Node /= "Unused"
 349       then
 350          exit when Node = "Empty";
 351          Prevl := "   function Make_" & Node & " (Sloc : Source_Ptr";
 352          Arg_List := Nul;
 353
 354          --  Loop through fields of one node
 355
 356          loop
 357             Line := Get_Line (InS);
 358             exit when Line = "";
 359
 360             if Match (Line, Binop) then
 361                WriteBS (Prevl & ';');
 362                Append (Arg_List, "Left_Opnd,Right_Opnd,");
 363                WriteBS (
 364                  "      " & Rpad ("Left_Opnd",  NWidth) & " : Node_Id;");
 365                Prevl :=
 366                  "      " & Rpad ("Right_Opnd", NWidth) & " : Node_Id";
 367
 368             elsif Match (Line, Unop) then
 369                WriteBS (Prevl & ';');
 370                Append (Arg_List, "Right_Opnd,");
 371                Prevl := "      " & Rpad ("Right_Opnd", NWidth) & " : Node_Id";
 372
 373             elsif Match (Line, Syn) then
 374                if         Synonym /= "Prev_Ids"
 375                  and then Synonym /= "More_Ids"
 376                  and then Synonym /= "Comes_From_Source"
 377                  and then Synonym /= "Paren_Count"
 378                  and then not Match (Field, Sem_Field)
 379                  and then not Match (Field, Lib_Field)
 380                then
 381                   Match (Field, Get_Field);
 382
 383                   if    Field = "Str"   then
 384                      Field := V_String_Id;
 385                   elsif Field = "Node"  then
 386                      Field := V_Node_Id;
 387                   elsif Field = "Name"  then
 388                      Field := V_Name_Id;
 389                   elsif Field = "List"  then
 390                      Field := V_List_Id;
 391                   elsif Field = "Elist" then
 392                      Field := V_Elist_Id;
 393                   elsif Field = "Flag"  then
 394                      Field := V_Boolean;
 395                   end if;
 396
 397                   if Field = "Boolean" then
 398                      Default := V ("False");
 399                   else
 400                      Default := Nul;
 401                   end if;
 402
 403                   Match (Comment, Get_Dflt);
 404
 405                   WriteBS (Prevl & ';');
 406                   Append (Arg_List, Synonym & ',');
 407                   Rpad (Synonym, NWidth);
 408
 409                   if Default = "" then
 410                      Prevl := "      " & Synonym & " : " & Field;
 411                   else
 412                      Prevl :=
 413                        "      " & Synonym & " : " & Field & " := " & Default;
 414                   end if;
 415                end if;
 416             end if;
 417          end loop;
 418
 419          WriteBS (Prevl & ')');
 420          WriteS ("      return Node_Id;");
 421          WriteS ("   pragma Inline (Make_" & Node & ");");
 422          WriteB ("      return Node_Id");
 423          WriteB ("   is");
 424          WriteB ("      N : constant Node_Id :=");
 425
 426          if Match (Node, "Defining_Identifier") or else
 427             Match (Node, "Defining_Character")  or else
 428             Match (Node, "Defining_Operator")
 429          then
 430             WriteB ("            New_Entity (N_" & Node & ", Sloc);");
 431          else
 432             WriteB ("            New_Node (N_" & Node & ", Sloc);");
 433          end if;
 434
 435          WriteB ("   begin");
 436
 437          while Match (Arg_List, Next_Arg, "") loop
 438             if Length (Arg) < NWidth then
 439                WriteB ("      Set_" & Arg & " (N, " & Arg & ");");
 440             else
 441                WriteB ("      Set_" & Arg);
 442                WriteB ("        (N, " & Arg & ");");
 443             end if;
 444          end loop;
 445
 446          if Match (Node, Op_Node) then
 447             if Node = "Op_Plus" then
 448                WriteB ("      Set_Chars (N, Name_Op_Add);");
 449
 450             elsif Node = "Op_Minus" then
 451                WriteB ("      Set_Chars (N, Name_Op_Subtract);");
 452
 453             elsif Match (Op_Name, Shft_Rot) then
 454                WriteB ("      Set_Chars (N, Name_" & Op_Name & ");");
 455
 456             else
 457                WriteB ("      Set_Chars (N, Name_" & Node & ");");
 458             end if;
 459
 460             if not Match (Op_Name, No_Ent) then
 461                WriteB ("      Set_Entity (N, Standard_" & Node & ");");
 462             end if;
 463          end if;
 464
 465          WriteB ("      return N;");
 466          WriteB ("   end Make_" & Node & ';');
 467          WriteBS ("");
 468       end if;
 469    end loop;
 470
 471    WriteBS ("end Nmake;");
 472
 473 exception
 474
 475    when Err =>
 476       Put_Line (Standard_Error, "usage: xnmake [-b] [-s] [filename]");
 477       Set_Exit_Status (1);
 478
 479 end XNmake;