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