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