diff options
Diffstat (limited to 'gcc/ada/gnatprep.adb')
| -rw-r--r-- | gcc/ada/gnatprep.adb | 1395 |
1 files changed, 1395 insertions, 0 deletions
diff --git a/gcc/ada/gnatprep.adb b/gcc/ada/gnatprep.adb new file mode 100644 index 00000000000..ccff6fc4a3c --- /dev/null +++ b/gcc/ada/gnatprep.adb @@ -0,0 +1,1395 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T P R E P -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.27 $ +-- -- +-- Copyright (C) 1996-2001, 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Strings.Fixed; +with Ada.Command_Line; use Ada.Command_Line; +with Ada.Text_IO; use Ada.Text_IO; + +with GNAT.Heap_Sort_G; +with GNAT.Command_Line; + +with Gnatvsn; + +procedure GNATprep is + pragma Ident (Gnatvsn.Gnat_Version_String); + + Version_String : constant String := "$Revision: 1.27 $"; + + type Strptr is access String; + + Usage_Error : exception; + -- Raised if a usage error is detected, causes termination of processing + -- with an appropriate error message and error exit status set. + + Fatal_Error : exception; + -- Exception raised if fatal error detected + + Expression_Error : exception; + -- Exception raised when an invalid boolean expression is found + -- on a preprocessor line + + ------------------------ + -- Argument Line Data -- + ------------------------ + + Infile_Name : Strptr; + Outfile_Name : Strptr; + Deffile_Name : Strptr; + -- Names of files + + Infile : File_Type; + Outfile : File_Type; + Deffile : File_Type; + + Opt_Comment_Deleted_Lines : Boolean := False; -- Set if -c switch set + Blank_Deleted_Lines : Boolean := False; -- Set if -b switch set + List_Symbols : Boolean := False; -- Set if -s switch set + Source_Ref_Pragma : Boolean := False; -- Set if -r switch set + Undefined_Is_False : Boolean := False; -- Set if -u switch set + -- Record command line options + + --------------------------- + -- Definitions File Data -- + --------------------------- + + Num_Syms : Natural := 0; + -- Number of symbols defined in definitions file + + Symbols : array (0 .. 10_000) of Strptr; + Values : array (0 .. 10_000) of Strptr; + -- Symbol names and values. Note that the zero'th element is used only + -- during the call to Sort (to hold a temporary value, as required by + -- the GNAT.Heap_Sort_G interface). + + --------------------- + -- Input File Data -- + --------------------- + + Current_File_Name : Strptr; + -- Holds name of file being read (definitions file or input file) + + Line_Buffer : String (1 .. 20_000); + -- Hold one line + + Line_Length : Natural; + -- Length of line in Line_Buffer + + Line_Num : Natural; + -- Current input file line number + + Ptr : Natural; + -- Input scan pointer for line in Line_Buffer + + type Keyword is (K_Not, K_Then, K_If, K_Else, K_End, K_Elsif, + K_And, K_Or, K_Open_Paren, K_Close_Paren, + K_Defined, K_Andthen, K_Orelse, K_Equal, K_None); + -- Keywords that are recognized on preprocessor lines. K_None indicates + -- that no keyword was present. + + K : Keyword; + -- Scanned keyword + + Start_Sym, End_Sym : Natural; + -- First and last positions of scanned symbol + + Num_Errors : Natural := 0; + -- Number of errors detected + + ----------------------- + -- Preprocessor Data -- + ----------------------- + + -- The following record represents the state of an #if structure: + + type PP_Rec is record + If_Line : Positive; + -- Line number for #if line + + Else_Line : Natural; + -- Line number for #else line, zero = no else seen yet + + Deleting : Boolean; + -- True if lines currently being deleted + + Match_Seen : Boolean; + -- True if either the #if condition or one of the previously seen + -- #elsif lines was true, meaning that any future #elsif sections + -- or the #else section, is to be deleted. + end record; + + PP_Depth : Natural; + -- Preprocessor #if nesting level. A value of zero means that we are + -- outside any #if structure. + + PP : array (0 .. 100) of PP_Rec; + -- Stack of records showing state of #if structures. PP (1) is the + -- outer level entry, and PP (PP_Depth) is the active entry. PP (0) + -- contains a dummy entry whose Deleting flag is always set to False. + + ----------------- + -- Subprograms -- + ----------------- + + function At_End_Of_Line return Boolean; + -- First advances Ptr using Skip_Spaces. Then returns True if Ptr is + -- either at the end of the line, or at a -- comment sequence. + + procedure Error (Msg : String); + -- Post error message with given text. The line number is taken from + -- Line_Num, and the column number from Ptr. + + function Eval_Condition + (Parenthesis : Natural := 0; + Do_Eval : Boolean := True) + return Boolean; + -- Eval the condition found in the current Line. The condition can + -- include any of the 'and', 'or', 'not', and parenthesis subexpressions. + -- If Line is an invalid expression, then Expression_Error is raised, + -- after an error message has been printed. Line can include 'then' + -- followed by a comment, which is automatically ignored. If Do_Eval + -- is False, then the expression is not evaluated at all, and symbols + -- are just skipped. + + function Eval_Symbol (Do_Eval : Boolean) return Boolean; + -- Read and evaluate the next symbol or expression (A, A'Defined, A=...) + -- If it is followed by 'Defined or an equality test, read as many symbols + -- as needed. Do_Eval has the same meaning as in Eval_Condition + + procedure Help_Page; + -- Print a help page to summarize the usage of gnatprep + + function Is_Preprocessor_Line return Boolean; + -- Tests if current line is a preprocessor line, i.e. that its first + -- non-blank character is a # character. If so, then a result of True + -- is returned, and Ptr is set to point to the character following the + -- # character. If not, False is returned and Ptr is undefined. + + procedure No_Junk; + -- Make sure no junk is present on a preprocessor line. Ptr points past + -- the scanned preprocessor syntax. + + function OK_Identifier (S : String) return Boolean; + -- Tests if given referenced string is valid Ada identifier + + function Matching_Strings (S1, S2 : String) return Boolean; + -- Check if S1 and S2 are the same string (this is a case independent + -- comparison, lower and upper case letters are considered to match). + -- Duplicate quotes in S2 are considered as a single quote ("" => ") + + procedure Parse_Def_File; + -- Parse the deffile given by the user + + function Scan_Keyword return Keyword; + -- Advances Ptr to end of line or next non-blank using Skip_Spaces. Then + -- attempts to scan out a recognized keyword. if a recognized keyword is + -- found, sets Ptr past it, and returns the code for the keyword, if not, + -- then Ptr is left unchanged pointing to a non-blank character or to the + -- end of the line. + + function Symbol_Scanned return Boolean; + -- On entry, Start_Sym is set to the first character of an identifier + -- symbol to be scanned out. On return, End_Sym is set to the last + -- character of the identifier, and the result indicates if the scanned + -- symbol is a valid identifier (True = valid). Ptr is not changed. + + procedure Skip_Spaces; + -- Skips Ptr past tabs and spaces to next non-blank, or one character + -- past the end of line. + + function Variable_Index (Name : String) return Natural; + -- Returns the index of the variable in the table. If the variable is not + -- found, returns Natural'Last + + -------------------- + -- At_End_Of_Line -- + -------------------- + + function At_End_Of_Line return Boolean is + begin + Skip_Spaces; + + return Ptr > Line_Length + or else + (Ptr < Line_Length and then Line_Buffer (Ptr .. Ptr + 1) = "--"); + end At_End_Of_Line; + + ----------- + -- Error -- + ----------- + + procedure Error (Msg : String) is + L : constant String := Natural'Image (Line_Num); + C : constant String := Natural'Image (Ptr); + + begin + Put (Standard_Error, Current_File_Name.all); + Put (Standard_Error, ':'); + Put (Standard_Error, L (2 .. L'Length)); + Put (Standard_Error, ':'); + Put (Standard_Error, C (2 .. C'Length)); + Put (Standard_Error, ": "); + + Put_Line (Standard_Error, Msg); + Num_Errors := Num_Errors + 1; + end Error; + + -------------------- + -- Eval_Condition -- + -------------------- + + function Eval_Condition + (Parenthesis : Natural := 0; + Do_Eval : Boolean := True) + return Boolean + is + Symbol_Is_True : Boolean := False; -- init to avoid warning + K : Keyword; + + begin + -- Find the next subexpression + + K := Scan_Keyword; + + case K is + when K_None => + Symbol_Is_True := Eval_Symbol (Do_Eval); + + when K_Not => + + -- Not applies to the next subexpression (either a simple + -- evaluation like A or A'Defined, or a parenthesis expression) + + K := Scan_Keyword; + + if K = K_Open_Paren then + Symbol_Is_True := not Eval_Condition (Parenthesis + 1, Do_Eval); + + elsif K = K_None then + Symbol_Is_True := not Eval_Symbol (Do_Eval); + + else + Ptr := Start_Sym; -- Puts the keyword back + end if; + + when K_Open_Paren => + Symbol_Is_True := Eval_Condition (Parenthesis + 1, Do_Eval); + + when others => + Ptr := Start_Sym; + Error ("invalid syntax in preprocessor line"); + raise Expression_Error; + end case; + + -- Do we have a compound expression with AND, OR, ... + + K := Scan_Keyword; + case K is + when K_None => + if not At_End_Of_Line then + Error ("Invalid Syntax at end of line"); + raise Expression_Error; + end if; + + if Parenthesis /= 0 then + Error ("Unmatched opening parenthesis"); + raise Expression_Error; + end if; + + return Symbol_Is_True; + + when K_Then => + if Parenthesis /= 0 then + Error ("Unmatched opening parenthesis"); + raise Expression_Error; + end if; + + return Symbol_Is_True; + + when K_Close_Paren => + if Parenthesis = 0 then + Error ("Unmatched closing parenthesis"); + raise Expression_Error; + end if; + + return Symbol_Is_True; + + when K_And => + return Symbol_Is_True and Eval_Condition (Parenthesis, Do_Eval); + + when K_Andthen => + if not Symbol_Is_True then + + -- Just skip the symbols for the remaining part + + Symbol_Is_True := Eval_Condition (Parenthesis, False); + return False; + + else + return Eval_Condition (Parenthesis, Do_Eval); + end if; + + when K_Or => + return Symbol_Is_True or Eval_Condition (Parenthesis, Do_Eval); + + when K_Orelse => + if Symbol_Is_True then + + -- Just skip the symbols for the remaining part + + Symbol_Is_True := Eval_Condition (Parenthesis, False); + return True; + + else + return Eval_Condition (Parenthesis, Do_Eval); + end if; + + when others => + Error ("invalid syntax in preprocessor line"); + raise Expression_Error; + end case; + + end Eval_Condition; + + ----------------- + -- Eval_Symbol -- + ----------------- + + function Eval_Symbol (Do_Eval : Boolean) return Boolean is + Sym : constant String := Line_Buffer (Start_Sym .. End_Sym); + K : Keyword; + Index : Natural; + Symbol_Defined : Boolean := False; + Symbol_Is_True : Boolean := False; + + begin + -- Read the symbol + + Skip_Spaces; + Start_Sym := Ptr; + + if not Symbol_Scanned then + Error ("invalid symbol name"); + raise Expression_Error; + end if; + + Ptr := End_Sym + 1; + + -- Test if we have a simple test (A) or a more complicated one + -- (A'Defined) + + K := Scan_Keyword; + + if K /= K_Defined and then K /= K_Equal then + Ptr := Start_Sym; -- Puts the keyword back + end if; + + Index := Variable_Index (Sym); + + case K is + when K_Defined => + Symbol_Defined := Index /= Natural'Last; + Symbol_Is_True := Symbol_Defined; + + when K_Equal => + + -- Read the second part of the statement + Skip_Spaces; + Start_Sym := Ptr; + + if not Symbol_Scanned + and then End_Sym < Start_Sym + then + Error ("No right part for the equality test"); + raise Expression_Error; + end if; + + Ptr := End_Sym + 1; + + -- If the variable was not found + + if Do_Eval then + if Index = Natural'Last then + if not Undefined_Is_False then + Error ("symbol name """ & Sym & + """ is not defined in definitions file"); + end if; + + else + declare + Right : constant String + := Line_Buffer (Start_Sym .. End_Sym); + Index_R : Natural; + begin + if Right (Right'First) = '"' then + Symbol_Is_True := + Matching_Strings + (Values (Index).all, + Right (Right'First + 1 .. Right'Last - 1)); + else + Index_R := Variable_Index (Right); + if Index_R = Natural'Last then + Error ("Variable " & Right & " in test is " + & "not defined"); + raise Expression_Error; + else + Symbol_Is_True := + Matching_Strings (Values (Index).all, + Values (Index_R).all); + end if; + end if; + end; + end if; + end if; + + when others => + + if Index = Natural'Last then + + Symbol_Defined := False; + if Do_Eval and then not Symbol_Defined then + if Undefined_Is_False then + Symbol_Defined := True; + Symbol_Is_True := False; + + else + Error + ("symbol name """ & Sym & + """ is not defined in definitions file"); + end if; + end if; + + elsif not Do_Eval then + Symbol_Is_True := True; + + elsif Matching_Strings (Values (Index).all, "True") then + Symbol_Is_True := True; + + elsif Matching_Strings (Values (Index).all, "False") then + Symbol_Is_True := False; + + else + Error ("symbol value is not True or False"); + Symbol_Is_True := False; + end if; + + end case; + + return Symbol_Is_True; + end Eval_Symbol; + + --------------- + -- Help_Page -- + --------------- + + procedure Help_Page is + begin + Put_Line (Standard_Error, + "GNAT Preprocessor Version " & + Version_String (12 .. 15) & + " Copyright 1996-2001 Free Software Foundation, Inc."); + Put_Line (Standard_Error, + "Usage: gnatprep [-bcrsu] [-Dsymbol=value] infile " & + "outfile [deffile]"); + New_Line (Standard_Error); + Put_Line (Standard_Error, " infile Name of the input file"); + Put_Line (Standard_Error, " outfile Name of the output file"); + Put_Line (Standard_Error, " deffile Name of the definition file"); + New_Line (Standard_Error); + Put_Line (Standard_Error, "gnatprep switches:"); + Put_Line (Standard_Error, " -b Replace preprocessor lines by " & + "blank lines"); + Put_Line (Standard_Error, " -c Keep preprocessor lines as comments"); + Put_Line (Standard_Error, " -D Associate symbol with value"); + Put_Line (Standard_Error, " -r Generate Source_Reference pragma"); + Put_Line (Standard_Error, " -s Print a sorted list of symbol names " & + "and values"); + Put_Line (Standard_Error, " -u Treat undefined symbols as FALSE"); + New_Line (Standard_Error); + end Help_Page; + + -------------------------- + -- Is_Preprocessor_Line -- + -------------------------- + + function Is_Preprocessor_Line return Boolean is + begin + Ptr := 1; + + while Ptr <= Line_Length loop + if Line_Buffer (Ptr) = '#' then + Ptr := Ptr + 1; + return True; + + elsif Line_Buffer (Ptr) > ' ' then + return False; + + else + Ptr := Ptr + 1; + end if; + end loop; + + return False; + end Is_Preprocessor_Line; + + ---------------------- + -- Matching_Strings -- + ---------------------- + + function Matching_Strings (S1, S2 : String) return Boolean is + S2_Index : Integer := S2'First; + + begin + for S1_Index in S1'Range loop + + if To_Upper (S1 (S1_Index)) /= To_Upper (S2 (S2_Index)) then + return False; + + else + if S2 (S2_Index) = '"' + and then S2_Index < S2'Last + and then S2 (S2_Index + 1) = '"' + then + S2_Index := S2_Index + 2; + else + S2_Index := S2_Index + 1; + end if; + + -- If S2 was too short then + + if S2_Index > S2'Last and then S1_Index < S1'Last then + return False; + end if; + end if; + end loop; + + return S2_Index = S2'Last + 1; + end Matching_Strings; + + ------------- + -- No_Junk -- + ------------- + + procedure No_Junk is + begin + Skip_Spaces; + + if Ptr = Line_Length + or else (Ptr < Line_Length + and then Line_Buffer (Ptr .. Ptr + 1) /= "--") + then + Error ("extraneous text on preprocessor line ignored"); + end if; + end No_Junk; + + ------------------- + -- OK_Identifier -- + ------------------- + + function OK_Identifier (S : String) return Boolean is + P : Natural := S'First; + + begin + if S'Length /= 0 and then S (P) = Character'Val (39) then -- ''' + P := P + 1; + end if; + + if S'Length = 0 + or else not Is_Letter (S (P)) + then + return False; + + else + while P <= S'Last loop + if Is_Letter (S (P)) or Is_Digit (S (P)) then + null; + + elsif S (P) = '_' + and then P < S'Last + and then S (P + 1) /= '_' + then + null; + + else + return False; + end if; + + P := P + 1; + end loop; + + return True; + end if; + end OK_Identifier; + + -------------------- + -- Parse_Def_File -- + -------------------- + + procedure Parse_Def_File is + begin + Open (Deffile, In_File, Deffile_Name.all); + + Line_Num := 0; + Current_File_Name := Deffile_Name; + + -- Loop through lines in symbol definitions file + + while not End_Of_File (Deffile) loop + Get_Line (Deffile, Line_Buffer, Line_Length); + Line_Num := Line_Num + 1; + + Ptr := 1; + Skip_Spaces; + + if Ptr > Line_Length + or else (Ptr < Line_Length + and then + Line_Buffer (Ptr .. Ptr + 1) = "--") + then + goto Continue; + end if; + + Start_Sym := Ptr; + + if not Symbol_Scanned then + Error ("invalid symbol identifier """ & + Line_Buffer (Start_Sym .. End_Sym) & + '"'); + goto Continue; + end if; + + Ptr := End_Sym + 1; + Skip_Spaces; + + if Ptr >= Line_Length + or else Line_Buffer (Ptr .. Ptr + 1) /= ":=" + then + Error ("missing "":="" in symbol definition line"); + goto Continue; + end if; + + Ptr := Ptr + 2; + Skip_Spaces; + + Num_Syms := Num_Syms + 1; + Symbols (Num_Syms) := new String'(Line_Buffer (Start_Sym .. End_Sym)); + + Start_Sym := Ptr; + End_Sym := Ptr - 1; + + if At_End_Of_Line then + null; + + elsif Line_Buffer (Start_Sym) = '"' then + End_Sym := End_Sym + 1; + loop + End_Sym := End_Sym + 1; + + if End_Sym > Line_Length then + Error ("no closing quote for string constant"); + goto Continue; + + elsif End_Sym < Line_Length + and then Line_Buffer (End_Sym .. End_Sym + 1) = """""" + then + End_Sym := End_Sym + 1; + + elsif Line_Buffer (End_Sym) = '"' then + exit; + end if; + end loop; + + else + End_Sym := Ptr - 1; + + while End_Sym < Line_Length + and then (Is_Alphanumeric (Line_Buffer (End_Sym + 1)) + or else + Line_Buffer (End_Sym + 1) = '_' + or else + Line_Buffer (End_Sym + 1) = '.') + loop + End_Sym := End_Sym + 1; + end loop; + + Ptr := End_Sym + 1; + + if not At_End_Of_Line then + Error ("incorrect symbol value syntax"); + goto Continue; + end if; + end if; + + Values (Num_Syms) := new String'(Line_Buffer (Start_Sym .. End_Sym)); + + <<Continue>> + null; + end loop; + + exception + -- Could not open the file + + when Name_Error => + Put_Line (Standard_Error, "cannot open " & Deffile_Name.all); + raise Fatal_Error; + end Parse_Def_File; + + ------------------ + -- Scan_Keyword -- + ------------------ + + function Scan_Keyword return Keyword is + Kptr : constant Natural := Ptr; + + begin + Skip_Spaces; + Start_Sym := Ptr; + + if Symbol_Scanned then + + -- If the symbol was the last thing on the line, End_Sym will + -- point too far in Line_Buffer + + if End_Sym > Line_Length then + End_Sym := Line_Length; + end if; + + Ptr := End_Sym + 1; + + declare + Sym : constant String := Line_Buffer (Start_Sym .. End_Sym); + + begin + if Matching_Strings (Sym, "not") then + return K_Not; + + elsif Matching_Strings (Sym, "then") then + return K_Then; + + elsif Matching_Strings (Sym, "if") then + return K_If; + + elsif Matching_Strings (Sym, "else") then + return K_Else; + + elsif Matching_Strings (Sym, "end") then + return K_End; + + elsif Matching_Strings (Sym, "elsif") then + return K_Elsif; + + elsif Matching_Strings (Sym, "and") then + if Scan_Keyword = K_Then then + Start_Sym := Kptr; + return K_Andthen; + else + Ptr := Start_Sym; -- Put back the last keyword read + Start_Sym := Kptr; + return K_And; + end if; + + elsif Matching_Strings (Sym, "or") then + if Scan_Keyword = K_Else then + Start_Sym := Kptr; + return K_Orelse; + else + Ptr := Start_Sym; -- Put back the last keyword read + Start_Sym := Kptr; + return K_Or; + end if; + + elsif Matching_Strings (Sym, "'defined") then + return K_Defined; + + elsif Sym = "(" then + return K_Open_Paren; + + elsif Sym = ")" then + return K_Close_Paren; + + elsif Sym = "=" then + return K_Equal; + end if; + end; + end if; + + Ptr := Kptr; + return K_None; + end Scan_Keyword; + + ----------------- + -- Skip_Spaces -- + ----------------- + + procedure Skip_Spaces is + begin + while Ptr <= Line_Length loop + if Line_Buffer (Ptr) /= ' ' + and then Line_Buffer (Ptr) /= ASCII.HT + then + return; + else + Ptr := Ptr + 1; + end if; + end loop; + end Skip_Spaces; + + -------------------- + -- Symbol_Scanned -- + -------------------- + + function Symbol_Scanned return Boolean is + begin + End_Sym := Start_Sym - 1; + + case Line_Buffer (End_Sym + 1) is + + when '(' | ')' | '=' => + End_Sym := End_Sym + 1; + return True; + + when '"' => + End_Sym := End_Sym + 1; + while End_Sym < Line_Length loop + + if Line_Buffer (End_Sym + 1) = '"' then + + if End_Sym + 2 < Line_Length + and then Line_Buffer (End_Sym + 2) = '"' + then + End_Sym := End_Sym + 2; + else + exit; + end if; + else + End_Sym := End_Sym + 1; + end if; + end loop; + + if End_Sym >= Line_Length then + Error ("Invalid string "); + raise Expression_Error; + end if; + + End_Sym := End_Sym + 1; + return False; + + when ''' => + End_Sym := End_Sym + 1; + + when others => + null; + end case; + + while End_Sym < Line_Length + and then (Is_Alphanumeric (Line_Buffer (End_Sym + 1)) + or else Line_Buffer (End_Sym + 1) = '_') + loop + End_Sym := End_Sym + 1; + end loop; + + return OK_Identifier (Line_Buffer (Start_Sym .. End_Sym)); + end Symbol_Scanned; + + -------------------- + -- Variable_Index -- + -------------------- + + function Variable_Index (Name : String) return Natural is + begin + for J in 1 .. Num_Syms loop + if Matching_Strings (Symbols (J).all, Name) then + return J; + end if; + end loop; + + return Natural'Last; + end Variable_Index; + +-- Start of processing for GNATprep + +begin + + -- Parse the switches + + loop + case GNAT.Command_Line.Getopt ("D: b c r s u") is + when ASCII.NUL => + exit; + + when 'D' => + declare + S : String := GNAT.Command_Line.Parameter; + Index : Natural; + + begin + Index := Ada.Strings.Fixed.Index (S, "="); + + if Index = 0 then + Num_Syms := Num_Syms + 1; + Symbols (Num_Syms) := new String'(S); + Values (Num_Syms) := new String'("True"); + + else + Num_Syms := Num_Syms + 1; + Symbols (Num_Syms) := new String'(S (S'First .. Index - 1)); + Values (Num_Syms) := new String'(S (Index + 1 .. S'Last)); + end if; + end; + + when 'b' => + Blank_Deleted_Lines := True; + + when 'c' => + Opt_Comment_Deleted_Lines := True; + + when 'r' => + Source_Ref_Pragma := True; + + when 's' => + List_Symbols := True; + + when 'u' => + Undefined_Is_False := True; + + when others => + raise Usage_Error; + end case; + end loop; + + -- Get the file names + + loop + declare + S : constant String := GNAT.Command_Line.Get_Argument; + + begin + exit when S'Length = 0; + + if Infile_Name = null then + Infile_Name := new String'(S); + elsif Outfile_Name = null then + Outfile_Name := new String'(S); + elsif Deffile_Name = null then + Deffile_Name := new String'(S); + else + raise Usage_Error; + end if; + end; + end loop; + + -- Test we had all the arguments needed + + if Infile_Name = null + or else Outfile_Name = null + then + raise Usage_Error; + end if; + + if Source_Ref_Pragma and (not Opt_Comment_Deleted_Lines) then + Blank_Deleted_Lines := True; + end if; + + -- Get symbol definitions + + if Deffile_Name /= null then + Parse_Def_File; + end if; + + if Num_Errors > 0 then + raise Fatal_Error; + + elsif List_Symbols and then Num_Syms > 0 then + List_Symbols_Case : declare + + function Lt (Op1, Op2 : Natural) return Boolean; + -- Comparison routine for sort call + + procedure Move (From : Natural; To : Natural); + -- Move routine for sort call + + function Lt (Op1, Op2 : Natural) return Boolean is + L1 : constant Natural := Symbols (Op1)'Length; + L2 : constant Natural := Symbols (Op2)'Length; + MinL : constant Natural := Natural'Min (L1, L2); + + C1, C2 : Character; + + begin + for J in 0 .. MinL - 1 loop + C1 := To_Upper (Symbols (Op1).all (Symbols (Op1)'First + J)); + C2 := To_Upper (Symbols (Op2).all (Symbols (Op2)'First + J)); + + if C1 < C2 then + return True; + + elsif C1 > C2 then + return False; + end if; + end loop; + + return L1 < L2; + end Lt; + + procedure Move (From : Natural; To : Natural) is + begin + Symbols (To) := Symbols (From); + Values (To) := Values (From); + end Move; + + package Sort_Syms is new GNAT.Heap_Sort_G (Move, Lt); + + Max_L : Natural; + -- Maximum length of any symbol + + -- Start of processing for List_Symbols_Case + + begin + Sort_Syms.Sort (Num_Syms); + + Max_L := 7; + for J in 1 .. Num_Syms loop + Max_L := Natural'Max (Max_L, Symbols (J)'Length); + end loop; + + New_Line; + Put ("Symbol"); + + for J in 1 .. Max_L - 5 loop + Put (' '); + end loop; + + Put_Line ("Value"); + + Put ("------"); + + for J in 1 .. Max_L - 5 loop + Put (' '); + end loop; + + Put_Line ("------"); + + for J in 1 .. Num_Syms loop + Put (Symbols (J).all); + + for K in 1 .. Max_L - Symbols (J)'Length + 1 loop + Put (' '); + end loop; + + Put_Line (Values (J).all); + end loop; + + New_Line; + end List_Symbols_Case; + end if; + + -- Open files and initialize preprocessing + + begin + Open (Infile, In_File, Infile_Name.all); + + exception + when Name_Error => + Put_Line (Standard_Error, "cannot open " & Infile_Name.all); + raise Fatal_Error; + end; + + begin + Create (Outfile, Out_File, Outfile_Name.all); + + exception + when Name_Error => + Put_Line (Standard_Error, "cannot create " & Outfile_Name.all); + raise Fatal_Error; + end; + + if Source_Ref_Pragma then + Put_Line + (Outfile, "pragma Source_Reference (1, """ & Infile_Name.all & """);"); + end if; + + Line_Num := 0; + Current_File_Name := Infile_Name; + + PP_Depth := 0; + PP (0).Deleting := False; + + -- Loop through lines in input file + + while not End_Of_File (Infile) loop + Get_Line (Infile, Line_Buffer, Line_Length); + Line_Num := Line_Num + 1; + + -- Handle preprocessor line + + if Is_Preprocessor_Line then + K := Scan_Keyword; + + case K is + + -- If/Elsif processing + + when K_If | K_Elsif => + + -- If differs from elsif only in that an initial stack entry + -- must be made for the new if range. We set the match seen + -- entry to a copy of the deleting status in the range above + -- us. If we are deleting in the range above us, then we want + -- all the branches of the nested #if to delete. + + if K = K_If then + PP_Depth := PP_Depth + 1; + PP (PP_Depth) := + (If_Line => Line_Num, + Else_Line => 0, + Deleting => False, + Match_Seen => PP (PP_Depth - 1).Deleting); + + elsif PP_Depth = 0 then + Error ("no matching #if for this #elsif"); + goto Output; + + end if; + + PP (PP_Depth).Deleting := True; + + if not PP (PP_Depth).Match_Seen + and then Eval_Condition = True + then + + -- Case of match and no match yet in this #if + + PP (PP_Depth).Deleting := False; + PP (PP_Depth).Match_Seen := True; + No_Junk; + end if; + + -- Processing for #else + + when K_Else => + + if PP_Depth = 0 then + Error ("no matching #if for this #else"); + + elsif PP (PP_Depth).Else_Line /= 0 then + Error ("duplicate #else line (previous was on line" & + Natural'Image (PP (PP_Depth).Else_Line) & + ")"); + + else + PP (PP_Depth).Else_Line := Line_Num; + PP (PP_Depth).Deleting := PP (PP_Depth).Match_Seen; + end if; + + No_Junk; + + -- Process for #end + + when K_End => + + if PP_Depth = 0 then + Error ("no matching #if for this #end"); + + else + Skip_Spaces; + + if Scan_Keyword /= K_If then + Error ("expected if after #end"); + Ptr := Line_Length + 1; + end if; + + Skip_Spaces; + + if Ptr > Line_Length + or else Line_Buffer (Ptr) /= ';' + then + Error ("missing semicolon after #end if"); + else + Ptr := Ptr + 1; + end if; + + No_Junk; + + PP_Depth := PP_Depth - 1; + end if; + + when others => + Error ("invalid preprocessor keyword syntax"); + + end case; + + -- Handle symbol substitution + + -- Substitution is not allowed in string (which we simply skip), + -- but is allowed inside character constants. The last case is + -- because there is no way to know whether the user want to + -- substitute the name of an attribute ('Min or 'Max for instance) + -- or actually meant to substitue a character ('$name' is probably + -- a character constant, but my_type'$name'Min is probably an + -- attribute, with $name=Base) + + else + Ptr := 1; + + while Ptr < Line_Length loop + exit when At_End_Of_Line; + + case Line_Buffer (Ptr) is + + when ''' => + + -- Two special cases here: + -- '"' => we don't want the " sign to appear as belonging + -- to a string. + -- '$' => this is obviously not a substitution, just skip it + + if Ptr < Line_Length - 1 + and then Line_Buffer (Ptr + 1) = '"' + then + Ptr := Ptr + 2; + elsif Ptr < Line_Length - 2 + and then Line_Buffer (Ptr + 1 .. Ptr + 2) = "$'" + then + Ptr := Ptr + 2; + end if; + + when '"' => + + -- The special case of "" inside the string is easy to + -- handle: just ignore them. The second one will be seen + -- as the beginning of a second string + + Ptr := Ptr + 1; + while Ptr < Line_Length + and then Line_Buffer (Ptr) /= '"' + loop + Ptr := Ptr + 1; + end loop; + + when '$' => + + -- $ found, so scan out possible following symbol + + Start_Sym := Ptr + 1; + + if Symbol_Scanned then + + -- Look up symbol in table and if found do replacement + + for J in 1 .. Num_Syms loop + if Matching_Strings + (Symbols (J).all, Line_Buffer (Start_Sym .. End_Sym)) + then + declare + OldL : constant Positive := + End_Sym - Start_Sym + 2; + NewL : constant Positive := Values (J)'Length; + AdjL : constant Integer := NewL - OldL; + NewP : constant Positive := Ptr + NewL - 1; + + begin + Line_Buffer (NewP + 1 .. Line_Length + AdjL) := + Line_Buffer (End_Sym + 1 .. Line_Length); + Line_Buffer (Ptr .. NewP) := Values (J).all; + + Ptr := NewP; + Line_Length := Line_Length + AdjL; + end; + + exit; + end if; + end loop; + end if; + + when others => + null; + + end case; + Ptr := Ptr + 1; + end loop; + end if; + + -- Here after dealing with preprocessor line, output current line + + <<Output>> + + if Is_Preprocessor_Line or else PP (PP_Depth).Deleting then + if Blank_Deleted_Lines then + New_Line (Outfile); + + elsif Opt_Comment_Deleted_Lines then + if Line_Length = 0 then + Put_Line (Outfile, "--!"); + else + Put (Outfile, "--! "); + Put_Line (Outfile, Line_Buffer (1 .. Line_Length)); + end if; + end if; + + else + Put_Line (Outfile, Line_Buffer (1 .. Line_Length)); + end if; + end loop; + + for J in 1 .. PP_Depth loop + Error ("no matching #end for #if at line" & + Natural'Image (PP (J).If_Line)); + end loop; + + if Num_Errors = 0 then + Close (Outfile); + Set_Exit_Status (0); + else + Delete (Outfile); + Set_Exit_Status (1); + end if; + +exception + when Usage_Error => + Help_Page; + Set_Exit_Status (1); + + when GNAT.Command_Line.Invalid_Parameter => + Put_Line (Standard_Error, "No parameter given for -" + & GNAT.Command_Line.Full_Switch); + Help_Page; + Set_Exit_Status (1); + + when GNAT.Command_Line.Invalid_Switch => + Put_Line (Standard_Error, "Invalid Switch: -" + & GNAT.Command_Line.Full_Switch); + Help_Page; + Set_Exit_Status (1); + + when Fatal_Error => + Set_Exit_Status (1); + + when Expression_Error => + Set_Exit_Status (1); + +end GNATprep; |