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