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