1396 lines
40 KiB
Ada
1396 lines
40 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- 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;
|