------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
-- --
|
-- --
|
-- GNAT COMPILER COMPONENTS --
|
-- GNAT COMPILER COMPONENTS --
|
-- --
|
-- --
|
-- S F N _ S C A N --
|
-- S F N _ S C A N --
|
-- --
|
-- --
|
-- B o d y --
|
-- B o d y --
|
-- --
|
-- --
|
-- Copyright (C) 2000-2009, Free Software Foundation, Inc. --
|
-- Copyright (C) 2000-2009, Free Software Foundation, Inc. --
|
-- --
|
-- --
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
-- --
|
-- --
|
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
-- additional permissions described in the GCC Runtime Library Exception, --
|
-- additional permissions described in the GCC Runtime Library Exception, --
|
-- version 3.1, as published by the Free Software Foundation. --
|
-- version 3.1, as published by the Free Software Foundation. --
|
-- --
|
-- --
|
-- You should have received a copy of the GNU General Public License and --
|
-- You should have received a copy of the GNU General Public License and --
|
-- a copy of the GCC Runtime Library Exception along with this program; --
|
-- a copy of the GCC Runtime Library Exception along with this program; --
|
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
-- <http://www.gnu.org/licenses/>. --
|
-- <http://www.gnu.org/licenses/>. --
|
-- --
|
-- --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- --
|
-- --
|
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
|
|
with Ada.Exceptions; use Ada.Exceptions;
|
with Ada.Exceptions; use Ada.Exceptions;
|
|
|
package body SFN_Scan is
|
package body SFN_Scan is
|
|
|
use ASCII;
|
use ASCII;
|
-- Allow easy access to control character definitions
|
-- Allow easy access to control character definitions
|
|
|
EOF : constant Character := ASCII.SUB;
|
EOF : constant Character := ASCII.SUB;
|
-- The character SUB (16#1A#) is used in DOS and other systems derived
|
-- The character SUB (16#1A#) is used in DOS and other systems derived
|
-- from DOS (OS/2, NT etc.) to signal the end of a text file. If this
|
-- from DOS (OS/2, NT etc.) to signal the end of a text file. If this
|
-- character appears as the last character of a file scanned by a call
|
-- character appears as the last character of a file scanned by a call
|
-- to Scan_SFN_Pragmas, then it is ignored, otherwise it is treated as
|
-- to Scan_SFN_Pragmas, then it is ignored, otherwise it is treated as
|
-- an illegal character.
|
-- an illegal character.
|
|
|
type String_Ptr is access String;
|
type String_Ptr is access String;
|
|
|
S : String_Ptr;
|
S : String_Ptr;
|
-- Points to the gnat.adc input file
|
-- Points to the gnat.adc input file
|
|
|
P : Natural;
|
P : Natural;
|
-- Subscript of next character to process in S
|
-- Subscript of next character to process in S
|
|
|
Line_Num : Natural;
|
Line_Num : Natural;
|
-- Current line number
|
-- Current line number
|
|
|
Start_Of_Line : Natural;
|
Start_Of_Line : Natural;
|
-- Subscript of first character at start of current line
|
-- Subscript of first character at start of current line
|
|
|
----------------------
|
----------------------
|
-- Local Procedures --
|
-- Local Procedures --
|
----------------------
|
----------------------
|
|
|
function Acquire_Integer return Natural;
|
function Acquire_Integer return Natural;
|
-- This function skips white space, and then scans and returns
|
-- This function skips white space, and then scans and returns
|
-- an unsigned integer. Raises Error if no integer is present
|
-- an unsigned integer. Raises Error if no integer is present
|
-- or if the integer is greater than 999.
|
-- or if the integer is greater than 999.
|
|
|
function Acquire_String (B : Natural; E : Natural) return String;
|
function Acquire_String (B : Natural; E : Natural) return String;
|
-- This function takes a string scanned out by Scan_String, strips
|
-- This function takes a string scanned out by Scan_String, strips
|
-- the enclosing quote characters and any internal doubled quote
|
-- the enclosing quote characters and any internal doubled quote
|
-- characters, and returns the result as a String. The arguments
|
-- characters, and returns the result as a String. The arguments
|
-- B and E are as returned from a call to Scan_String. The lower
|
-- B and E are as returned from a call to Scan_String. The lower
|
-- bound of the string returned is always 1.
|
-- bound of the string returned is always 1.
|
|
|
function Acquire_Unit_Name return String;
|
function Acquire_Unit_Name return String;
|
-- Skips white space, and then scans and returns a unit name. The
|
-- Skips white space, and then scans and returns a unit name. The
|
-- unit name is cased exactly as it appears in the source file.
|
-- unit name is cased exactly as it appears in the source file.
|
-- The terminating character must be white space, or a comma or
|
-- The terminating character must be white space, or a comma or
|
-- a right parenthesis or end of file.
|
-- a right parenthesis or end of file.
|
|
|
function At_EOF return Boolean;
|
function At_EOF return Boolean;
|
pragma Inline (At_EOF);
|
pragma Inline (At_EOF);
|
-- Returns True if at end of file, False if not. Note that this
|
-- Returns True if at end of file, False if not. Note that this
|
-- function does NOT skip white space, so P is always unchanged.
|
-- function does NOT skip white space, so P is always unchanged.
|
|
|
procedure Check_Not_At_EOF;
|
procedure Check_Not_At_EOF;
|
pragma Inline (Check_Not_At_EOF);
|
pragma Inline (Check_Not_At_EOF);
|
-- Skips past white space if any, and then raises Error if at
|
-- Skips past white space if any, and then raises Error if at
|
-- end of file. Otherwise returns with P skipped past whitespace.
|
-- end of file. Otherwise returns with P skipped past whitespace.
|
|
|
function Check_File_Type return Character;
|
function Check_File_Type return Character;
|
-- Skips white space if any, and then looks for any of the tokens
|
-- Skips white space if any, and then looks for any of the tokens
|
-- Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one
|
-- Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one
|
-- of these is found then the value returned is 's', 'b' or 'u'
|
-- of these is found then the value returned is 's', 'b' or 'u'
|
-- respectively, and P is bumped past the token. If none of
|
-- respectively, and P is bumped past the token. If none of
|
-- these tokens is found, then P is unchanged (except for
|
-- these tokens is found, then P is unchanged (except for
|
-- possible skip of white space), and a space is returned.
|
-- possible skip of white space), and a space is returned.
|
|
|
function Check_Token (T : String) return Boolean;
|
function Check_Token (T : String) return Boolean;
|
-- Skips white space if any, and then checks if the string at the
|
-- Skips white space if any, and then checks if the string at the
|
-- current location matches the given string T, and the character
|
-- current location matches the given string T, and the character
|
-- immediately following is non-alphabetic, non-numeric. If so,
|
-- immediately following is non-alphabetic, non-numeric. If so,
|
-- P is stepped past the token, and True is returned. If not,
|
-- P is stepped past the token, and True is returned. If not,
|
-- P is unchanged (except for possibly skipping past whitespace),
|
-- P is unchanged (except for possibly skipping past whitespace),
|
-- and False is returned. S may contain only lower-case letters
|
-- and False is returned. S may contain only lower-case letters
|
-- ('a' .. 'z').
|
-- ('a' .. 'z').
|
|
|
procedure Error (Err : String);
|
procedure Error (Err : String);
|
-- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
|
-- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
|
-- with a message of the form gnat.adc:line:col: xxx, where xxx is
|
-- with a message of the form gnat.adc:line:col: xxx, where xxx is
|
-- the string Err passed as a parameter.
|
-- the string Err passed as a parameter.
|
|
|
procedure Require_Token (T : String);
|
procedure Require_Token (T : String);
|
-- Skips white space if any, and then requires the given string
|
-- Skips white space if any, and then requires the given string
|
-- to be present. If it is, the P is stepped past it, otherwise
|
-- to be present. If it is, the P is stepped past it, otherwise
|
-- Error is raised, since this is a syntax error. Require_Token
|
-- Error is raised, since this is a syntax error. Require_Token
|
-- is used only for sequences of special characters, so there
|
-- is used only for sequences of special characters, so there
|
-- is no issue of terminators, or casing of letters.
|
-- is no issue of terminators, or casing of letters.
|
|
|
procedure Scan_String (B : out Natural; E : out Natural);
|
procedure Scan_String (B : out Natural; E : out Natural);
|
-- Skips white space if any, then requires that a double quote
|
-- Skips white space if any, then requires that a double quote
|
-- or percent be present (start of string). Raises error if
|
-- or percent be present (start of string). Raises error if
|
-- neither of these two characters is found. Otherwise scans
|
-- neither of these two characters is found. Otherwise scans
|
-- out the string, and returns with P pointing past the
|
-- out the string, and returns with P pointing past the
|
-- closing quote and S (B .. E) contains the characters of the
|
-- closing quote and S (B .. E) contains the characters of the
|
-- string (including the enclosing quotes, with internal quotes
|
-- string (including the enclosing quotes, with internal quotes
|
-- still doubled). Raises Error if the string is malformed.
|
-- still doubled). Raises Error if the string is malformed.
|
|
|
procedure Skip_WS;
|
procedure Skip_WS;
|
-- Skips P past any white space characters (end of line
|
-- Skips P past any white space characters (end of line
|
-- characters, spaces, comments, horizontal tab characters).
|
-- characters, spaces, comments, horizontal tab characters).
|
|
|
---------------------
|
---------------------
|
-- Acquire_Integer --
|
-- Acquire_Integer --
|
---------------------
|
---------------------
|
|
|
function Acquire_Integer return Natural is
|
function Acquire_Integer return Natural is
|
N : Natural := 0;
|
N : Natural := 0;
|
|
|
begin
|
begin
|
Skip_WS;
|
Skip_WS;
|
|
|
if S (P) not in '0' .. '9' then
|
if S (P) not in '0' .. '9' then
|
Error ("missing index parameter");
|
Error ("missing index parameter");
|
end if;
|
end if;
|
|
|
while S (P) in '0' .. '9' loop
|
while S (P) in '0' .. '9' loop
|
N := N * 10 + Character'Pos (S (P)) - Character'Pos ('0');
|
N := N * 10 + Character'Pos (S (P)) - Character'Pos ('0');
|
|
|
if N > 999 then
|
if N > 999 then
|
Error ("index value greater than 999");
|
Error ("index value greater than 999");
|
end if;
|
end if;
|
|
|
P := P + 1;
|
P := P + 1;
|
end loop;
|
end loop;
|
|
|
return N;
|
return N;
|
end Acquire_Integer;
|
end Acquire_Integer;
|
|
|
--------------------
|
--------------------
|
-- Acquire_String --
|
-- Acquire_String --
|
--------------------
|
--------------------
|
|
|
function Acquire_String (B : Natural; E : Natural) return String is
|
function Acquire_String (B : Natural; E : Natural) return String is
|
Str : String (1 .. E - B - 1);
|
Str : String (1 .. E - B - 1);
|
Q : constant Character := S (B);
|
Q : constant Character := S (B);
|
J : Natural;
|
J : Natural;
|
Ptr : Natural;
|
Ptr : Natural;
|
|
|
begin
|
begin
|
Ptr := B + 1;
|
Ptr := B + 1;
|
J := 0;
|
J := 0;
|
while Ptr < E loop
|
while Ptr < E loop
|
J := J + 1;
|
J := J + 1;
|
Str (J) := S (Ptr);
|
Str (J) := S (Ptr);
|
|
|
if S (Ptr) = Q and then S (Ptr + 1) = Q then
|
if S (Ptr) = Q and then S (Ptr + 1) = Q then
|
Ptr := Ptr + 2;
|
Ptr := Ptr + 2;
|
else
|
else
|
Ptr := Ptr + 1;
|
Ptr := Ptr + 1;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
return Str (1 .. J);
|
return Str (1 .. J);
|
end Acquire_String;
|
end Acquire_String;
|
|
|
-----------------------
|
-----------------------
|
-- Acquire_Unit_Name --
|
-- Acquire_Unit_Name --
|
-----------------------
|
-----------------------
|
|
|
function Acquire_Unit_Name return String is
|
function Acquire_Unit_Name return String is
|
B : Natural;
|
B : Natural;
|
|
|
begin
|
begin
|
Check_Not_At_EOF;
|
Check_Not_At_EOF;
|
B := P;
|
B := P;
|
|
|
while not At_EOF loop
|
while not At_EOF loop
|
exit when S (P) not in '0' .. '9'
|
exit when S (P) not in '0' .. '9'
|
and then S (P) /= '.'
|
and then S (P) /= '.'
|
and then S (P) /= '_'
|
and then S (P) /= '_'
|
and then not (S (P) = '[' and then S (P + 1) = '"')
|
and then not (S (P) = '[' and then S (P + 1) = '"')
|
and then not (S (P) = '"' and then S (P - 1) = '[')
|
and then not (S (P) = '"' and then S (P - 1) = '[')
|
and then not (S (P) = '"' and then S (P + 1) = ']')
|
and then not (S (P) = '"' and then S (P + 1) = ']')
|
and then not (S (P) = ']' and then S (P - 1) = '"')
|
and then not (S (P) = ']' and then S (P - 1) = '"')
|
and then S (P) < 'A';
|
and then S (P) < 'A';
|
P := P + 1;
|
P := P + 1;
|
end loop;
|
end loop;
|
|
|
if P = B then
|
if P = B then
|
Error ("null unit name");
|
Error ("null unit name");
|
end if;
|
end if;
|
|
|
return S (B .. P - 1);
|
return S (B .. P - 1);
|
end Acquire_Unit_Name;
|
end Acquire_Unit_Name;
|
|
|
------------
|
------------
|
-- At_EOF --
|
-- At_EOF --
|
------------
|
------------
|
|
|
function At_EOF return Boolean is
|
function At_EOF return Boolean is
|
begin
|
begin
|
-- Immediate return (False) if before last character of file
|
-- Immediate return (False) if before last character of file
|
|
|
if P < S'Last then
|
if P < S'Last then
|
return False;
|
return False;
|
|
|
-- Special case: DOS EOF character as last character of file is
|
-- Special case: DOS EOF character as last character of file is
|
-- allowed and treated as an end of file.
|
-- allowed and treated as an end of file.
|
|
|
elsif P = S'Last then
|
elsif P = S'Last then
|
return S (P) = EOF;
|
return S (P) = EOF;
|
|
|
-- If beyond last character of file, then definitely at EOF
|
-- If beyond last character of file, then definitely at EOF
|
|
|
else
|
else
|
return True;
|
return True;
|
end if;
|
end if;
|
end At_EOF;
|
end At_EOF;
|
|
|
---------------------
|
---------------------
|
-- Check_File_Type --
|
-- Check_File_Type --
|
---------------------
|
---------------------
|
|
|
function Check_File_Type return Character is
|
function Check_File_Type return Character is
|
begin
|
begin
|
if Check_Token ("spec_file_name") then
|
if Check_Token ("spec_file_name") then
|
return 's';
|
return 's';
|
elsif Check_Token ("body_file_name") then
|
elsif Check_Token ("body_file_name") then
|
return 'b';
|
return 'b';
|
elsif Check_Token ("subunit_file_name") then
|
elsif Check_Token ("subunit_file_name") then
|
return 'u';
|
return 'u';
|
else
|
else
|
return ' ';
|
return ' ';
|
end if;
|
end if;
|
end Check_File_Type;
|
end Check_File_Type;
|
|
|
----------------------
|
----------------------
|
-- Check_Not_At_EOF --
|
-- Check_Not_At_EOF --
|
----------------------
|
----------------------
|
|
|
procedure Check_Not_At_EOF is
|
procedure Check_Not_At_EOF is
|
begin
|
begin
|
Skip_WS;
|
Skip_WS;
|
|
|
if At_EOF then
|
if At_EOF then
|
Error ("unexpected end of file");
|
Error ("unexpected end of file");
|
end if;
|
end if;
|
|
|
return;
|
return;
|
end Check_Not_At_EOF;
|
end Check_Not_At_EOF;
|
|
|
-----------------
|
-----------------
|
-- Check_Token --
|
-- Check_Token --
|
-----------------
|
-----------------
|
|
|
function Check_Token (T : String) return Boolean is
|
function Check_Token (T : String) return Boolean is
|
Save_P : Natural;
|
Save_P : Natural;
|
C : Character;
|
C : Character;
|
|
|
begin
|
begin
|
Skip_WS;
|
Skip_WS;
|
Save_P := P;
|
Save_P := P;
|
|
|
for K in T'Range loop
|
for K in T'Range loop
|
if At_EOF then
|
if At_EOF then
|
P := Save_P;
|
P := Save_P;
|
return False;
|
return False;
|
end if;
|
end if;
|
|
|
C := S (P);
|
C := S (P);
|
|
|
if C in 'A' .. 'Z' then
|
if C in 'A' .. 'Z' then
|
C := Character'Val (Character'Pos (C) +
|
C := Character'Val (Character'Pos (C) +
|
(Character'Pos ('a') - Character'Pos ('A')));
|
(Character'Pos ('a') - Character'Pos ('A')));
|
end if;
|
end if;
|
|
|
if C /= T (K) then
|
if C /= T (K) then
|
P := Save_P;
|
P := Save_P;
|
return False;
|
return False;
|
end if;
|
end if;
|
|
|
P := P + 1;
|
P := P + 1;
|
end loop;
|
end loop;
|
|
|
if At_EOF then
|
if At_EOF then
|
return True;
|
return True;
|
end if;
|
end if;
|
|
|
C := S (P);
|
C := S (P);
|
|
|
if C in '0' .. '9'
|
if C in '0' .. '9'
|
or else C in 'a' .. 'z'
|
or else C in 'a' .. 'z'
|
or else C in 'A' .. 'Z'
|
or else C in 'A' .. 'Z'
|
or else C > Character'Val (127)
|
or else C > Character'Val (127)
|
then
|
then
|
P := Save_P;
|
P := Save_P;
|
return False;
|
return False;
|
|
|
else
|
else
|
return True;
|
return True;
|
end if;
|
end if;
|
end Check_Token;
|
end Check_Token;
|
|
|
-----------
|
-----------
|
-- Error --
|
-- Error --
|
-----------
|
-----------
|
|
|
procedure Error (Err : String) is
|
procedure Error (Err : String) is
|
C : Natural := 0;
|
C : Natural := 0;
|
-- Column number
|
-- Column number
|
|
|
M : String (1 .. 80);
|
M : String (1 .. 80);
|
-- Buffer used to build resulting error msg
|
-- Buffer used to build resulting error msg
|
|
|
LM : Natural := 0;
|
LM : Natural := 0;
|
-- Pointer to last set location in M
|
-- Pointer to last set location in M
|
|
|
procedure Add_Nat (N : Natural);
|
procedure Add_Nat (N : Natural);
|
-- Add chars of integer to error msg buffer
|
-- Add chars of integer to error msg buffer
|
|
|
-------------
|
-------------
|
-- Add_Nat --
|
-- Add_Nat --
|
-------------
|
-------------
|
|
|
procedure Add_Nat (N : Natural) is
|
procedure Add_Nat (N : Natural) is
|
begin
|
begin
|
if N > 9 then
|
if N > 9 then
|
Add_Nat (N / 10);
|
Add_Nat (N / 10);
|
end if;
|
end if;
|
|
|
LM := LM + 1;
|
LM := LM + 1;
|
M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));
|
M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));
|
end Add_Nat;
|
end Add_Nat;
|
|
|
-- Start of processing for Error
|
-- Start of processing for Error
|
|
|
begin
|
begin
|
M (1 .. 9) := "gnat.adc:";
|
M (1 .. 9) := "gnat.adc:";
|
LM := 9;
|
LM := 9;
|
Add_Nat (Line_Num);
|
Add_Nat (Line_Num);
|
LM := LM + 1;
|
LM := LM + 1;
|
M (LM) := ':';
|
M (LM) := ':';
|
|
|
-- Determine column number
|
-- Determine column number
|
|
|
for X in Start_Of_Line .. P loop
|
for X in Start_Of_Line .. P loop
|
C := C + 1;
|
C := C + 1;
|
|
|
if S (X) = HT then
|
if S (X) = HT then
|
C := (C + 7) / 8 * 8;
|
C := (C + 7) / 8 * 8;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
Add_Nat (C);
|
Add_Nat (C);
|
M (LM + 1) := ':';
|
M (LM + 1) := ':';
|
LM := LM + 1;
|
LM := LM + 1;
|
M (LM + 1) := ' ';
|
M (LM + 1) := ' ';
|
LM := LM + 1;
|
LM := LM + 1;
|
|
|
M (LM + 1 .. LM + Err'Length) := Err;
|
M (LM + 1 .. LM + Err'Length) := Err;
|
LM := LM + Err'Length;
|
LM := LM + Err'Length;
|
|
|
Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));
|
Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));
|
end Error;
|
end Error;
|
|
|
-------------------
|
-------------------
|
-- Require_Token --
|
-- Require_Token --
|
-------------------
|
-------------------
|
|
|
procedure Require_Token (T : String) is
|
procedure Require_Token (T : String) is
|
SaveP : Natural;
|
SaveP : Natural;
|
|
|
begin
|
begin
|
Skip_WS;
|
Skip_WS;
|
SaveP := P;
|
SaveP := P;
|
|
|
for J in T'Range loop
|
for J in T'Range loop
|
|
|
if At_EOF or else S (P) /= T (J) then
|
if At_EOF or else S (P) /= T (J) then
|
declare
|
declare
|
S : String (1 .. T'Length + 10);
|
S : String (1 .. T'Length + 10);
|
|
|
begin
|
begin
|
S (1 .. 9) := "missing """;
|
S (1 .. 9) := "missing """;
|
S (10 .. T'Length + 9) := T;
|
S (10 .. T'Length + 9) := T;
|
S (T'Length + 10) := '"';
|
S (T'Length + 10) := '"';
|
P := SaveP;
|
P := SaveP;
|
Error (S);
|
Error (S);
|
end;
|
end;
|
|
|
else
|
else
|
P := P + 1;
|
P := P + 1;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
end Require_Token;
|
end Require_Token;
|
|
|
----------------------
|
----------------------
|
-- Scan_SFN_Pragmas --
|
-- Scan_SFN_Pragmas --
|
----------------------
|
----------------------
|
|
|
procedure Scan_SFN_Pragmas
|
procedure Scan_SFN_Pragmas
|
(Source : String;
|
(Source : String;
|
SFN_Ptr : Set_File_Name_Ptr;
|
SFN_Ptr : Set_File_Name_Ptr;
|
SFNP_Ptr : Set_File_Name_Pattern_Ptr)
|
SFNP_Ptr : Set_File_Name_Pattern_Ptr)
|
is
|
is
|
B, E : Natural;
|
B, E : Natural;
|
Typ : Character;
|
Typ : Character;
|
Cas : Character;
|
Cas : Character;
|
|
|
begin
|
begin
|
Line_Num := 1;
|
Line_Num := 1;
|
S := Source'Unrestricted_Access;
|
S := Source'Unrestricted_Access;
|
P := Source'First;
|
P := Source'First;
|
Start_Of_Line := P;
|
Start_Of_Line := P;
|
|
|
-- Loop through pragmas in file
|
-- Loop through pragmas in file
|
|
|
Main_Scan_Loop : loop
|
Main_Scan_Loop : loop
|
Skip_WS;
|
Skip_WS;
|
exit Main_Scan_Loop when At_EOF;
|
exit Main_Scan_Loop when At_EOF;
|
|
|
-- Error if something other than pragma
|
-- Error if something other than pragma
|
|
|
if not Check_Token ("pragma") then
|
if not Check_Token ("pragma") then
|
Error ("non pragma encountered");
|
Error ("non pragma encountered");
|
end if;
|
end if;
|
|
|
-- Source_File_Name pragma case
|
-- Source_File_Name pragma case
|
|
|
if Check_Token ("source_file_name")
|
if Check_Token ("source_file_name")
|
or else
|
or else
|
Check_Token ("source_file_name_project")
|
Check_Token ("source_file_name_project")
|
then
|
then
|
Require_Token ("(");
|
Require_Token ("(");
|
|
|
Typ := Check_File_Type;
|
Typ := Check_File_Type;
|
|
|
-- First format, with unit name first
|
-- First format, with unit name first
|
|
|
if Typ = ' ' then
|
if Typ = ' ' then
|
if Check_Token ("unit_name") then
|
if Check_Token ("unit_name") then
|
Require_Token ("=>");
|
Require_Token ("=>");
|
end if;
|
end if;
|
|
|
declare
|
declare
|
U : constant String := Acquire_Unit_Name;
|
U : constant String := Acquire_Unit_Name;
|
|
|
begin
|
begin
|
Require_Token (",");
|
Require_Token (",");
|
Typ := Check_File_Type;
|
Typ := Check_File_Type;
|
|
|
if Typ /= 's' and then Typ /= 'b' then
|
if Typ /= 's' and then Typ /= 'b' then
|
Error ("bad pragma");
|
Error ("bad pragma");
|
end if;
|
end if;
|
|
|
Require_Token ("=>");
|
Require_Token ("=>");
|
Scan_String (B, E);
|
Scan_String (B, E);
|
|
|
declare
|
declare
|
F : constant String := Acquire_String (B, E);
|
F : constant String := Acquire_String (B, E);
|
X : Natural;
|
X : Natural;
|
|
|
begin
|
begin
|
-- Scan Index parameter if present
|
-- Scan Index parameter if present
|
|
|
if Check_Token (",") then
|
if Check_Token (",") then
|
if Check_Token ("index") then
|
if Check_Token ("index") then
|
Require_Token ("=>");
|
Require_Token ("=>");
|
end if;
|
end if;
|
|
|
X := Acquire_Integer;
|
X := Acquire_Integer;
|
else
|
else
|
X := 0;
|
X := 0;
|
end if;
|
end if;
|
|
|
Require_Token (")");
|
Require_Token (")");
|
Require_Token (";");
|
Require_Token (";");
|
SFN_Ptr.all (Typ, U, F, X);
|
SFN_Ptr.all (Typ, U, F, X);
|
end;
|
end;
|
end;
|
end;
|
|
|
-- Second format with pattern string
|
-- Second format with pattern string
|
|
|
else
|
else
|
Require_Token ("=>");
|
Require_Token ("=>");
|
Scan_String (B, E);
|
Scan_String (B, E);
|
|
|
declare
|
declare
|
Pat : constant String := Acquire_String (B, E);
|
Pat : constant String := Acquire_String (B, E);
|
Nas : Natural := 0;
|
Nas : Natural := 0;
|
|
|
begin
|
begin
|
-- Check exactly one asterisk
|
-- Check exactly one asterisk
|
|
|
for J in Pat'Range loop
|
for J in Pat'Range loop
|
if Pat (J) = '*' then
|
if Pat (J) = '*' then
|
Nas := Nas + 1;
|
Nas := Nas + 1;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
if Nas /= 1 then
|
if Nas /= 1 then
|
Error ("** not allowed");
|
Error ("** not allowed");
|
end if;
|
end if;
|
|
|
B := 0;
|
B := 0;
|
E := 0;
|
E := 0;
|
Cas := ' ';
|
Cas := ' ';
|
|
|
-- Loop to scan out Casing or Dot_Replacement parameters
|
-- Loop to scan out Casing or Dot_Replacement parameters
|
|
|
loop
|
loop
|
Check_Not_At_EOF;
|
Check_Not_At_EOF;
|
exit when S (P) = ')';
|
exit when S (P) = ')';
|
Require_Token (",");
|
Require_Token (",");
|
|
|
if Check_Token ("casing") then
|
if Check_Token ("casing") then
|
Require_Token ("=>");
|
Require_Token ("=>");
|
|
|
if Cas /= ' ' then
|
if Cas /= ' ' then
|
Error ("duplicate casing argument");
|
Error ("duplicate casing argument");
|
elsif Check_Token ("lowercase") then
|
elsif Check_Token ("lowercase") then
|
Cas := 'l';
|
Cas := 'l';
|
elsif Check_Token ("uppercase") then
|
elsif Check_Token ("uppercase") then
|
Cas := 'u';
|
Cas := 'u';
|
elsif Check_Token ("mixedcase") then
|
elsif Check_Token ("mixedcase") then
|
Cas := 'm';
|
Cas := 'm';
|
else
|
else
|
Error ("invalid casing argument");
|
Error ("invalid casing argument");
|
end if;
|
end if;
|
|
|
elsif Check_Token ("dot_replacement") then
|
elsif Check_Token ("dot_replacement") then
|
Require_Token ("=>");
|
Require_Token ("=>");
|
|
|
if E /= 0 then
|
if E /= 0 then
|
Error ("duplicate dot_replacement");
|
Error ("duplicate dot_replacement");
|
else
|
else
|
Scan_String (B, E);
|
Scan_String (B, E);
|
end if;
|
end if;
|
|
|
else
|
else
|
Error ("invalid argument");
|
Error ("invalid argument");
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
Require_Token (")");
|
Require_Token (")");
|
Require_Token (";");
|
Require_Token (";");
|
|
|
if Cas = ' ' then
|
if Cas = ' ' then
|
Cas := 'l';
|
Cas := 'l';
|
end if;
|
end if;
|
|
|
if E = 0 then
|
if E = 0 then
|
SFNP_Ptr.all (Pat, Typ, ".", Cas);
|
SFNP_Ptr.all (Pat, Typ, ".", Cas);
|
|
|
else
|
else
|
declare
|
declare
|
Dot : constant String := Acquire_String (B, E);
|
Dot : constant String := Acquire_String (B, E);
|
|
|
begin
|
begin
|
SFNP_Ptr.all (Pat, Typ, Dot, Cas);
|
SFNP_Ptr.all (Pat, Typ, Dot, Cas);
|
end;
|
end;
|
end if;
|
end if;
|
end;
|
end;
|
end if;
|
end if;
|
|
|
-- Some other pragma, scan to semicolon at end of pragma
|
-- Some other pragma, scan to semicolon at end of pragma
|
|
|
else
|
else
|
Skip_Loop : loop
|
Skip_Loop : loop
|
exit Main_Scan_Loop when At_EOF;
|
exit Main_Scan_Loop when At_EOF;
|
exit Skip_Loop when S (P) = ';';
|
exit Skip_Loop when S (P) = ';';
|
|
|
if S (P) = '"' or else S (P) = '%' then
|
if S (P) = '"' or else S (P) = '%' then
|
Scan_String (B, E);
|
Scan_String (B, E);
|
else
|
else
|
P := P + 1;
|
P := P + 1;
|
end if;
|
end if;
|
end loop Skip_Loop;
|
end loop Skip_Loop;
|
|
|
-- We successfully skipped to semicolon, so skip past it
|
-- We successfully skipped to semicolon, so skip past it
|
|
|
P := P + 1;
|
P := P + 1;
|
end if;
|
end if;
|
end loop Main_Scan_Loop;
|
end loop Main_Scan_Loop;
|
|
|
exception
|
exception
|
when others =>
|
when others =>
|
Cursor := P - S'First + 1;
|
Cursor := P - S'First + 1;
|
raise;
|
raise;
|
end Scan_SFN_Pragmas;
|
end Scan_SFN_Pragmas;
|
|
|
-----------------
|
-----------------
|
-- Scan_String --
|
-- Scan_String --
|
-----------------
|
-----------------
|
|
|
procedure Scan_String (B : out Natural; E : out Natural) is
|
procedure Scan_String (B : out Natural; E : out Natural) is
|
Q : Character;
|
Q : Character;
|
|
|
begin
|
begin
|
Check_Not_At_EOF;
|
Check_Not_At_EOF;
|
|
|
if S (P) = '"' then
|
if S (P) = '"' then
|
Q := '"';
|
Q := '"';
|
elsif S (P) = '%' then
|
elsif S (P) = '%' then
|
Q := '%';
|
Q := '%';
|
else
|
else
|
Error ("bad string");
|
Error ("bad string");
|
Q := '"';
|
Q := '"';
|
end if;
|
end if;
|
|
|
-- Scan out the string, B points to first char
|
-- Scan out the string, B points to first char
|
|
|
B := P;
|
B := P;
|
P := P + 1;
|
P := P + 1;
|
|
|
loop
|
loop
|
if At_EOF or else S (P) = LF or else S (P) = CR then
|
if At_EOF or else S (P) = LF or else S (P) = CR then
|
Error -- CODEFIX
|
Error -- CODEFIX
|
("missing string quote");
|
("missing string quote");
|
|
|
elsif S (P) = HT then
|
elsif S (P) = HT then
|
Error ("tab character in string");
|
Error ("tab character in string");
|
|
|
elsif S (P) /= Q then
|
elsif S (P) /= Q then
|
P := P + 1;
|
P := P + 1;
|
|
|
-- We have a quote
|
-- We have a quote
|
|
|
else
|
else
|
P := P + 1;
|
P := P + 1;
|
|
|
-- Check for doubled quote
|
-- Check for doubled quote
|
|
|
if not At_EOF and then S (P) = Q then
|
if not At_EOF and then S (P) = Q then
|
P := P + 1;
|
P := P + 1;
|
|
|
-- Otherwise this is the terminating quote
|
-- Otherwise this is the terminating quote
|
|
|
else
|
else
|
E := P - 1;
|
E := P - 1;
|
return;
|
return;
|
end if;
|
end if;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
end Scan_String;
|
end Scan_String;
|
|
|
-------------
|
-------------
|
-- Skip_WS --
|
-- Skip_WS --
|
-------------
|
-------------
|
|
|
procedure Skip_WS is
|
procedure Skip_WS is
|
begin
|
begin
|
WS_Scan : while not At_EOF loop
|
WS_Scan : while not At_EOF loop
|
case S (P) is
|
case S (P) is
|
|
|
-- End of physical line
|
-- End of physical line
|
|
|
when CR | LF =>
|
when CR | LF =>
|
Line_Num := Line_Num + 1;
|
Line_Num := Line_Num + 1;
|
P := P + 1;
|
P := P + 1;
|
|
|
while not At_EOF
|
while not At_EOF
|
and then (S (P) = CR or else S (P) = LF)
|
and then (S (P) = CR or else S (P) = LF)
|
loop
|
loop
|
Line_Num := Line_Num + 1;
|
Line_Num := Line_Num + 1;
|
P := P + 1;
|
P := P + 1;
|
end loop;
|
end loop;
|
|
|
Start_Of_Line := P;
|
Start_Of_Line := P;
|
|
|
-- All other cases of white space characters
|
-- All other cases of white space characters
|
|
|
when ' ' | FF | VT | HT =>
|
when ' ' | FF | VT | HT =>
|
P := P + 1;
|
P := P + 1;
|
|
|
-- Comment
|
-- Comment
|
|
|
when '-' =>
|
when '-' =>
|
P := P + 1;
|
P := P + 1;
|
|
|
if At_EOF then
|
if At_EOF then
|
Error ("bad comment");
|
Error ("bad comment");
|
|
|
elsif S (P) = '-' then
|
elsif S (P) = '-' then
|
P := P + 1;
|
P := P + 1;
|
|
|
while not At_EOF loop
|
while not At_EOF loop
|
case S (P) is
|
case S (P) is
|
when CR | LF | FF | VT =>
|
when CR | LF | FF | VT =>
|
exit;
|
exit;
|
when others =>
|
when others =>
|
P := P + 1;
|
P := P + 1;
|
end case;
|
end case;
|
end loop;
|
end loop;
|
|
|
else
|
else
|
P := P - 1;
|
P := P - 1;
|
exit WS_Scan;
|
exit WS_Scan;
|
end if;
|
end if;
|
|
|
when others =>
|
when others =>
|
exit WS_Scan;
|
exit WS_Scan;
|
|
|
end case;
|
end case;
|
end loop WS_Scan;
|
end loop WS_Scan;
|
end Skip_WS;
|
end Skip_WS;
|
|
|
end SFN_Scan;
|
end SFN_Scan;
|
|
|