Subversion Repositories scarts

------------------------------------------------------------------------------

--                                                                          --

--                          GNAT SYSTEM UTILITIES                           --

--                                                                          --

--                             X G N A T U G N                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 2003-2005, 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,  51  Franklin  Street,  Fifth  Floor, --

-- Boston, MA 02110-1301, USA.                                              --

--                                                                          --

------------------------------------------------------------------------------

--  This utility is used to process the source of gnat_ugn.texi to make a

--  version suitable for running through standard Texinfo processor. It is

--  invoked as follows:

--  xgnatugn <target> <in-file> <word-list> [ <out-file> [ <warnings> ] ]

--  1. <target> is the target type of the manual, which is one of:

--     unw       Unix and Windows platforms

--     vms       OpenVMS

--  2. <in-file> is the file name of the Texinfo file to be

--  preprocessed.

--  3. <word-list> is the name of the word list file. This file is used for

--  rewriting the VMS edition. Each line contains a word mapping: The source

--  word in the first column, the target word in the second column. The

--  columns are separated by a '^' character. When preprocessing for VMS, the

--  first word is replaced with the second. (Words consist of letters,

--  digits, and the four characters "?-_~". A sequence of multiple words can

--  be replaced if they are listed in the first column, separated by a single

--  space character. If multiple words are to be replaced, there must be a

--  replacement for each prefix.)

--  4. <out-file> (optional) is the name of the output file. It defaults to

--  gnat_ugn_unw.texi or gnat_ugn_vms.texi, depending on the target.

--  5. <warnings> (optional, and allowed only if <out-file> is explicit)

--  can be any string. If present, it indicates that warning messages are

--  to be output to Standard_Error. If absent, no warning messages are

--  generated.

--  The following steps are performed:

--     In VMS mode

--       Any occurrences of ^alpha^beta^ are replaced by beta. The sequence

--       must fit on a single line, and there can only be one occurrence on a

--       line.

--       Any occurrences of a word in the Ug_Words list are replaced by the

--       appropriate vms equivalents. Note that replacements do not occur

--       within ^alpha^beta^ sequences.

--       Any occurence of [filename].extension, where extension one of the

--       following:

--           "o", "ads", "adb", "ali", "ada", "atb", "ats", "adc", "c"

--       replaced by the appropriate VMS names (all upper case with .o

--       replaced .OBJ). Note that replacements do not occur within

--       ^alpha^beta^ sequences.

--     In UNW mode

--       Any occurrences of ^alpha^beta^ are replaced by alpha. The sequence

--       must fit on a single line.

--     In both modes

--       The sequence ^^^ is replaced by a single ^. This escape sequence

--       must be used if the literal character ^ is to appear in the

--       output. A line containing this escape sequence may not also contain

--       a ^alpha^beta^ sequence.

--       Process @ifset and @ifclear for the target flags (unw, vms);

--       this is because we have menu problems if we let makeinfo handle

--       these ifset/ifclear pairs.

--       Note: @ifset/@ifclear commands for the edition flags (FSFEDITION,

--       PROEDITION, ACADEMICEDITION) are passed through unchanged

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;

   --  Print usage information. Invoked if an invalid command line is

   --  encountered.

   Output_File : File_Type;

   --  The preprocessed output is written to this file

   type Input_File is record

      Name : VString;

      Data : File_Type;

      Line : Natural := 0;

   end record;

   --  Records information on an input file. Name and Line are used

   --  in error messages, Line is updated automatically by Get_Line.

   function Get_Line (Input : access Input_File) return String;

   --  Returns a line from Input and performs the necessary

   --  line-oriented checks (length, character set, trailing spaces).

   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);

   --  Prints a message reporting an error on line Input.Line. If

   --  At_Character is not 0, indicate the exact character at which

   --  the error occurs.

   procedure Warning

     (Input        : Input_File;

      At_Character : Natural;

      Message      : String);

   procedure Warning

     (Input        : Input_File;

      Message      : String);

   --  Like Error, but just print a warning message

   Dictionary_File : aliased Input_File;

   procedure Read_Dictionary_File;

   --  Dictionary_File is opened using the name given on the command

   --  line. It contains the replacements for the Ug_Words list.

   --  Read_Dictionary_File reads Dictionary_File and fills the

   --  Ug_Words table.

   Source_File : aliased Input_File;

   procedure Process_Source_File;

   --  Source_File is opened using the name given on the command line.

   --  It contains the Texinfo source code. Process_Source_File

   --  performs the necessary replacements.

   type Flag_Type is (UNW, VMS, FSFEDITION, PROEDITION, ACADEMICEDITION);

   --  The flags permitted in @ifset or @ifclear commands:

   --

   --  Targets for preprocessing

   --    UNW (Unix and Windows) or VMS

   --

   --  Editions of the manual

   --    FSFEDITION, PROEDITION, or ACADEMICEDITION

   --

   --  Conditional commands for target are processed by xgnatugn

   --

   --  Conditional commands for edition are passed through unchanged

   subtype Target_Type is Flag_Type range UNW .. VMS;

   subtype Edition_Type is Flag_Type range FSFEDITION .. ACADEMICEDITION;

   Target : Target_Type;

   --  The Target variable is initialized using the command line

   Valid_Characters : constant Character_Set :=

                        To_Set (Span => (' ',  '~'));

   --  This array controls which characters are permitted in the input

   --  file (after line breaks have been removed). Valid characters

   --  are all printable ASCII characters and the space character.

   Word_Characters : constant Character_Set :=

                       (To_Set (Ranges =>

                                  (('0', '9'), ('a', 'z'), ('A', 'Z')))

                        or To_Set ("?-_~"));

   --  The characters which are permitted in words. Other (valid)

   --  characters are assumed to be delimiters between words. Note that

   --  this set has to include all characters of the source words of the

   --  Ug_Words dictionary.

   Reject_Trailing_Spaces : constant Boolean := True;

   --  Controls whether Xgnatug rejects superfluous space characters

   --  at the end of lines.

   Maximum_Line_Length     : constant Positive := 79;

   Fatal_Line_Length_Limit : constant Positive := 5000;

   Fatal_Line_Length       : exception;

   --  If Maximum_Line_Length is exceeded in an input file, an error

   --  message is printed. If Fatal_Line_Length is exceeded,

   --  execution terminates with a Fatal_Line_Length exception.

   VMS_Escape_Character : constant Character := '^';

   --  The character used to mark VMS alternatives (^alpha^beta^)

   Extensions : GNAT.Spitbol.Table_VString.Table (20);

   procedure Initialize_Extensions;

   --  This table records extensions and their replacement for

   --  rewriting filenames in the VMS version of the manual.

   function Is_Extension (Extension : String) return Boolean;

   function Get_Replacement_Extension (Extension : String) return String;

   --  These functions query the replacement table. Is_Extension

   --  checks if the given string is a known extension.

   --  Get_Replacement returns the replacement extension.

   Ug_Words : GNAT.Spitbol.Table_VString.Table (200);

   function Is_Known_Word (Word : String) return Boolean;

   function Get_Replacement_Word (Word : String) return String;

   --  The Ug_Words table lists replacement words for the VMS version

   --  of the manual. Is_Known_Word and Get_Replacement_Word query

   --  this table. The table is filled using Read_Dictionary_File.

   function Rewrite_Source_Line (Line : String) return String;

   --  This subprogram takes a line and rewrites it according to Target.

   --  It relies on information in Source_File to generate error messages.

   type Conditional is (Set, Clear);

   procedure Push_Conditional (Cond : Conditional; Flag : Target_Type);

   procedure Pop_Conditional  (Cond : Conditional);

   --  These subprograms deal with conditional processing (@ifset/@ifclear).

   --  They rely on information in Source_File to generate error messages.

   function Currently_Excluding return Boolean;

   --  Returns true if conditional processing directives imply that the

   --  current line should not be included in the output.

   function VMS_Context_Determined return Boolean;

   --  Returns true if, in the current conditional preprocessing context, we

   --  always have a VMS or a non-VMS version, regardless of the value of

   --  Target.

   function In_VMS_Section return Boolean;

   --  Returns True if in an "@ifset vms" section

   procedure Check_No_Pending_Conditional;

   --  Checks that all preprocessing directives have been properly matched by

   --  their @end counterpart. If this is not the case, print an error

   --  message.

   --  The following definitions implement a stack to track the conditional

   --  preprocessing context.

   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;

   --  Pointer to the Top Of Stack for Conditional_Stack

   -----------

   -- Usage --

   -----------

   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;

   --------------

   -- Get_Line --

   --------------

   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;

   -----------

   -- Error --

   -----------

   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);

      --  These variables are required because we have to drop the leading

      --  space 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;

   -------------

   -- Warning --

   -------------

   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);

      --  These variables are required because we have to drop the leading

      --  space 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;

   --------------------------

   -- Read_Dictionary_File --

   --------------------------

   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));

                     --  Ensure that if Source is a sequence of words

                     --  "WORD1 WORD2 ...", we already have a mapping for

                     --  "WORD1".

                     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;

   -------------------------

   -- Rewrite_Source_Line --

   -------------------------

   function Rewrite_Source_Line (Line : String) return String is

      --  We use a simple lexer to split the line into tokens:

      --    Word             consisting entirely of Word_Characters

      --    VMS_Alternative  ^alpha^beta^ replacement (but not ^^^)

      --    Space            a space character

      --    Other            everything else (sequence of non-word characters)

      --    VMS_Error        incomplete VMS alternative

      --    End_Of_Line      no more characters on this line

      --   A sequence of three VMS_Escape_Characters is automatically

      --   collapsed to an Other token.

      type Token_Span is record

         First, Last : Positive;

      end record;

      --  The character range covered by a token in Line

      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;

      --  The position of the next character to be processed by Next_Token

      procedure Next_Token;

      --  Returns the next token in Line, starting at Input_Position

      Rewritten_Line : VString;

      --  Collects the line as it is rewritten

      procedure Rewrite_Word;

      --  The current token is assumed to be a Word. When processing the VMS

      --  version of the manual, additional tokens are gathered to check if

      --  we have a file name or a sequence of known words.

      procedure Maybe_Rewrite_Extension;

      --  The current token is assumed to be Other. When processing the VMS

      --  version of the manual and the token represents a single dot ".",

      --  the following word is rewritten according to the rules for

      --  extensions.

      VMS_Token_Seen : Boolean := False;

      --  This is set to true if a VMS_Alternative has been encountered, or a

      --  ^^^ token.

      ----------------

      -- Next_Token --

      ----------------

      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;

         --  ^alpha^beta^, the VMS_Alternative case

         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;

               --  Find the second and third escape character. If one of

               --  them is not present, generate an error token.

               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;

               --  Consume all the characters we are about to include in

               --  the token.

               Input_Position := VMS_Third_Character + 1;

               --  Check if we are in a ^^^ situation, and return an Other

               --  token in this case.

               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;                        --  VMS_Alternative

         --  The Word case. Search for characters not in Word_Characters.

         --  We have found a word if the first non-word character is not

         --  the first character in Remaining_Line, i.e. if Remaining_Line

         --  starts with a word character.

         Last_Character := Index (Remaining_Line, Word_Characters, Outside);

         if Last_Character /= Remaining_Line'First then

            --  If we haven't found a character which is not in

            --  Word_Characters, all remaining characters are part of the

            --  current Word token.

            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;

         --  Remaining characters are in the Other category. To speed

         --  up processing, we collect them together if there are several

         --  of them.

         Input_Position := Last_Character + 1;

         Token := (Other,

                   Remaining_Line'First,

                   (Remaining_Line'First, Last_Character));

      end Next_Token;

      ------------------

      -- Rewrite_Word --

      ------------------

      procedure Rewrite_Word is

         First_Word : String

           renames Line (Token.Span.First .. Token.Span.Last);

      begin

         --  We do not perform any error checking below, so we can just skip

         --  all processing for the non-VMS version.

         if Target /= VMS then

            Append (Rewritten_Line, First_Word);

            Next_Token;

            return;

         end if;

         if Is_Known_Word (First_Word) then

            --  If we have a word from the dictionary, we look for the

            --  longest possible sequence we can rewrite.

            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

                        --  When we reach this point, the following

                        --  conditions are true:

                        --

                        --  Seq is a known word.

                        --  The previous token was a space character.

                        --  Seq extended to the current token is not a

                        --  known word.

                        Lost_Space := True;

                        exit;

                     else

                        --  Extend Seq to cover the current (known) word

                        Seq.Last := Token.Span.Last;

                        Next_Token;

                     end if;

                  else

                     --  When we reach this point, the following conditions

                     --  are true:

                     --

                     --  Seq is a known word.

                     --  The previous token was a word.

                     --  The current token is not a space character.

                     exit;

                  end if;

               end loop;

               --  Rewrite Seq, and add the lost space if necessary

               Append (Rewritten_Line,

                       Get_Replacement_Word (Line (Seq.First .. Seq.Last)));

               if Lost_Space then

                  Append (Rewritten_Line, ' ');

               end if;

               --  The unknown token will be processed during the

               --  next iteration of the main loop.

               return;

            end;

         end if;

         Next_Token;

         if Token.Kind = Other

           and then Line (Token.Span.First .. Token.Span.Last) = "."

         then

            --  Deal with extensions