358 lines
12 KiB
Ada
358 lines
12 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT SYSTEM UTILITIES --
|
|
-- --
|
|
-- X T R E E P R S --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2010, 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 the spec of the Treeprs package
|
|
|
|
-- Input files:
|
|
|
|
-- sinfo.ads Spec of Sinfo package
|
|
-- treeprs.adt Template for Treeprs package
|
|
|
|
-- Output files:
|
|
|
|
-- treeprs.ads Spec of Treeprs package
|
|
|
|
-- 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
|
|
|
|
-- An optional argument allows the specification of an output file name to
|
|
-- override the default treeprs.ads 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 Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
|
|
|
|
with GNAT.Spitbol; use GNAT.Spitbol;
|
|
with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
|
|
with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean;
|
|
with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString;
|
|
|
|
procedure XTreeprs is
|
|
|
|
package TB renames GNAT.Spitbol.Table_Boolean;
|
|
package TV renames GNAT.Spitbol.Table_VString;
|
|
|
|
Err : exception;
|
|
-- Raised on fatal error
|
|
|
|
A : VString := Nul;
|
|
Ffield : VString := Nul;
|
|
Field : VString := Nul;
|
|
Fieldno : VString := Nul;
|
|
Flagno : VString := Nul;
|
|
Line : VString := Nul;
|
|
Name : VString := Nul;
|
|
Node : VString := Nul;
|
|
Outstring : VString := Nul;
|
|
Prefix : VString := Nul;
|
|
S : VString := Nul;
|
|
S1 : VString := Nul;
|
|
Syn : VString := Nul;
|
|
Synonym : VString := Nul;
|
|
Term : VString := Nul;
|
|
|
|
subtype Sfile is Ada.Streams.Stream_IO.File_Type;
|
|
|
|
OutS : Sfile;
|
|
-- Output file
|
|
|
|
InS : Ada.Text_IO.File_Type;
|
|
-- Read sinfo.ads
|
|
|
|
InT : Ada.Text_IO.File_Type;
|
|
-- Read treeprs.adt
|
|
|
|
Special : TB.Table (20);
|
|
-- Table of special fields. These fields are not included in the table
|
|
-- constructed by Xtreeprs, since they are specially handled in treeprs.
|
|
-- This means these field definitions are completely ignored.
|
|
|
|
Names : array (1 .. 500) of VString;
|
|
-- Table of names of synonyms
|
|
|
|
Positions : array (1 .. 500) of Natural;
|
|
-- Table of starting positions in Pchars string for synonyms
|
|
|
|
Strings : TV.Table (300);
|
|
-- Contribution of each synonym to Pchars string, indexed by name
|
|
|
|
Count : Natural := 0;
|
|
-- Number of synonyms processed so far
|
|
|
|
Curpos : Natural := 1;
|
|
-- Number of characters generated in Pchars string so far
|
|
|
|
Lineno : Natural := 0;
|
|
-- Line number in sinfo.ads
|
|
|
|
Field_Base : constant := Character'Pos ('#');
|
|
-- Fields 1-5 are represented by the characters #$%&' (i.e. by five
|
|
-- contiguous characters starting at # (16#23#)).
|
|
|
|
Flag_Base : constant := Character'Pos ('(');
|
|
-- Flags 1-18 are represented by the characters ()*+,-./0123456789
|
|
-- (i.e. by 18 contiguous characters starting at (16#28#)).
|
|
|
|
Fieldch : Character;
|
|
-- Field character, as per above tables
|
|
|
|
Sp : aliased Natural;
|
|
-- Space left on line for Pchars output
|
|
|
|
wsp : constant Pattern := Span (' ' & ASCII.HT);
|
|
Is_Temp : constant Pattern := BreakX ('T') * A & "T e m p l a t e";
|
|
Get_Node : constant Pattern := wsp & "-- N_" & Rest * Node;
|
|
Tst_Punc : constant Pattern := Break (" ,.");
|
|
Get_Syn : constant Pattern := Span (' ') & "-- " & Break (' ') * Synonym
|
|
& " (" & Break (')') * Field;
|
|
Brk_Min : constant Pattern := Break ('-') * Ffield;
|
|
Is_Flag : constant Pattern := "Flag" & Rest * Flagno;
|
|
Is_Field : constant Pattern := Rtab (1) & Len (1) * Fieldno;
|
|
Is_Syn : constant Pattern := wsp & "N_" & Break (",)") * Syn
|
|
& Len (1) * Term;
|
|
Brk_Node : constant Pattern := Break (' ') * Node & ' ';
|
|
Chop_SP : constant Pattern := Len (Sp'Unrestricted_Access) * S1;
|
|
|
|
M : Match_Result;
|
|
|
|
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 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 XTreeprs
|
|
|
|
begin
|
|
Anchored_Mode := True;
|
|
|
|
if Argument_Count > 0 then
|
|
Create (OutS, Out_File, Argument (1));
|
|
else
|
|
Create (OutS, Out_File, "treeprs.ads");
|
|
end if;
|
|
|
|
Open (InS, In_File, "sinfo.ads");
|
|
Open (InT, In_File, "treeprs.adt");
|
|
|
|
-- Initialize special fields table
|
|
|
|
Set (Special, "Analyzed", True);
|
|
Set (Special, "Cannot_Be_Constant", True);
|
|
Set (Special, "Chars", True);
|
|
Set (Special, "Comes_From_Source", True);
|
|
Set (Special, "Error_Posted", True);
|
|
Set (Special, "Etype", True);
|
|
Set (Special, "Has_No_Side_Effects", True);
|
|
Set (Special, "Is_Controlling_Actual", True);
|
|
Set (Special, "Is_Overloaded", True);
|
|
Set (Special, "Is_Static_Expression", True);
|
|
Set (Special, "Left_Opnd", True);
|
|
Set (Special, "Must_Check_Expr", True);
|
|
Set (Special, "No_Overflow_Expr", True);
|
|
Set (Special, "Paren_Count", True);
|
|
Set (Special, "Raises_Constraint_Error", True);
|
|
Set (Special, "Right_Opnd", True);
|
|
|
|
-- Read template header and generate new header
|
|
|
|
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;
|
|
|
|
exit when Match (Line, "package");
|
|
|
|
if Match (Line, Is_Temp, M) then
|
|
Replace (M, A & " S p e c ");
|
|
end if;
|
|
|
|
Put_Line (OutS, Line);
|
|
end loop;
|
|
|
|
Put_Line (OutS, Line);
|
|
|
|
-- Copy rest of comments up to template insert point to spec
|
|
|
|
loop
|
|
Line := Get_Line (InT);
|
|
exit when Match (Line, "!!TEMPLATE INSERTION POINT");
|
|
Put_Line (OutS, Line);
|
|
end loop;
|
|
|
|
-- Here we are doing the actual insertions
|
|
|
|
Put_Line (OutS, " Pchars : constant String :=");
|
|
|
|
-- Loop through comments describing nodes, picking up fields
|
|
|
|
loop
|
|
Line := Get_Line (InS);
|
|
Lineno := Lineno + 1;
|
|
exit when Match (Line, " type Node_Kind");
|
|
|
|
if Match (Line, Get_Node)
|
|
and then not Match (Node, Tst_Punc)
|
|
then
|
|
Outstring := Node & ' ';
|
|
|
|
loop
|
|
Line := Get_Line (InS);
|
|
exit when Line = "";
|
|
|
|
if Match (Line, Get_Syn)
|
|
and then not Match (Synonym, "plus")
|
|
and then not Present (Special, Synonym)
|
|
then
|
|
-- Convert this field into the character used to
|
|
-- represent the field according to the table:
|
|
|
|
-- Field1 '#'
|
|
-- Field2 '$'
|
|
-- Field3 '%'
|
|
-- Field4 '&'
|
|
-- Field5 "'"
|
|
-- Flag4 '+'
|
|
-- Flag5 ','
|
|
-- Flag6 '-'
|
|
-- Flag7 '.'
|
|
-- Flag8 '/'
|
|
-- Flag9 '0'
|
|
-- Flag10 '1'
|
|
-- Flag11 '2'
|
|
-- Flag12 '3'
|
|
-- Flag13 '4'
|
|
-- Flag14 '5'
|
|
-- Flag15 '6'
|
|
-- Flag16 '7'
|
|
-- Flag17 '8'
|
|
-- Flag18 '9'
|
|
|
|
if Match (Field, Brk_Min) then
|
|
Field := Ffield;
|
|
end if;
|
|
|
|
if Match (Field, Is_Flag) then
|
|
Fieldch := Char (Flag_Base - 1 + N (Flagno));
|
|
|
|
elsif Match (Field, Is_Field) then
|
|
Fieldch := Char (Field_Base - 1 + N (Fieldno));
|
|
|
|
else
|
|
Put_Line
|
|
(Standard_Error,
|
|
"*** Line " &
|
|
Lineno &
|
|
" has unrecognized field name " &
|
|
Field);
|
|
raise Err;
|
|
end if;
|
|
|
|
Append (Outstring, Fieldch & Synonym);
|
|
end if;
|
|
end loop;
|
|
|
|
Set (Strings, Node, Outstring);
|
|
end if;
|
|
end loop;
|
|
|
|
-- Loop through actual definitions of node kind enumeration literals
|
|
|
|
loop
|
|
loop
|
|
Line := Get_Line (InS);
|
|
Lineno := Lineno + 1;
|
|
exit when Match (Line, Is_Syn);
|
|
end loop;
|
|
|
|
S := Get (Strings, Syn);
|
|
Match (S, Brk_Node, "");
|
|
Count := Count + 1;
|
|
Names (Count) := Syn;
|
|
Positions (Count) := Curpos;
|
|
Curpos := Curpos + Length (S);
|
|
Put_Line (OutS, " -- " & Node);
|
|
Prefix := V (" ");
|
|
exit when Term = ")";
|
|
|
|
-- Loop to output the string literal for Pchars
|
|
|
|
loop
|
|
Sp := 79 - 4 - Length (Prefix);
|
|
exit when Size (S) <= Sp;
|
|
Match (S, Chop_SP, "");
|
|
Put_Line (OutS, Prefix & '"' & S1 & """ &");
|
|
Prefix := V (" ");
|
|
end loop;
|
|
|
|
Put_Line (OutS, Prefix & '"' & S & """ &");
|
|
end loop;
|
|
|
|
Put_Line (OutS, " """";");
|
|
Put_Line (OutS, "");
|
|
Put_Line
|
|
(OutS, " type Pchar_Pos_Array is array (Node_Kind) of Positive;");
|
|
Put_Line
|
|
(OutS,
|
|
" Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'(");
|
|
|
|
-- Output lines for Pchar_Pos_Array values
|
|
|
|
for M in 1 .. Count - 1 loop
|
|
Name := Rpad ("N_" & Names (M), 40);
|
|
Put_Line (OutS, " " & Name & " => " & Positions (M) & ',');
|
|
end loop;
|
|
|
|
Name := Rpad ("N_" & Names (Count), 40);
|
|
Put_Line (OutS, " " & Name & " => " & Positions (Count) & ");");
|
|
|
|
Put_Line (OutS, "");
|
|
Put_Line (OutS, "end Treeprs;");
|
|
|
|
exception
|
|
when Err =>
|
|
Put_Line (Standard_Error, "*** fatal error");
|
|
Set_Exit_Status (1);
|
|
|
|
end XTreeprs;
|