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