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