with Ada.Exceptions; use Ada.Exceptions;
package body SFN_Scan is
use ASCII;
EOF : constant Character := ASCII.SUB;
type String_Ptr is access String;
S : String_Ptr;
P : Natural;
Line_Num : Natural;
Start_Of_Line : Natural;
function Acquire_Integer return Natural;
function Acquire_String (B : Natural; E : Natural) return String;
function Acquire_Unit_Name return String;
function At_EOF return Boolean;
pragma Inline (At_EOF);
procedure Check_Not_At_EOF;
pragma Inline (Check_Not_At_EOF);
function Check_File_Type return Character;
function Check_Token (T : String) return Boolean;
procedure Error (Err : String);
procedure Require_Token (T : String);
procedure Scan_String (B : out Natural; E : out Natural);
procedure Skip_WS;
function Acquire_Integer return Natural is
N : Natural := 0;
begin
Skip_WS;
if S (P) not in '0' .. '9' then
Error ("missing index parameter");
end if;
while S (P) in '0' .. '9' loop
N := N * 10 + Character'Pos (S (P)) - Character'Pos ('0');
if N > 999 then
Error ("index value greater than 999");
end if;
P := P + 1;
end loop;
return N;
end Acquire_Integer;
function Acquire_String (B : Natural; E : Natural) return String is
Str : String (1 .. E - B - 1);
Q : constant Character := S (B);
J : Natural;
Ptr : Natural;
begin
Ptr := B + 1;
J := 0;
while Ptr < E loop
J := J + 1;
Str (J) := S (Ptr);
if S (Ptr) = Q and then S (Ptr + 1) = Q then
Ptr := Ptr + 2;
else
Ptr := Ptr + 1;
end if;
end loop;
return Str (1 .. J);
end Acquire_String;
function Acquire_Unit_Name return String is
B : Natural;
begin
Check_Not_At_EOF;
B := P;
while not At_EOF loop
exit when S (P) not in '0' .. '9'
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 S (P) < 'A';
P := P + 1;
end loop;
if P = B then
Error ("null unit name");
end if;
return S (B .. P - 1);
end Acquire_Unit_Name;
function At_EOF return Boolean is
begin
if P < S'Last then
return False;
elsif P = S'Last then
return S (P) = EOF;
else
return True;
end if;
end At_EOF;
function Check_File_Type return Character is
begin
if Check_Token ("spec_file_name") then
return 's';
elsif Check_Token ("body_file_name") then
return 'b';
elsif Check_Token ("subunit_file_name") then
return 'u';
else
return ' ';
end if;
end Check_File_Type;
procedure Check_Not_At_EOF is
begin
Skip_WS;
if At_EOF then
Error ("unexpected end of file");
end if;
return;
end Check_Not_At_EOF;
function Check_Token (T : String) return Boolean is
Save_P : Natural;
C : Character;
begin
Skip_WS;
Save_P := P;
for K in T'Range loop
if At_EOF then
P := Save_P;
return False;
end if;
C := S (P);
if C in 'A' .. 'Z' then
C := Character'Val (Character'Pos (C) +
(Character'Pos ('a') - Character'Pos ('A')));
end if;
if C /= T (K) then
P := Save_P;
return False;
end if;
P := P + 1;
end loop;
if At_EOF then
return True;
end if;
C := S (P);
if C in '0' .. '9'
or else C in 'a' .. 'z'
or else C in 'A' .. 'Z'
or else C > Character'Val (127)
then
P := Save_P;
return False;
else
return True;
end if;
end Check_Token;
procedure Error (Err : String) is
C : Natural := 0;
M : String (1 .. 80);
LM : Natural := 0;
procedure Add_Nat (N : Natural);
procedure Add_Nat (N : Natural) is
begin
if N > 9 then
Add_Nat (N / 10);
end if;
LM := LM + 1;
M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));
end Add_Nat;
begin
M (1 .. 9) := "gnat.adc:";
LM := 9;
Add_Nat (Line_Num);
LM := LM + 1;
M (LM) := ':';
for X in Start_Of_Line .. P loop
C := C + 1;
if S (X) = HT then
C := (C + 7) / 8 * 8;
end if;
end loop;
Add_Nat (C);
M (LM + 1) := ':';
LM := LM + 1;
M (LM + 1) := ' ';
LM := LM + 1;
M (LM + 1 .. LM + Err'Length) := Err;
LM := LM + Err'Length;
Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));
end Error;
procedure Require_Token (T : String) is
SaveP : Natural;
begin
Skip_WS;
SaveP := P;
for J in T'Range loop
if At_EOF or else S (P) /= T (J) then
declare
S : String (1 .. T'Length + 10);
begin
S (1 .. 9) := "missing """;
S (10 .. T'Length + 9) := T;
S (T'Length + 10) := '"';
P := SaveP;
Error (S);
end;
else
P := P + 1;
end if;
end loop;
end Require_Token;
procedure Scan_SFN_Pragmas
(Source : String;
SFN_Ptr : Set_File_Name_Ptr;
SFNP_Ptr : Set_File_Name_Pattern_Ptr)
is
B, E : Natural;
Typ : Character;
Cas : Character;
begin
Line_Num := 1;
S := Source'Unrestricted_Access;
P := Source'First;
Start_Of_Line := P;
Main_Scan_Loop : loop
Skip_WS;
exit Main_Scan_Loop when At_EOF;
if not Check_Token ("pragma") then
Error ("non pragma encountered");
end if;
if Check_Token ("source_file_name")
or else
Check_Token ("source_file_name_project")
then
Require_Token ("(");
Typ := Check_File_Type;
if Typ = ' ' then
if Check_Token ("unit_name") then
Require_Token ("=>");
end if;
declare
U : constant String := Acquire_Unit_Name;
begin
Require_Token (",");
Typ := Check_File_Type;
if Typ /= 's' and then Typ /= 'b' then
Error ("bad pragma");
end if;
Require_Token ("=>");
Scan_String (B, E);
declare
F : constant String := Acquire_String (B, E);
X : Natural;
begin
if Check_Token (",") then
if Check_Token ("index") then
Require_Token ("=>");
end if;
X := Acquire_Integer;
else
X := 0;
end if;
Require_Token (")");
Require_Token (";");
SFN_Ptr.all (Typ, U, F, X);
end;
end;
else
Require_Token ("=>");
Scan_String (B, E);
declare
Pat : constant String := Acquire_String (B, E);
Nas : Natural := 0;
begin
for J in Pat'Range loop
if Pat (J) = '*' then
Nas := Nas + 1;
end if;
end loop;
if Nas /= 1 then
Error ("** not allowed");
end if;
B := 0;
E := 0;
Cas := ' ';
loop
Check_Not_At_EOF;
exit when S (P) = ')';
Require_Token (",");
if Check_Token ("casing") then
Require_Token ("=>");
if Cas /= ' ' then
Error ("duplicate casing argument");
elsif Check_Token ("lowercase") then
Cas := 'l';
elsif Check_Token ("uppercase") then
Cas := 'u';
elsif Check_Token ("mixedcase") then
Cas := 'm';
else
Error ("invalid casing argument");
end if;
elsif Check_Token ("dot_replacement") then
Require_Token ("=>");
if E /= 0 then
Error ("duplicate dot_replacement");
else
Scan_String (B, E);
end if;
else
Error ("invalid argument");
end if;
end loop;
Require_Token (")");
Require_Token (";");
if Cas = ' ' then
Cas := 'l';
end if;
if E = 0 then
SFNP_Ptr.all (Pat, Typ, ".", Cas);
else
declare
Dot : constant String := Acquire_String (B, E);
begin
SFNP_Ptr.all (Pat, Typ, Dot, Cas);
end;
end if;
end;
end if;
else
Skip_Loop : loop
exit Main_Scan_Loop when At_EOF;
exit Skip_Loop when S (P) = ';';
if S (P) = '"' or else S (P) = '%' then
Scan_String (B, E);
else
P := P + 1;
end if;
end loop Skip_Loop;
P := P + 1;
end if;
end loop Main_Scan_Loop;
exception
when others =>
Cursor := P - S'First + 1;
raise;
end Scan_SFN_Pragmas;
procedure Scan_String (B : out Natural; E : out Natural) is
Q : Character;
begin
Check_Not_At_EOF;
if S (P) = '"' then
Q := '"';
elsif S (P) = '%' then
Q := '%';
else
Error ("bad string");
Q := '"';
end if;
B := P;
P := P + 1;
loop
if At_EOF or else S (P) = LF or else S (P) = CR then
Error ("missing string quote");
elsif S (P) = HT then
Error ("tab character in string");
elsif S (P) /= Q then
P := P + 1;
else
P := P + 1;
if not At_EOF and then S (P) = Q then
P := P + 1;
else
E := P - 1;
return;
end if;
end if;
end loop;
end Scan_String;
procedure Skip_WS is
begin
WS_Scan : while not At_EOF loop
case S (P) is
when CR | LF =>
Line_Num := Line_Num + 1;
P := P + 1;
while not At_EOF
and then (S (P) = CR or else S (P) = LF)
loop
Line_Num := Line_Num + 1;
P := P + 1;
end loop;
Start_Of_Line := P;
when ' ' | FF | VT | HT =>
P := P + 1;
when '-' =>
P := P + 1;
if At_EOF then
Error ("bad comment");
elsif S (P) = '-' then
P := P + 1;
while not At_EOF loop
case S (P) is
when CR | LF | FF | VT =>
exit;
when others =>
P := P + 1;
end case;
end loop;
else
P := P - 1;
exit WS_Scan;
end if;
when others =>
exit WS_Scan;
end case;
end loop WS_Scan;
end Skip_WS;
end SFN_Scan;