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