with Ada.Command_Line; use Ada.Command_Line;
with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Strings.Maps; use Ada.Strings.Maps;
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Spitbol; use GNAT.Spitbol;
with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString;
procedure Xgnatugn is
procedure Usage;
Output_File : File_Type;
type Input_File is record
Name : VString;
Data : File_Type;
Line : Natural := 0;
end record;
function Get_Line (Input : access Input_File) return String;
Number_Of_Warnings : Natural := 0;
Number_Of_Errors : Natural := 0;
Warnings_Enabled : Boolean;
procedure Error
(Input : Input_File;
At_Character : Natural;
Message : String);
procedure Error
(Input : Input_File;
Message : String);
procedure Warning
(Input : Input_File;
At_Character : Natural;
Message : String);
procedure Warning
(Input : Input_File;
Message : String);
Dictionary_File : aliased Input_File;
procedure Read_Dictionary_File;
Source_File : aliased Input_File;
procedure Process_Source_File;
type Flag_Type is (UNW, VMS, FSFEDITION, PROEDITION, ACADEMICEDITION);
subtype Target_Type is Flag_Type range UNW .. VMS;
subtype Edition_Type is Flag_Type range FSFEDITION .. ACADEMICEDITION;
Target : Target_Type;
Valid_Characters : constant Character_Set :=
To_Set (Span => (' ', '~'));
Word_Characters : constant Character_Set :=
(To_Set (Ranges =>
(('0', '9'), ('a', 'z'), ('A', 'Z')))
or To_Set ("?-_~"));
Reject_Trailing_Spaces : constant Boolean := True;
Maximum_Line_Length : constant Positive := 79;
Fatal_Line_Length_Limit : constant Positive := 5000;
Fatal_Line_Length : exception;
VMS_Escape_Character : constant Character := '^';
Extensions : GNAT.Spitbol.Table_VString.Table (20);
procedure Initialize_Extensions;
function Is_Extension (Extension : String) return Boolean;
function Get_Replacement_Extension (Extension : String) return String;
Ug_Words : GNAT.Spitbol.Table_VString.Table (200);
function Is_Known_Word (Word : String) return Boolean;
function Get_Replacement_Word (Word : String) return String;
function Rewrite_Source_Line (Line : String) return String;
type Conditional is (Set, Clear);
procedure Push_Conditional (Cond : Conditional; Flag : Target_Type);
procedure Pop_Conditional (Cond : Conditional);
function Currently_Excluding return Boolean;
function VMS_Context_Determined return Boolean;
function In_VMS_Section return Boolean;
procedure Check_No_Pending_Conditional;
type Conditional_Context is record
Starting_Line : Positive;
Cond : Conditional;
Flag : Flag_Type;
Excluding : Boolean;
end record;
Conditional_Stack_Depth : constant := 3;
Conditional_Stack :
array (1 .. Conditional_Stack_Depth) of Conditional_Context;
Conditional_TOS : Natural := 0;
procedure Usage is
begin
Put_Line (Standard_Error,
"usage: xgnatugn TARGET SOURCE DICTIONARY [OUTFILE [WARNINGS]]");
New_Line;
Put_Line (Standard_Error, "TARGET is one of:");
for T in Target_Type'Range loop
Put_Line (Standard_Error, " " & Target_Type'Image (T));
end loop;
New_Line;
Put_Line (Standard_Error, "SOURCE is the source file to process.");
New_Line;
Put_Line (Standard_Error, "DICTIONARY is the name of a file "
& "that contains word replacements");
Put_Line (Standard_Error, "for the VMS version.");
New_Line;
Put_Line (Standard_Error,
"OUT-FILE, if present, is the output file to be created;");
Put_Line (Standard_Error,
"If OUT-FILE is absent, the output file is either " &
"gnat_ugn_unw.texi, ");
Put_Line (Standard_Error,
"or gnat_ugn_vms.texi, depending on TARGET.");
New_Line;
Put_Line (Standard_Error,
"WARNINGS, if present, is any string;");
Put_Line (Standard_Error,
"it will result in warning messages (e.g., line too long))");
Put_Line (Standard_Error,
"being output to Standard_Error.");
end Usage;
function Get_Line (Input : access Input_File) return String is
Line_Buffer : String (1 .. Fatal_Line_Length_Limit);
Last : Natural;
begin
Input.Line := Input.Line + 1;
Get_Line (Input.Data, Line_Buffer, Last);
if Last = Line_Buffer'Last then
Error (Input.all, "line exceeds fatal line length limit");
raise Fatal_Line_Length;
end if;
declare
Line : String renames Line_Buffer (Line_Buffer'First .. Last);
begin
for J in Line'Range loop
if not Is_In (Line (J), Valid_Characters) then
Error (Input.all, J, "invalid character");
exit;
end if;
end loop;
if Line'Length > Maximum_Line_Length then
Warning (Input.all, Maximum_Line_Length + 1, "line too long");
end if;
if Reject_Trailing_Spaces
and then Line'Length > 0
and then Line (Line'Last) = ' '
then
Error (Input.all, Line'Last, "trailing space character");
end if;
return Trim (Line, Right);
end;
end Get_Line;
procedure Error
(Input : Input_File;
Message : String)
is
begin
Error (Input, 0, Message);
end Error;
procedure Error
(Input : Input_File;
At_Character : Natural;
Message : String)
is
Line_Image : constant String := Integer'Image (Input.Line);
At_Character_Image : constant String := Integer'Image (At_Character);
begin
Number_Of_Errors := Number_Of_Errors + 1;
if At_Character > 0 then
Put_Line (Standard_Error,
S (Input.Name) & ':'
& Line_Image (Line_Image'First + 1 .. Line_Image'Last) & ':'
& At_Character_Image (At_Character_Image'First + 1
.. At_Character_Image'Last)
& ": "
& Message);
else
Put_Line (Standard_Error,
S (Input.Name) & ':'
& Line_Image (Line_Image'First + 1 .. Line_Image'Last)
& ": "
& Message);
end if;
end Error;
procedure Warning
(Input : Input_File;
Message : String)
is
begin
if Warnings_Enabled then
Warning (Input, 0, Message);
end if;
end Warning;
procedure Warning
(Input : Input_File;
At_Character : Natural;
Message : String)
is
Line_Image : constant String := Integer'Image (Input.Line);
At_Character_Image : constant String := Integer'Image (At_Character);
begin
if not Warnings_Enabled then
return;
end if;
Number_Of_Warnings := Number_Of_Warnings + 1;
if At_Character > 0 then
Put_Line (Standard_Error,
S (Input.Name) & ':'
& Line_Image (Line_Image'First + 1 .. Line_Image'Last) & ':'
& At_Character_Image (At_Character_Image'First + 1
.. At_Character_Image'Last)
& ": warning: "
& Message);
else
Put_Line (Standard_Error,
S (Input.Name) & ':'
& Line_Image (Line_Image'First + 1 .. Line_Image'Last)
& ": warning: "
& Message);
end if;
end Warning;
procedure Read_Dictionary_File is
begin
while not End_Of_File (Dictionary_File.Data) loop
declare
Line : constant String :=
Get_Line (Dictionary_File'Access);
Split : constant Natural :=
Index (Line, (1 => VMS_Escape_Character));
begin
if Line'Length = 0 then
Error (Dictionary_File, "empty line in dictionary file");
elsif Line (Line'First) = ' ' then
Error (Dictionary_File, 1, "line starts with space character");
elsif Split = 0 then
Error (Dictionary_File, "line does not contain "
& VMS_Escape_Character & " character");
else
declare
Source : constant String :=
Trim (Line (1 .. Split - 1), Both);
Target : constant String :=
Trim (Line (Split + 1 .. Line'Last), Both);
Two_Spaces : constant Natural :=
Index (Source, " ");
Non_Word_Character : constant Natural :=
Index (Source,
Word_Characters or
To_Set (" "),
Outside);
begin
if Two_Spaces /= 0 then
Error (Dictionary_File, Two_Spaces,
"multiple space characters in source word");
end if;
if Non_Word_Character /= 0 then
Error (Dictionary_File, Non_Word_Character,
"illegal character in source word");
end if;
if Source'Length = 0 then
Error (Dictionary_File, "source is empty");
elsif Target'Length = 0 then
Error (Dictionary_File, "target is empty");
else
Set (Ug_Words, Source, V (Target));
for J in Source'Range loop
if Source (J) = ' ' then
declare
Prefix : String renames
Source (Source'First .. J - 1);
begin
if not Is_Known_Word (Prefix) then
Error (Dictionary_File,
"prefix '" & Prefix
& "' not known at this point");
end if;
end;
end if;
end loop;
end if;
end;
end if;
end;
end loop;
end Read_Dictionary_File;
function Rewrite_Source_Line (Line : String) return String is
type Token_Span is record
First, Last : Positive;
end record;
type Token_Kind is (End_Of_Line, Word, Other,
VMS_Alternative, VMS_Error);
type Token_Record (Kind : Token_Kind := End_Of_Line) is record
First : Positive;
case Kind is
when Word | Other =>
Span : Token_Span;
when VMS_Alternative =>
Non_VMS, VMS : Token_Span;
when VMS_Error | End_Of_Line =>
null;
end case;
end record;
Input_Position : Positive := Line'First;
Token : Token_Record;
procedure Next_Token;
Rewritten_Line : VString;
procedure Rewrite_Word;
procedure Maybe_Rewrite_Extension;
VMS_Token_Seen : Boolean := False;
procedure Next_Token is
Remaining_Line : String renames Line (Input_Position .. Line'Last);
Last_Character : Natural;
begin
if Remaining_Line'Length = 0 then
Token := (End_Of_Line, Remaining_Line'First);
return;
end if;
if Remaining_Line (Remaining_Line'First) = VMS_Escape_Character then
declare
VMS_Second_Character, VMS_Third_Character : Natural;
begin
if VMS_Token_Seen then
Error (Source_File, Remaining_Line'First,
"multiple " & VMS_Escape_Character
& " characters on a single line");
else
VMS_Token_Seen := True;
end if;
VMS_Second_Character :=
Index (Remaining_Line (Remaining_Line'First + 1
.. Remaining_Line'Last),
(1 => VMS_Escape_Character));
if VMS_Second_Character = 0 then
Input_Position := Remaining_Line'Last + 1;
Token := (VMS_Error, Remaining_Line'First);
return;
end if;
VMS_Third_Character :=
Index (Remaining_Line (VMS_Second_Character + 1
.. Remaining_Line'Last),
(1 => VMS_Escape_Character));
if VMS_Third_Character = 0 then
Input_Position := Remaining_Line'Last + 1;
Token := (VMS_Error, Remaining_Line'First);
return;
end if;
Input_Position := VMS_Third_Character + 1;
if Remaining_Line'First + 1 = VMS_Second_Character
and then Remaining_Line'First + 2 = VMS_Third_Character
then
Token := (Other, Remaining_Line'First,
(Remaining_Line'First, Remaining_Line'First));
return;
end if;
Token := (VMS_Alternative, Remaining_Line'First,
(Remaining_Line'First + 1, VMS_Second_Character - 1),
(VMS_Second_Character + 1, VMS_Third_Character - 1));
return;
end;
end if;
Last_Character := Index (Remaining_Line, Word_Characters, Outside);
if Last_Character /= Remaining_Line'First then
if Last_Character = 0 then
Last_Character := Remaining_Line'Last + 1;
end if;
Input_Position := Last_Character;
Token := (Word, Remaining_Line'First,
(Remaining_Line'First, Last_Character - 1));
return;
end if;
Input_Position := Last_Character + 1;
Token := (Other,
Remaining_Line'First,
(Remaining_Line'First, Last_Character));
end Next_Token;
procedure Rewrite_Word is
First_Word : String
renames Line (Token.Span.First .. Token.Span.Last);
begin
if Target /= VMS then
Append (Rewritten_Line, First_Word);
Next_Token;
return;
end if;
if Is_Known_Word (First_Word) then
declare
Seq : Token_Span := Token.Span;
Lost_Space : Boolean := False;
begin
Next_Token;
loop
if Token.Kind = Other
and then Line (Token.Span.First .. Token.Span.Last) = " "
then
Next_Token;
if Token.Kind /= Word
or else not Is_Known_Word (Line (Seq.First
.. Token.Span.Last))
then
Lost_Space := True;
exit;
else
Seq.Last := Token.Span.Last;
Next_Token;
end if;
else
exit;
end if;
end loop;
Append (Rewritten_Line,
Get_Replacement_Word (Line (Seq.First .. Seq.Last)));
if Lost_Space then
Append (Rewritten_Line, ' ');
end if;
return;
end;
end if;
Next_Token;
if Token.Kind = Other
and then Line (Token.Span.First .. Token.Span.Last) = "."
then
Next_Token;
if Token.Kind = Word
and then Is_Extension (Line (Token.Span.First
.. Token.Span.Last))
then
Append (Rewritten_Line,
Translate (First_Word, Upper_Case_Map) & '.');
Append (Rewritten_Line,
Get_Replacement_Extension
(Line (Token.Span.First .. Token.Span.Last)));
Next_Token;
else
Append (Rewritten_Line, First_Word & '.');
end if;
else
Append (Rewritten_Line, First_Word);
end if;
end Rewrite_Word;
procedure Maybe_Rewrite_Extension is
begin
if Target = VMS
and then Line (Token.Span.First .. Token.Span.Last) = "."
then
Next_Token;
if Token.Kind = Word
and then Is_Extension (Line (Token.Span.First
.. Token.Span.Last))
then
Append (Rewritten_Line, '.' & Get_Replacement_Extension
(Line (Token.Span.First .. Token.Span.Last)));
Next_Token;
else
Append (Rewritten_Line, '.');
end if;
else
Append (Rewritten_Line, Line (Token.Span.First
.. Token.Span.Last));
Next_Token;
end if;
end Maybe_Rewrite_Extension;
begin
Next_Token;
loop
case Token.Kind is
when End_Of_Line =>
exit;
when Word =>
Rewrite_Word;
when Other =>
Maybe_Rewrite_Extension;
when VMS_Alternative =>
if VMS_Context_Determined then
if (not In_VMS_Section)
or else
Line (Token.VMS.First .. Token.VMS.Last) /=
Line (Token.Non_VMS.First .. Token.Non_VMS.Last)
then
Warning (Source_File, Token.First,
"VMS alternative already determined "
& "by conditionals");
end if;
end if;
if Target = VMS then
Append (Rewritten_Line, Line (Token.VMS.First
.. Token.VMS.Last));
else
Append (Rewritten_Line, Line (Token.Non_VMS.First
.. Token.Non_VMS.Last));
end if;
Next_Token;
when VMS_Error =>
Error (Source_File, Token.First, "invalid VMS alternative");
Next_Token;
end case;
end loop;
return S (Rewritten_Line);
end Rewrite_Source_Line;
procedure Process_Source_File is
Ifset : constant String := "@ifset ";
Ifclear : constant String := "@ifclear ";
Endsetclear : constant String := "@end ";
begin
while not End_Of_File (Source_File.Data) loop
declare
Line : constant String := Get_Line (Source_File'Access);
Rewritten : constant String := Rewrite_Source_Line (Line);
Have_Conditional : Boolean := False;
Cond : Conditional;
Flag : Flag_Type;
begin
if Line'Length >= Ifset'Length
and then Line (1 .. Ifset'Length) = Ifset
then
Cond := Set;
declare
Arg : constant String :=
Trim (Line (Ifset'Length + 1 .. Line'Last), Both);
begin
Flag := Flag_Type'Value (Arg);
Have_Conditional := True;
case Flag is
when Target_Type =>
if Translate (Target_Type'Image (Flag),
Lower_Case_Map)
/= Arg
then
Error (Source_File, "flag has to be lowercase");
end if;
when Edition_Type =>
null;
end case;
exception
when Constraint_Error =>
Error (Source_File, "unknown flag for '@ifset'");
end;
elsif Line'Length >= Ifclear'Length
and then Line (1 .. Ifclear'Length) = Ifclear
then
Cond := Clear;
declare
Arg : constant String :=
Trim (Line (Ifclear'Length + 1 .. Line'Last), Both);
begin
Flag := Flag_Type'Value (Arg);
Have_Conditional := True;
case Flag is
when Target_Type =>
if Translate (Target_Type'Image (Flag),
Lower_Case_Map)
/= Arg
then
Error (Source_File, "flag has to be lowercase");
end if;
when Edition_Type =>
null;
end case;
exception
when Constraint_Error =>
Error (Source_File, "unknown flag for '@ifclear'");
end;
end if;
if Have_Conditional and (Flag in Target_Type) then
Push_Conditional (Cond, Flag);
elsif Line'Length >= Endsetclear'Length
and then Line (1 .. Endsetclear'Length) = Endsetclear
and then (Flag in Target_Type)
then
declare
First, Last : Natural;
begin
Find_Token (Source => Line (Endsetclear'Length + 1
.. Line'Length),
Set => Letter_Set,
Test => Inside,
First => First,
Last => Last);
if Last = 0 then
Error (Source_File, "'@end' without argument");
else
if Line (First .. Last) = "ifset" then
Have_Conditional := True;
Cond := Set;
elsif Line (First .. Last) = "ifclear" then
Have_Conditional := True;
Cond := Clear;
end if;
if Have_Conditional then
Pop_Conditional (Cond);
end if;
end if; end;
end if;
if (not Have_Conditional) or (Flag in Edition_Type) then
if not Currently_Excluding then
Put_Line (Output_File, Rewritten);
end if;
end if;
end;
end loop;
Check_No_Pending_Conditional;
end Process_Source_File;
procedure Initialize_Extensions is
procedure Add (Extension : String);
procedure Add (Extension, Replacement : String);
procedure Add (Extension : String) is
begin
Add (Extension, Translate (Extension, Upper_Case_Map));
end Add;
procedure Add (Extension, Replacement : String) is
begin
Set (Extensions, Extension, V (Replacement));
end Add;
begin
Add ("o", "OBJ");
Add ("ads");
Add ("adb");
Add ("ali");
Add ("ada");
Add ("atb");
Add ("ats");
Add ("adc");
Add ("c");
end Initialize_Extensions;
function Is_Extension (Extension : String) return Boolean is
begin
return Present (Extensions, Extension);
end Is_Extension;
function Get_Replacement_Extension (Extension : String) return String is
begin
return S (Get (Extensions, Extension));
end Get_Replacement_Extension;
function Is_Known_Word (Word : String) return Boolean is
begin
return Present (Ug_Words, Word);
end Is_Known_Word;
function Get_Replacement_Word (Word : String) return String is
begin
return S (Get (Ug_Words, Word));
end Get_Replacement_Word;
procedure Push_Conditional (Cond : Conditional; Flag : Target_Type) is
Will_Exclude : Boolean;
begin
if Conditional_TOS > 0
and then Conditional_Stack (Conditional_TOS).Excluding
then
Will_Exclude := True;
else
case Cond is
when Set =>
Will_Exclude := Flag /= Target;
when Clear =>
Will_Exclude := Flag = Target;
end case;
end if;
for J in 1 .. Conditional_TOS loop
if Conditional_Stack (J).Flag = Flag then
Warning (Source_File, "directive without effect because of line"
& Integer'Image (Conditional_Stack (J).Starting_Line));
end if;
end loop;
Conditional_TOS := Conditional_TOS + 1;
Conditional_Stack (Conditional_TOS) :=
(Starting_Line => Source_File.Line,
Cond => Cond,
Flag => Flag,
Excluding => Will_Exclude);
end Push_Conditional;
procedure Pop_Conditional (Cond : Conditional) is
begin
if Conditional_TOS > 0 then
case Cond is
when Set =>
if Conditional_Stack (Conditional_TOS).Cond /= Set then
Error (Source_File,
"'@end ifset' does not match '@ifclear' at line"
& Integer'Image (Conditional_Stack
(Conditional_TOS).Starting_Line));
end if;
when Clear =>
if Conditional_Stack (Conditional_TOS).Cond /= Clear then
Error (Source_File,
"'@end ifclear' does not match '@ifset' at line"
& Integer'Image (Conditional_Stack
(Conditional_TOS).Starting_Line));
end if;
end case;
Conditional_TOS := Conditional_TOS - 1;
else
case Cond is
when Set =>
Error (Source_File,
"'@end ifset' without corresponding '@ifset'");
when Clear =>
Error (Source_File,
"'@end ifclear' without corresponding '@ifclear'");
end case;
end if;
end Pop_Conditional;
function Currently_Excluding return Boolean is
begin
return Conditional_TOS > 0
and then Conditional_Stack (Conditional_TOS).Excluding;
end Currently_Excluding;
function VMS_Context_Determined return Boolean is
begin
for J in 1 .. Conditional_TOS loop
if Conditional_Stack (J).Flag = VMS then
return True;
end if;
end loop;
return False;
end VMS_Context_Determined;
function In_VMS_Section return Boolean is
begin
for J in 1 .. Conditional_TOS loop
if Conditional_Stack (J).Flag = VMS then
return Conditional_Stack (J).Cond = Set;
end if;
end loop;
return False;
end In_VMS_Section;
procedure Check_No_Pending_Conditional is
begin
for J in 1 .. Conditional_TOS loop
case Conditional_Stack (J).Cond is
when Set =>
Error (Source_File, "Missing '@end ifset' for '@ifset' at line"
& Integer'Image (Conditional_Stack (J).Starting_Line));
when Clear =>
Error (Source_File,
"Missing '@end ifclear' for '@ifclear' at line"
& Integer'Image (Conditional_Stack (J).Starting_Line));
end case;
end loop;
end Check_No_Pending_Conditional;
Valid_Command_Line : Boolean;
Output_File_Name : VString;
begin
Initialize_Extensions;
Valid_Command_Line := Argument_Count in 3 .. 5;
if Valid_Command_Line then
begin
Target := Flag_Type'Value (Argument (1));
if not Target'Valid then
Valid_Command_Line := False;
end if;
exception
when Constraint_Error =>
Valid_Command_Line := False;
end;
end if;
if Valid_Command_Line then
begin
Source_File.Name := V (Argument (2));
Open (Source_File.Data, In_File, Argument (2));
exception
when Name_Error =>
Valid_Command_Line := False;
end;
end if;
if Valid_Command_Line then
begin
Dictionary_File.Name := V (Argument (3));
Open (Dictionary_File.Data, In_File, Argument (3));
exception
when Name_Error =>
Valid_Command_Line := False;
end;
end if;
if Valid_Command_Line then
if Argument_Count in 4 .. 5 then
Output_File_Name := V (Argument (4));
else
case Target is
when UNW =>
Output_File_Name := V ("gnat_ugn_unw.texi");
when VMS =>
Output_File_Name := V ("gnat_ugn_vms.texi");
end case;
end if;
Warnings_Enabled := Argument_Count = 5;
begin
Create (Output_File, Out_File, S (Output_File_Name));
exception
when Name_Error | Use_Error =>
Valid_Command_Line := False;
end;
end if;
if not Valid_Command_Line then
Usage;
Set_Exit_Status (Failure);
else
Read_Dictionary_File;
Close (Dictionary_File.Data);
Process_Source_File;
Close (Output_File);
Close (Source_File.Data);
New_Line (Standard_Error);
if Number_Of_Warnings = 0 then
Put_Line (Standard_Error, " NO Warnings");
else
Put (Standard_Error, Integer'Image (Number_Of_Warnings));
Put (Standard_Error, " Warning");
if Number_Of_Warnings > 1 then
Put (Standard_Error, "s");
end if;
New_Line (Standard_Error);
end if;
if Number_Of_Errors = 0 then
Put_Line (Standard_Error, " NO Errors");
else
Put (Standard_Error, Integer'Image (Number_Of_Errors));
Put (Standard_Error, " Error");
if Number_Of_Errors > 1 then
Put (Standard_Error, "s");
end if;
New_Line (Standard_Error);
end if;
if Number_Of_Errors /= 0 then
Set_Exit_Status (Failure);
else
Set_Exit_Status (Success);
end if;
end if;
end Xgnatugn;