New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45960 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 261 insertions, 0 deletions

diff --git a/gcc/ada/xsinfo.adb b/gcc/ada/xsinfo.adb
new file mode 100644
index 00000000000..57d4b3e1580
--- /dev/null
+++ b/gcc/ada/xsinfo.adb
@@ -0,0 +1,261 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                          GNAT SYSTEM UTILITIES                           --
+--                                                                          --
+--                               X S I N F O                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.19 $
+--                                                                          --
+--          Copyright (C) 1992-2000 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,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Program to construct C header file a-sinfo.h (C version of sinfo.ads spec,
+--  for use by Gigi, contains all definitions and access functions, but does
+--  not contain set procedures, since Gigi never modifies the GNAT tree)
+
+--    Input files:
+
+--       sinfo.ads     Spec of Sinfo package
+
+--    Output files:
+
+--       a-sinfo.h     Corresponding c header file
+
+--  Note: this program assumes that sinfo.ads has passed the error checks
+--  which are carried out by the CSinfo utility, so it does not duplicate
+--  these checks and assumes the soruce is correct.
+
+--  An optional argument allows the specification of an output file name to
+--  override the default a-sinfo.h file name for the generated output file.
+
+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.Text_IO;                   use Ada.Text_IO;
+
+with GNAT.Spitbol;                  use GNAT.Spitbol;
+with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
+
+procedure XSinfo is
+
+   Done : exception;
+   Err  : exception;
+
+   A         : VString := Nul;
+   Arg       : VString := Nul;
+   Comment   : VString := Nul;
+   Line      : VString := Nul;
+   N         : VString := Nul;
+   N1, N2    : VString := Nul;
+   Nam       : VString := Nul;
+   Rtn       : VString := Nul;
+   Sinforev  : VString := Nul;
+   Term      : VString := Nul;
+   XSinforev : VString := Nul;
+
+   InS       : File_Type;
+   Ofile     : File_Type;
+
+   wsp     : Pattern := Span (' ' & ASCII.HT);
+   Get_Vsn : Pattern := BreakX ('$') & "$Rev" & "ision: "
+                          & Break (' ') * Sinforev;
+   Wsp_For : Pattern := wsp & "for";
+   Is_Cmnt : Pattern := wsp & "--";
+   Typ_Nod : Pattern := wsp * A & "type Node_Kind is";
+   Get_Nam : Pattern := wsp * A & "N_" &  Break (",)") * Nam
+                          & Len (1) * Term;
+   Sub_Typ : Pattern := wsp * A & "subtype " &  Break (' ') * N;
+   No_Cont : Pattern := wsp & Break (' ') * N1 & " .. " & Break (';') * N2;
+   Cont_N1 : Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0);
+   Cont_N2 : Pattern := Span (' ') & Break (';') * N2;
+   Is_Func : Pattern := wsp * A & "function " & Rest * Nam;
+   Get_Arg : Pattern := wsp & "(N : " & Break (')') * Arg
+                          & ") return " & Break (';') * Rtn
+                          & ';' & wsp & "--" & wsp & Rest * Comment;
+
+   NKV : Natural;
+
+   M : Match_Result;
+
+
+   procedure Getline;
+   --  Get non-comment, non-blank line. Also skips "for " rep clauses.
+
+   procedure Getline is
+   begin
+      loop
+         Line := Get_Line (InS);
+
+         if Line /= ""
+           and then not Match (Line, Wsp_For)
+           and then not Match (Line, Is_Cmnt)
+         then
+            return;
+
+         elsif Match (Line, "   --  End functions (note") then
+            raise Done;
+         end if;
+      end loop;
+   end Getline;
+
+--  Start of processing for XSinfo
+
+begin
+   Set_Exit_Status (1);
+   Anchored_Mode := True;
+   Match ("$Revision: 1.19 $", "$Rev" & "ision: "  & Break (' ') * XSinforev);
+
+   if Argument_Count > 0 then
+      Create (Ofile, Out_File, Argument (1));
+   else
+      Create (Ofile, Out_File, "a-sinfo.h");
+   end if;
+
+   Open (InS, In_File, "sinfo.ads");
+
+   --  Get Sinfo rev and write header to output file
+
+   loop
+      Line := Get_Line (InS);
+      exit when Line = "";
+
+      if Match (Line, Get_Vsn) then
+         Put_Line
+           (Ofile, "/*                 Generated by xsinfo revision "
+            & XSinforev & " using                  */");
+         Put_Line
+           (Ofile, "/*                         sinfo.ads revision "
+            & Sinforev & "                         */");
+
+      else
+         Match
+           (Line,
+            "--                                 S p e c       ",
+            "--                              C Header File    ");
+
+         Match (Line, "--", "/*");
+         Match (Line, Rtab (2) * A & "--", M);
+         Replace (M, A & "*/");
+         Put_Line (Ofile, Line);
+      end if;
+   end loop;
+
+   --  Skip to package line
+
+   loop
+      Getline;
+      exit when Match (Line, "package");
+   end loop;
+
+   --  Skip to first node kind line
+
+   loop
+      Getline;
+      exit when Match (Line, Typ_Nod);
+      Put_Line (Ofile, Line);
+   end loop;
+
+   Put_Line (Ofile, "");
+   NKV := 0;
+
+   --  Loop through node kind codes
+
+   loop
+      Getline;
+
+      if Match (Line, Get_Nam) then
+         Put_Line (Ofile, A & "#define N_" & Nam & ' ' & NKV);
+         NKV := NKV + 1;
+         exit when not Match (Term, ",");
+
+      else
+         Put_Line (Ofile, Line);
+      end if;
+   end loop;
+
+   Put_Line (Ofile, "");
+   Put_Line (Ofile, A & "#define Number_Node_Kinds " & NKV);
+
+   --  Loop through subtype declarations
+
+   loop
+      Getline;
+
+      if not Match (Line, Sub_Typ) then
+         exit when Match (Line, "   function");
+         Put_Line (Ofile, Line);
+
+      else
+         Put_Line (Ofile, A & "SUBTYPE (" & N & ", Node_Kind, ");
+         Getline;
+
+         --  Normal case
+
+         if Match (Line, No_Cont) then
+            Put_Line (Ofile, A & "   " & N1 & ", " & N2 & ')');
+
+         --  Continuation case
+
+         else
+            if not Match (Line, Cont_N1) then
+               raise Err;
+            end if;
+
+            Getline;
+
+            if not Match (Line, Cont_N2) then
+               raise Err;
+            end if;
+
+            Put_Line (Ofile,  A & "   " & N1 & ',');
+            Put_Line (Ofile,  A & "   " & N2 & ')');
+         end if;
+      end if;
+   end loop;
+
+   --  Loop through functions. Note that this loop is terminated by
+   --  the call to Getfile encountering the end of functions sentinel
+
+   loop
+      if Match (Line, Is_Func) then
+         Getline;
+            if not Match (Line, Get_Arg) then
+               raise Err;
+            end if;
+         Put_Line
+           (Ofile,
+            A &  "INLINE " & Rpad (Rtn, 9)
+            & ' ' & Rpad (Nam, 30) & " (" & Arg & " N)");
+
+         Put_Line (Ofile,  A & "   { return " & Comment & " (N); }");
+
+      else
+         Put_Line (Ofile, Line);
+      end if;
+
+      Getline;
+   end loop;
+
+exception
+   when Done =>
+      Put_Line (Ofile, "");
+      Set_Exit_Status (0);
+
+end XSinfo;