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;
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;
InS : Ada.Text_IO.File_Type;
InT : Ada.Text_IO.File_Type;
Special : TB.Table (20);
Names : array (1 .. 500) of VString;
Positions : array (1 .. 500) of Natural;
Strings : TV.Table (300);
Count : Natural := 0;
Curpos : Natural := 1;
Lineno : Natural := 0;
Field_Base : constant := Character'Pos ('#');
Flag_Base : constant := Character'Pos ('(');
Fieldch : Character;
Sp : aliased Natural;
wsp : Pattern := Span (' ' & ASCII.HT);
Is_Temp : Pattern := BreakX ('T') * A & "T e m p l a t e";
Get_Node : Pattern := wsp & "-- N_" & Rest * Node;
Tst_Punc : Pattern := Break (" ,.");
Get_Syn : Pattern := Span (' ') & "-- " & Break (' ') * Synonym
& " (" & Break (')') * Field;
Brk_Min : Pattern := Break ('-') * Ffield;
Is_Flag : Pattern := "Flag" & Rest * Flagno;
Is_Field : Pattern := Rtab (1) & Len (1) * Fieldno;
Is_Syn : Pattern := wsp & "N_" & Break (",)") * Syn & Len (1) * Term;
Brk_Node : Pattern := Break (' ') * Node & ' ';
Chop_SP : Pattern := Len (Sp'Unrestricted_Access) * S1;
M : Match_Result;
procedure Put_Line (F : Sfile; S : String);
procedure Put_Line (F : Sfile; S : VString);
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;
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");
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);
loop
Line := Get_Line (InT);
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);
loop
Line := Get_Line (InT);
exit when Match (Line, "!!TEMPLATE INSERTION POINT");
Put_Line (OutS, Line);
end loop;
Put_Line (OutS, " Pchars : constant String :=");
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
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
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
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'(");
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;