blob: 41e86bcf50e30e0a99901319ee01361666b43ced [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT SYSTEM UTILITIES --
-- --
-- X S I N F O --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, 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 3, 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Program to construct C header file 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:
-- sinfo.h Corresponding c header file
-- An optional argument allows the specification of an output file name to
-- override the default 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;
with CSinfo;
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;
Term : VString := Nul;
InS : File_Type;
Ofile : File_Type;
wsp : constant Pattern := Span (' ' & ASCII.HT);
Wsp_For : constant Pattern := wsp & "for";
Is_Cmnt : constant Pattern := wsp & "--";
Typ_Nod : constant Pattern := wsp * A & "type Node_Kind is";
Get_Nam : constant Pattern := wsp * A & "N_" & Break (",)") * Nam
& Len (1) * Term;
Sub_Typ : constant Pattern := wsp * A & "subtype " & Break (' ') * N;
No_Cont : constant Pattern := wsp & Break (' ') * N1
& " .. " & Break (';') * N2;
Cont_N1 : constant Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0);
Cont_N2 : constant Pattern := Span (' ') & Break (';') * N2;
Is_Func : constant Pattern := wsp * A & "function " & Rest * Nam;
Get_Arg : constant 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
-------------
-- Getline --
-------------
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
-- First run CSinfo to check for errors. Note that CSinfo is also a
-- stand-alone program that can be run separately.
CSinfo;
Set_Exit_Status (1);
Anchored_Mode := True;
if Argument_Count > 0 then
Create (Ofile, Out_File, Argument (1));
else
Create (Ofile, Out_File, "sinfo.h");
end if;
Open (InS, In_File, "sinfo.ads");
-- Write header to output file
loop
Line := Get_Line (InS);
exit when Line = "";
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 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, "");
Put_Line (Ofile, "#ifdef __cplusplus");
Put_Line (Ofile, "extern ""C"" {");
Put_Line (Ofile, "#endif");
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;
-- Can't get here since above loop only left via raise
exception
when Done =>
Close (InS);
Put_Line (Ofile, "");
Put_Line (Ofile, "#ifdef __cplusplus");
Put_Line (Ofile, "}");
Put_Line (Ofile, "#endif");
Close (Ofile);
Set_Exit_Status (0);
end XSinfo;