diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/xgnatugn.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/xgnatugn.adb | 1408 |
1 files changed, 0 insertions, 1408 deletions
diff --git a/gcc-4.2.1/gcc/ada/xgnatugn.adb b/gcc-4.2.1/gcc/ada/xgnatugn.adb deleted file mode 100644 index a7e90ffde..000000000 --- a/gcc-4.2.1/gcc/ada/xgnatugn.adb +++ /dev/null @@ -1,1408 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 - - 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 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 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 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); - - -- 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; |