| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT SYSTEM UTILITIES -- |
| -- -- |
| -- X G N A T U G N -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2003-2008, 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. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| -- 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 occurrence 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, GPLEDITION) 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.Streams.Stream_IO; use Ada.Streams.Stream_IO; |
| 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. |
| |
| subtype Sfile is Ada.Streams.Stream_IO.File_Type; |
| |
| Output_File : Sfile; |
| -- The preprocessed output is written to this file |
| |
| type Input_File is record |
| Name : VString; |
| Data : Ada.Text_IO.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). |
| |
| procedure Put_Line (F : Sfile; S : String); |
| -- Local version of Put_Line ensures Unix style line endings |
| |
| 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, GPLEDITION); |
| -- The flags permitted in @ifset or @ifclear commands: |
| -- |
| -- Targets for preprocessing |
| -- UNW (Unix and Windows) or VMS |
| -- |
| -- Editions of the manual |
| -- FSFEDITION, PROEDITION, or GPLEDITION |
| -- |
| -- 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 .. GPLEDITION; |
| |
| 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; |
| |
| -------------- |
| -- Put_Line -- |
| -------------- |
| |
| procedure Put_Line (F : Sfile; S : String) is |
| begin |
| String'Write (Stream (F), S); |
| Character'Write (Stream (F), ASCII.LF); |
| end Put_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 |
| |
| Next_Token; |
| if Token.Kind = Word |
| and then Is_Extension (Line (Token.Span.First |
| .. Token.Span.Last)) |
| then |
| -- We have discovered a file extension. Convert the file |
| -- name to upper case. |
| |
| 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 |
| -- We already have: Word ".", followed by an unknown token |
| |
| Append (Rewritten_Line, First_Word & '.'); |
| |
| -- The unknown token will be processed during the next |
| -- iteration of the main loop. |
| end if; |
| |
| else |
| -- We have an unknown Word, followed by an unknown token. |
| -- The unknown token will be processed by the outer loop. |
| |
| Append (Rewritten_Line, First_Word); |
| end if; |
| end Rewrite_Word; |
| |
| ----------------------------- |
| -- Maybe_Rewrite_Extension -- |
| ----------------------------- |
| |
| procedure Maybe_Rewrite_Extension is |
| begin |
| -- Again, we need no special processing in the non-VMS case |
| |
| if Target = VMS |
| and then Line (Token.Span.First .. Token.Span.Last) = "." |
| then |
| -- This extension is not preceded by a word, otherwise |
| -- Rewrite_Word would have handled it. |
| |
| 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; |
| |
| -- Start of processing for Process_Source_Line |
| |
| begin |
| -- The following parser recognizes the following special token |
| -- sequences: |
| |
| -- Word "." Word rewrite as file name if second word is extension |
| -- Word " " Word rewrite as a single word using Ug_Words table |
| |
| 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; |
| |
| ------------------------- |
| -- Process_Source_File -- |
| ------------------------- |
| |
| procedure Process_Source_File is |
| Ifset : constant String := "@ifset "; |
| Ifclear : constant String := "@ifclear "; |
| Endsetclear : constant String := "@end "; |
| -- Strings to be recognized for conditional processing |
| |
| 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); |
| -- We unconditionally rewrite the line so that we can check the |
| -- syntax of all lines, and not only those which are actually |
| -- included in the output. |
| |
| Have_Conditional : Boolean := False; |
| -- True if we have encountered a conditional preprocessing |
| -- directive. |
| |
| Cond : Conditional; |
| -- The kind of the directive |
| |
| Flag : Flag_Type; |
| -- Its flag |
| |
| begin |
| -- If the line starts with @ifset or @ifclear, we try to convert |
| -- the following flag to one of our flag types. If we fail, |
| -- Have_Conditional remains False. |
| |
| 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 |
| |
| -- We create a new conditional context and suppress the |
| -- directive in the output. |
| |
| Push_Conditional (Cond, Flag); |
| |
| elsif Line'Length >= Endsetclear'Length |
| and then Line (1 .. Endsetclear'Length) = Endsetclear |
| and then (Flag in Target_Type) |
| then |
| -- The '@end ifset'/'@end ifclear' case is handled here. We |
| -- have to pop the conditional context. |
| |
| 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; |
| |
| -- We fall through to the ordinary case for other @end |
| -- directives. |
| |
| end if; -- @end without argument |
| end; |
| end if; -- Have_Conditional |
| |
| if (not Have_Conditional) or (Flag in Edition_Type) then |
| |
| -- The ordinary case |
| |
| 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; |
| |
| --------------------------- |
| -- Initialize_Extensions -- |
| --------------------------- |
| |
| procedure Initialize_Extensions is |
| |
| procedure Add (Extension : String); |
| -- Adds an extension which is replaced with itself (in upper |
| -- case). |
| |
| procedure Add (Extension, Replacement : String); |
| -- Adds an extension with a custom replacement |
| |
| --------- |
| -- Add -- |
| --------- |
| |
| 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; |
| |
| -- Start of processing for Initialize_Extensions |
| |
| begin |
| -- To avoid performance degradation, increase the constant in the |
| -- definition of Extensions above if you add more extensions here. |
| |
| Add ("o", "OBJ"); |
| Add ("ads"); |
| Add ("adb"); |
| Add ("ali"); |
| Add ("ada"); |
| Add ("atb"); |
| Add ("ats"); |
| Add ("adc"); |
| Add ("c"); |
| end Initialize_Extensions; |
| |
| ------------------ |
| -- Is_Extension -- |
| ------------------ |
| |
| function Is_Extension (Extension : String) return Boolean is |
| begin |
| return Present (Extensions, Extension); |
| end Is_Extension; |
| |
| ------------------------------- |
| -- Get_Replacement_Extension -- |
| ------------------------------- |
| |
| function Get_Replacement_Extension (Extension : String) return String is |
| begin |
| return S (Get (Extensions, Extension)); |
| end Get_Replacement_Extension; |
| |
| ------------------- |
| -- Is_Known_Word -- |
| ------------------- |
| |
| function Is_Known_Word (Word : String) return Boolean is |
| begin |
| return Present (Ug_Words, Word); |
| end Is_Known_Word; |
| |
| -------------------------- |
| -- Get_Replacement_Word -- |
| -------------------------- |
| |
| function Get_Replacement_Word (Word : String) return String is |
| begin |
| return S (Get (Ug_Words, Word)); |
| end Get_Replacement_Word; |
| |
| ---------------------- |
| -- Push_Conditional -- |
| ---------------------- |
| |
| procedure Push_Conditional (Cond : Conditional; Flag : Target_Type) is |
| Will_Exclude : Boolean; |
| |
| begin |
| -- If we are already in an excluding context, inherit this property, |
| -- otherwise calculate it from scratch. |
| |
| 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; |
| |
| -- Check if the current directive is pointless because of a previous, |
| -- enclosing directive. |
| |
| 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; |
| |
| --------------------- |
| -- Pop_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; |
| |
| ------------------------- |
| -- Currently_Excluding -- |
| ------------------------- |
| |
| function Currently_Excluding return Boolean is |
| begin |
| return Conditional_TOS > 0 |
| and then Conditional_Stack (Conditional_TOS).Excluding; |
| end Currently_Excluding; |
| |
| ---------------------------- |
| -- VMS_Context_Determined -- |
| ---------------------------- |
| |
| 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; |
| |
| -------------------- |
| -- In_VMS_Section -- |
| -------------------- |
| |
| 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; |
| |
| ---------------------------------- |
| -- Check_No_Pending_Conditional -- |
| ---------------------------------- |
| |
| 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; |
| |
| -- Start of processing for Xgnatugn |
| |
| Valid_Command_Line : Boolean; |
| Output_File_Name : VString; |
| |
| begin |
| Initialize_Extensions; |
| Valid_Command_Line := Argument_Count in 3 .. 5; |
| |
| -- First argument: Target |
| |
| 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; |
| |
| -- Second argument: Source_File |
| |
| if Valid_Command_Line then |
| begin |
| Source_File.Name := V (Argument (2)); |
| Open (Source_File.Data, In_File, Argument (2)); |
| |
| exception |
| when Ada.Text_IO.Name_Error => |
| Valid_Command_Line := False; |
| end; |
| end if; |
| |
| -- Third argument: Dictionary_File |
| |
| if Valid_Command_Line then |
| begin |
| Dictionary_File.Name := V (Argument (3)); |
| Open (Dictionary_File.Data, In_File, Argument (3)); |
| |
| exception |
| when Ada.Text_IO.Name_Error => |
| Valid_Command_Line := False; |
| end; |
| end if; |
| |
| -- Fourth argument: Output_File |
| |
| 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 Ada.Text_IO.Name_Error | Ada.Text_IO.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); |
| |
| -- Main processing starts here |
| |
| 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; |
