Subversion Repositories scarts

------------------------------------------------------------------------------

--                                                                          --

--                          GNAT SYSTEM UTILITIES                           --

--                                                                          --

--                               X N M A K E                                --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 2,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT;  see file COPYING.  If not, write --

-- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

--  Program to construct the spec and body of the Nmake package

--    Input files:

--       sinfo.ads     Spec of Sinfo package

--       nmake.adt     Template for Nmake package

--    Output files:

--       nmake.ads     Spec of Nmake package

--       nmake.adb     Body of Nmake package

--  Note: this program assumes that sinfo.ads has passed the error checks that

--  are carried out by the csinfo utility, so it does not duplicate these

--  checks and assumes that sinfo.ads has the correct form.

--   In the absence of any switches, both the ads and adb files are output.

--   The switch -s or /s indicates that only the ads file is to be output.

--   The switch -b or /b indicates that only the adb file is to be output.

--   If a file name argument is given, then the output is written to this file

--   rather than to nmake.ads or nmake.adb. A file name can only be given if

--   exactly one of the -s or -b options is present.

with Ada.Command_Line;              use Ada.Command_Line;

with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;

with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;

with Ada.Strings.Maps;              use Ada.Strings.Maps;

with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;

with Ada.Streams.Stream_IO;         use Ada.Streams.Stream_IO;

with Ada.Text_IO;                   use Ada.Text_IO;

with GNAT.Spitbol;                  use GNAT.Spitbol;

with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;

procedure XNmake is

   Err : exception;

   --  Raised to terminate execution

   A          : VString := Nul;

   Arg        : VString := Nul;

   Arg_List   : VString := Nul;

   Comment    : VString := Nul;

   Default    : VString := Nul;

   Field      : VString := Nul;

   Line       : VString := Nul;

   Node       : VString := Nul;

   Op_Name    : VString := Nul;

   Prevl      : VString := Nul;

   Synonym    : VString := Nul;

   X          : VString := Nul;

   NWidth : Natural;

   FileS : VString := V ("nmake.ads");

   FileB : VString := V ("nmake.adb");

   --  Set to null if corresponding file not to be generated

   Given_File : VString := Nul;

   --  File name given by command line argument

   subtype Sfile is Ada.Streams.Stream_IO.File_Type;

   InS,  InT  : Ada.Text_IO.File_Type;

   OutS, OutB : Sfile;

   wsp : Pattern := Span (' ' & ASCII.HT);

   Body_Only : Pattern := BreakX (' ') * X & Span (' ') & "--  body only";

   Spec_Only : Pattern := BreakX (' ') * X & Span (' ') & "--  spec only";

   Node_Hdr  : Pattern := wsp & "--  N_" & Rest * Node;

   Punc      : Pattern := BreakX (" .,");

   Binop     : Pattern := wsp & "--  plus fields for binary operator";

   Unop      : Pattern := wsp & "--  plus fields for unary operator";

   Syn       : Pattern := wsp & "--  " & Break (' ') * Synonym

                            & " (" & Break (')') * Field & Rest * Comment;

   Templ     : Pattern := BreakX ('T') * A & "T e m p l a t e";

   Spec      : Pattern := BreakX ('S') * A & "S p e c";

   Sem_Field : Pattern := BreakX ('-') & "-Sem";

   Lib_Field : Pattern := BreakX ('-') & "-Lib";

   Get_Field : Pattern := BreakX (Decimal_Digit_Set) * Field;

   Get_Dflt  : Pattern := BreakX ('(') & "(set to "

                            & Break (" ") * Default & " if";

   Next_Arg  : Pattern := Break (',') * Arg & ',';

   Op_Node   : Pattern := "Op_" & Rest * Op_Name;

   Shft_Rot  : Pattern := "Shift_" or "Rotate_";

   No_Ent    : Pattern := "Or_Else" or "And_Then" or "In" or "Not_In";

   M : Match_Result;

   V_String_Id : constant VString := V ("String_Id");

   V_Node_Id   : constant VString := V ("Node_Id");

   V_Name_Id   : constant VString := V ("Name_Id");

   V_List_Id   : constant VString := V ("List_Id");

   V_Elist_Id  : constant VString := V ("Elist_Id");

   V_Boolean   : constant VString := V ("Boolean");

   procedure Put_Line (F : Sfile; S : String);

   procedure Put_Line (F : Sfile; S : VString);

   --  Local version of Put_Line ensures Unix style line endings

   procedure WriteS  (S : String);

   procedure WriteB  (S : String);

   procedure WriteBS (S : String);

   procedure WriteS  (S : VString);

   procedure WriteB  (S : VString);

   procedure WriteBS (S : VString);

   --  Write given line to spec or body file or both if active

   procedure WriteB (S : String) is

   begin

      if FileB /= Nul then

         Put_Line (OutB, S);

      end if;

   end WriteB;

   procedure WriteB (S : VString) is

   begin

      if FileB /= Nul then

         Put_Line (OutB, S);

      end if;

   end WriteB;

   procedure WriteBS (S : String) is

   begin

      if FileB /= Nul then

         Put_Line (OutB, S);

      end if;

      if FileS /= Nul then

         Put_Line (OutS, S);

      end if;

   end WriteBS;

   procedure WriteBS (S : VString) is

   begin

      if FileB /= Nul then

         Put_Line (OutB, S);

      end if;

      if FileS /= Nul then

         Put_Line (OutS, S);

      end if;

   end WriteBS;

   procedure WriteS (S : String) is

   begin

      if FileS /= Nul then

         Put_Line (OutS, S);

      end if;

   end WriteS;

   procedure WriteS (S : VString) is

   begin

      if FileS /= Nul then

         Put_Line (OutS, S);

      end if;

   end WriteS;

   procedure Put_Line (F : Sfile; S : String) is

   begin

      String'Write (Stream (F), S);

      Character'Write (Stream (F), ASCII.LF);

   end Put_Line;

   procedure Put_Line (F : Sfile; S : VString) is

   begin

      Put_Line (F, To_String (S));

   end Put_Line;

--  Start of processing for XNmake

begin

   NWidth := 28;

   Anchored_Mode := True;

   for ArgN in 1 .. Argument_Count loop

      declare

         Arg : constant String := Argument (ArgN);

      begin

         if Arg (1) = '-' then

            if Arg'Length = 2

              and then (Arg (2) = 'b' or else Arg (2) = 'B')

            then

               FileS := Nul;

            elsif Arg'Length = 2

              and then (Arg (2) = 's' or else Arg (2) = 'S')

            then

               FileB := Nul;

            else

               raise Err;

            end if;

         else

            if Given_File /= Nul then

               raise Err;

            else

               Given_File := V (Arg);

            end if;

         end if;

      end;

   end loop;

   if FileS = Nul and then FileB = Nul then

      raise Err;

   elsif Given_File /= Nul then

      if FileB = Nul then

         FileS := Given_File;

      elsif FileS = Nul then

         FileB := Given_File;

      else

         raise Err;

      end if;

   end if;

   Open (InS, In_File, "sinfo.ads");

   Open (InT, In_File, "nmake.adt");

   if FileS /= Nul then

      Create (OutS, Out_File, S (FileS));

   end if;

   if FileB /= Nul then

      Create (OutB, Out_File, S (FileB));

   end if;

   Anchored_Mode := True;

   --  Copy initial part of template to spec and body

   loop

      Line := Get_Line (InT);

      --  Skip lines describing the template

      if Match (Line, "--  This file is a template") then

         loop

            Line := Get_Line (InT);

            exit when Line = "";

         end loop;

      end if;

      --  Loop keeps going until "package" keyword written

      exit when Match (Line, "package");

      --  Deal with WITH lines, writing to body or spec as appropriate

      if Match (Line, Body_Only, M) then

         Replace (M, X);

         WriteB (Line);

      elsif Match (Line, Spec_Only, M) then

         Replace (M, X);

         WriteS (Line);

      --  Change header from Template to Spec and write to spec file

      else

         if Match (Line, Templ, M) then

            Replace (M, A &  "    S p e c    ");

         end if;

         WriteS (Line);

         --  Write header line to body file

         if Match (Line, Spec, M) then

            Replace (M, A &  "B o d y");

         end if;

         WriteB (Line);

      end if;

   end loop;

   --  Package line reached

   WriteS ("package Nmake is");

   WriteB ("package body Nmake is");

   WriteB ("");

   --  Copy rest of lines up to template insert point to spec only

   loop

      Line := Get_Line (InT);

      exit when Match (Line, "!!TEMPLATE INSERTION POINT");

      WriteS (Line);

   end loop;

   --  Here we are doing the actual insertions, loop through node types

   loop

      Line := Get_Line (InS);

      if Match (Line, Node_Hdr)

        and then not Match (Node, Punc)

        and then Node /= "Unused"

      then

         exit when Node = "Empty";

         Prevl := "   function Make_" & Node & " (Sloc : Source_Ptr";

         Arg_List := Nul;

         --  Loop through fields of one node

         loop

            Line := Get_Line (InS);

            exit when Line = "";

            if Match (Line, Binop) then

               WriteBS (Prevl & ';');

               Append (Arg_List, "Left_Opnd,Right_Opnd,");

               WriteBS (

                 "      " & Rpad ("Left_Opnd",  NWidth) & " : Node_Id;");

               Prevl :=

                 "      " & Rpad ("Right_Opnd", NWidth) & " : Node_Id";

            elsif Match (Line, Unop) then

               WriteBS (Prevl & ';');

               Append (Arg_List, "Right_Opnd,");

               Prevl := "      " & Rpad ("Right_Opnd", NWidth) & " : Node_Id";

            elsif Match (Line, Syn) then

               if         Synonym /= "Prev_Ids"

                 and then Synonym /= "More_Ids"

                 and then Synonym /= "Comes_From_Source"

                 and then Synonym /= "Paren_Count"

                 and then not Match (Field, Sem_Field)

                 and then not Match (Field, Lib_Field)

               then

                  Match (Field, Get_Field);

                  if    Field = "Str"   then Field := V_String_Id;

                  elsif Field = "Node"  then Field := V_Node_Id;

                  elsif Field = "Name"  then Field := V_Name_Id;

                  elsif Field = "List"  then Field := V_List_Id;

                  elsif Field = "Elist" then Field := V_Elist_Id;

                  elsif Field = "Flag"  then Field := V_Boolean;

                  end if;

                  if Field = "Boolean" then

                     Default := V ("False");

                  else

                     Default := Nul;

                  end if;

                  Match (Comment, Get_Dflt);

                  WriteBS (Prevl & ';');

                  Append (Arg_List, Synonym & ',');

                  Rpad (Synonym, NWidth);

                  if Default = "" then

                     Prevl := "      " & Synonym & " : " & Field;

                  else

                     Prevl :=

                       "      " & Synonym & " : " & Field & " := " & Default;

                  end if;

               end if;

            end if;

         end loop;

         WriteBS (Prevl & ')');

         WriteS ("      return Node_Id;");

         WriteS ("   pragma Inline (Make_" & Node & ");");

         WriteB ("      return Node_Id");

         WriteB ("   is");

         WriteB ("      N : constant Node_Id :=");

         if Match (Node, "Defining_Identifier") or else

            Match (Node, "Defining_Character")  or else

            Match (Node, "Defining_Operator")

         then

            WriteB ("            New_Entity (N_" & Node & ", Sloc);");

         else

            WriteB ("            New_Node (N_" & Node & ", Sloc);");

         end if;

         WriteB ("   begin");

         while Match (Arg_List, Next_Arg, "") loop

            if Length (Arg) < NWidth then

               WriteB ("      Set_" & Arg & " (N, " & Arg & ");");

            else

               WriteB ("      Set_" & Arg);

               WriteB ("        (N, " & Arg & ");");

            end if;

         end loop;

         if Match (Node, Op_Node) then

            if Node = "Op_Plus" then

               WriteB ("      Set_Chars (N, Name_Op_Add);");

            elsif Node = "Op_Minus" then

               WriteB ("      Set_Chars (N, Name_Op_Subtract);");

            elsif Match (Op_Name, Shft_Rot) then

               WriteB ("      Set_Chars (N, Name_" & Op_Name & ");");

            else

               WriteB ("      Set_Chars (N, Name_" & Node & ");");

            end if;

            if not Match (Op_Name, No_Ent) then

               WriteB ("      Set_Entity (N, Standard_" & Node & ");");

            end if;

         end if;

         WriteB ("      return N;");

         WriteB ("   end Make_" & Node & ';');

         WriteBS ("");

      end if;

   end loop;

   WriteBS ("end Nmake;");

exception

   when Err =>

      Put_Line (Standard_Error, "usage: xnmake [-b] [-s] [filename]");

      Set_Exit_Status (1);

end XNmake;