with Csets; use Csets;
with Err_Vars; use Err_Vars;
with Namet; use Namet;
with Opt; use Opt;
with Scans; use Scans;
with Sinput; use Sinput;
with Snames; use Snames;
with Stringt; use Stringt;
with Stylesw; use Stylesw;
with Uintp; use Uintp;
with Urealp; use Urealp;
with Widechar; use Widechar;
with System.CRC32;
with System.WCh_Con; use System.WCh_Con;
package body Scng is
use ASCII;
Special_Characters : array (Character) of Boolean := (others => False);
Comment_Is_Token : Boolean := False;
End_Of_Line_Is_Token : Boolean := False;
procedure Accumulate_Token_Checksum;
pragma Inline (Accumulate_Token_Checksum);
procedure Accumulate_Checksum (C : Character);
pragma Inline (Accumulate_Checksum);
procedure Accumulate_Checksum (C : Char_Code);
pragma Inline (Accumulate_Checksum);
procedure Initialize_Checksum;
pragma Inline (Initialize_Checksum);
procedure Accumulate_Checksum (C : Character) is
begin
System.CRC32.Update (System.CRC32.CRC32 (Checksum), C);
end Accumulate_Checksum;
procedure Accumulate_Checksum (C : Char_Code) is
begin
Accumulate_Checksum (Character'Val (C / 256));
Accumulate_Checksum (Character'Val (C mod 256));
end Accumulate_Checksum;
procedure Accumulate_Token_Checksum is
begin
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token)));
end Accumulate_Token_Checksum;
function Determine_Token_Casing return Casing_Type is
begin
return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1));
end Determine_Token_Casing;
procedure Initialize_Checksum is
begin
System.CRC32.Initialize (System.CRC32.CRC32 (Checksum));
end Initialize_Checksum;
procedure Initialize_Scanner
(Unit : Unit_Number_Type;
Index : Source_File_Index)
is
begin
Set_Name_Table_Byte (Name_Abort, Token_Type'Pos (Tok_Abort));
Set_Name_Table_Byte (Name_Abs, Token_Type'Pos (Tok_Abs));
Set_Name_Table_Byte (Name_Abstract, Token_Type'Pos (Tok_Abstract));
Set_Name_Table_Byte (Name_Accept, Token_Type'Pos (Tok_Accept));
Set_Name_Table_Byte (Name_Access, Token_Type'Pos (Tok_Access));
Set_Name_Table_Byte (Name_And, Token_Type'Pos (Tok_And));
Set_Name_Table_Byte (Name_Aliased, Token_Type'Pos (Tok_Aliased));
Set_Name_Table_Byte (Name_All, Token_Type'Pos (Tok_All));
Set_Name_Table_Byte (Name_Array, Token_Type'Pos (Tok_Array));
Set_Name_Table_Byte (Name_At, Token_Type'Pos (Tok_At));
Set_Name_Table_Byte (Name_Begin, Token_Type'Pos (Tok_Begin));
Set_Name_Table_Byte (Name_Body, Token_Type'Pos (Tok_Body));
Set_Name_Table_Byte (Name_Case, Token_Type'Pos (Tok_Case));
Set_Name_Table_Byte (Name_Constant, Token_Type'Pos (Tok_Constant));
Set_Name_Table_Byte (Name_Declare, Token_Type'Pos (Tok_Declare));
Set_Name_Table_Byte (Name_Delay, Token_Type'Pos (Tok_Delay));
Set_Name_Table_Byte (Name_Delta, Token_Type'Pos (Tok_Delta));
Set_Name_Table_Byte (Name_Digits, Token_Type'Pos (Tok_Digits));
Set_Name_Table_Byte (Name_Do, Token_Type'Pos (Tok_Do));
Set_Name_Table_Byte (Name_Else, Token_Type'Pos (Tok_Else));
Set_Name_Table_Byte (Name_Elsif, Token_Type'Pos (Tok_Elsif));
Set_Name_Table_Byte (Name_End, Token_Type'Pos (Tok_End));
Set_Name_Table_Byte (Name_Entry, Token_Type'Pos (Tok_Entry));
Set_Name_Table_Byte (Name_Exception, Token_Type'Pos (Tok_Exception));
Set_Name_Table_Byte (Name_Exit, Token_Type'Pos (Tok_Exit));
Set_Name_Table_Byte (Name_For, Token_Type'Pos (Tok_For));
Set_Name_Table_Byte (Name_Function, Token_Type'Pos (Tok_Function));
Set_Name_Table_Byte (Name_Generic, Token_Type'Pos (Tok_Generic));
Set_Name_Table_Byte (Name_Goto, Token_Type'Pos (Tok_Goto));
Set_Name_Table_Byte (Name_If, Token_Type'Pos (Tok_If));
Set_Name_Table_Byte (Name_In, Token_Type'Pos (Tok_In));
Set_Name_Table_Byte (Name_Is, Token_Type'Pos (Tok_Is));
Set_Name_Table_Byte (Name_Limited, Token_Type'Pos (Tok_Limited));
Set_Name_Table_Byte (Name_Loop, Token_Type'Pos (Tok_Loop));
Set_Name_Table_Byte (Name_Mod, Token_Type'Pos (Tok_Mod));
Set_Name_Table_Byte (Name_New, Token_Type'Pos (Tok_New));
Set_Name_Table_Byte (Name_Not, Token_Type'Pos (Tok_Not));
Set_Name_Table_Byte (Name_Null, Token_Type'Pos (Tok_Null));
Set_Name_Table_Byte (Name_Of, Token_Type'Pos (Tok_Of));
Set_Name_Table_Byte (Name_Or, Token_Type'Pos (Tok_Or));
Set_Name_Table_Byte (Name_Others, Token_Type'Pos (Tok_Others));
Set_Name_Table_Byte (Name_Out, Token_Type'Pos (Tok_Out));
Set_Name_Table_Byte (Name_Package, Token_Type'Pos (Tok_Package));
Set_Name_Table_Byte (Name_Pragma, Token_Type'Pos (Tok_Pragma));
Set_Name_Table_Byte (Name_Private, Token_Type'Pos (Tok_Private));
Set_Name_Table_Byte (Name_Procedure, Token_Type'Pos (Tok_Procedure));
Set_Name_Table_Byte (Name_Protected, Token_Type'Pos (Tok_Protected));
Set_Name_Table_Byte (Name_Raise, Token_Type'Pos (Tok_Raise));
Set_Name_Table_Byte (Name_Range, Token_Type'Pos (Tok_Range));
Set_Name_Table_Byte (Name_Record, Token_Type'Pos (Tok_Record));
Set_Name_Table_Byte (Name_Rem, Token_Type'Pos (Tok_Rem));
Set_Name_Table_Byte (Name_Renames, Token_Type'Pos (Tok_Renames));
Set_Name_Table_Byte (Name_Requeue, Token_Type'Pos (Tok_Requeue));
Set_Name_Table_Byte (Name_Return, Token_Type'Pos (Tok_Return));
Set_Name_Table_Byte (Name_Reverse, Token_Type'Pos (Tok_Reverse));
Set_Name_Table_Byte (Name_Select, Token_Type'Pos (Tok_Select));
Set_Name_Table_Byte (Name_Separate, Token_Type'Pos (Tok_Separate));
Set_Name_Table_Byte (Name_Subtype, Token_Type'Pos (Tok_Subtype));
Set_Name_Table_Byte (Name_Tagged, Token_Type'Pos (Tok_Tagged));
Set_Name_Table_Byte (Name_Task, Token_Type'Pos (Tok_Task));
Set_Name_Table_Byte (Name_Terminate, Token_Type'Pos (Tok_Terminate));
Set_Name_Table_Byte (Name_Then, Token_Type'Pos (Tok_Then));
Set_Name_Table_Byte (Name_Type, Token_Type'Pos (Tok_Type));
Set_Name_Table_Byte (Name_Until, Token_Type'Pos (Tok_Until));
Set_Name_Table_Byte (Name_Use, Token_Type'Pos (Tok_Use));
Set_Name_Table_Byte (Name_When, Token_Type'Pos (Tok_When));
Set_Name_Table_Byte (Name_While, Token_Type'Pos (Tok_While));
Set_Name_Table_Byte (Name_With, Token_Type'Pos (Tok_With));
Set_Name_Table_Byte (Name_Xor, Token_Type'Pos (Tok_Xor));
Current_Source_File := Index;
Source := Source_Text (Current_Source_File);
Current_Source_Unit := Unit;
Scan_Ptr := Source_First (Current_Source_File);
Token := No_Token;
Token_Ptr := Scan_Ptr;
Current_Line_Start := Scan_Ptr;
Token_Node := Empty;
Token_Name := No_Name;
Start_Column := Set_Start_Column;
First_Non_Blank_Location := Scan_Ptr;
Initialize_Checksum;
end Initialize_Scanner;
procedure Reset_Special_Characters is
begin
Special_Characters := (others => False);
end Reset_Special_Characters;
procedure Scan is
Start_Of_Comment : Source_Ptr;
procedure Check_End_Of_Line;
function Double_Char_Token (C : Character) return Boolean;
procedure Error_Illegal_Character;
procedure Error_Illegal_Wide_Character;
procedure Error_Long_Line;
procedure Error_No_Double_Underline;
procedure Nlit;
procedure Slit;
procedure Check_End_Of_Line is
Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start);
begin
if Style_Check and Style_Check_Max_Line_Length then
Style.Check_Line_Terminator (Len);
elsif Len > Opt.Max_Line_Length then
Error_Long_Line;
end if;
end Check_End_Of_Line;
function Double_Char_Token (C : Character) return Boolean is
begin
if Source (Scan_Ptr + 1) = C then
Accumulate_Checksum (C);
Scan_Ptr := Scan_Ptr + 2;
return True;
elsif Source (Scan_Ptr + 1) = ' '
and then Source (Scan_Ptr + 2) = C
then
Scan_Ptr := Scan_Ptr + 1;
Error_Msg_S ("no space allowed here");
Scan_Ptr := Scan_Ptr + 2;
return True;
else
return False;
end if;
end Double_Char_Token;
procedure Error_Illegal_Character is
begin
Error_Msg_S ("illegal character");
Scan_Ptr := Scan_Ptr + 1;
end Error_Illegal_Character;
procedure Error_Illegal_Wide_Character is
begin
Error_Msg_S ("illegal wide character, check -gnatW switch");
Scan_Ptr := Scan_Ptr + 1;
end Error_Illegal_Wide_Character;
procedure Error_Long_Line is
begin
Error_Msg
("this line is too long",
Current_Line_Start + Source_Ptr (Opt.Max_Line_Length));
end Error_Long_Line;
procedure Error_No_Double_Underline is
begin
Error_Msg_S ("two consecutive underlines not permitted");
end Error_No_Double_Underline;
procedure Nlit is
C : Character;
Base_Char : Character;
Base : Int;
UI_Base : Uint;
UI_Int_Value : Uint;
UI_Num_Value : Uint;
Scale : Int;
UI_Scale : Uint;
Exponent_Is_Negative : Boolean;
Extended_Digit_Value : Int;
Point_Scanned : Boolean;
procedure Error_Digit_Expected;
procedure Scan_Integer;
procedure Error_Digit_Expected is
begin
Error_Msg_S ("digit expected");
end Error_Digit_Expected;
procedure Scan_Integer is
C : Character;
begin
C := Source (Scan_Ptr);
loop
Accumulate_Checksum (C);
UI_Int_Value :=
UI_Int_Value * 10 + (Character'Pos (C) - Character'Pos ('0'));
Scan_Ptr := Scan_Ptr + 1;
Scale := Scale - 1;
C := Source (Scan_Ptr);
if C = '_' then
loop
Scan_Ptr := Scan_Ptr + 1;
C := Source (Scan_Ptr);
exit when C /= '_';
Error_No_Double_Underline;
end loop;
if C not in '0' .. '9' then
Error_Digit_Expected;
exit;
end if;
else
exit when C not in '0' .. '9';
end if;
end loop;
end Scan_Integer;
begin
Base := 10;
UI_Base := Uint_10;
UI_Int_Value := Uint_0;
Scale := 0;
Scan_Integer;
Scale := 0;
Point_Scanned := False;
UI_Num_Value := UI_Int_Value;
Scale := 0;
C := Source (Scan_Ptr);
if C = '.' then
while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop
Accumulate_Checksum ('.');
if Point_Scanned then
Error_Msg_S ("duplicate point ignored");
end if;
Point_Scanned := True;
Scan_Ptr := Scan_Ptr + 1;
C := Source (Scan_Ptr);
if C not in '0' .. '9' then
Error_Msg
("real literal cannot end with point", Scan_Ptr - 1);
else
Scan_Integer;
UI_Num_Value := UI_Int_Value;
end if;
end loop;
elsif C = '#'
or else (C = ':' and then
(Source (Scan_Ptr + 1) = '.'
or else
Source (Scan_Ptr + 1) in '0' .. '9'
or else
Source (Scan_Ptr + 1) in 'A' .. 'Z'
or else
Source (Scan_Ptr + 1) in 'a' .. 'z'))
then
if C = ':' and then Warn_On_Obsolescent_Feature then
Error_Msg_S
("use of "":"" is an obsolescent feature ('R'M 'J.2(3))?");
Error_Msg_S
("\use ""'#"" instead?");
end if;
Accumulate_Checksum (C);
Base_Char := C;
UI_Base := UI_Int_Value;
if UI_Base < 2 or else UI_Base > 16 then
Error_Msg_SC ("base not 2-16");
UI_Base := Uint_16;
end if;
Base := UI_To_Int (UI_Base);
Scan_Ptr := Scan_Ptr + 1;
C := Source (Scan_Ptr);
UI_Int_Value := Uint_0;
Scale := 0;
loop
if C in '0' .. '9' then
Accumulate_Checksum (C);
Extended_Digit_Value :=
Int'(Character'Pos (C)) - Int'(Character'Pos ('0'));
elsif C in 'A' .. 'F' then
Accumulate_Checksum (Character'Val (Character'Pos (C) + 32));
Extended_Digit_Value :=
Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10;
elsif C in 'a' .. 'f' then
Accumulate_Checksum (C);
Extended_Digit_Value :=
Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10;
else
Error_Msg_S ("extended digit expected");
exit;
end if;
if Extended_Digit_Value >= Base then
Error_Msg_S ("digit '>= base");
end if;
UI_Int_Value := UI_Int_Value * UI_Base + Extended_Digit_Value;
Scale := Scale - 1;
Scan_Ptr := Scan_Ptr + 1;
C := Source (Scan_Ptr);
if C = '_' then
loop
Accumulate_Checksum ('_');
Scan_Ptr := Scan_Ptr + 1;
C := Source (Scan_Ptr);
exit when C /= '_';
Error_No_Double_Underline;
end loop;
elsif C = '.' then
Accumulate_Checksum ('.');
if Point_Scanned then
Error_Msg_S ("duplicate point ignored");
end if;
Scan_Ptr := Scan_Ptr + 1;
C := Source (Scan_Ptr);
Point_Scanned := True;
Scale := 0;
elsif C = Base_Char then
Accumulate_Checksum (C);
Scan_Ptr := Scan_Ptr + 1;
exit;
elsif C = '#' or else C = ':' then
Error_Msg_S ("based number delimiters must match");
Scan_Ptr := Scan_Ptr + 1;
exit;
elsif not Identifier_Char (C) then
if Base_Char = '#' then
Error_Msg_S ("missing '#");
else
Error_Msg_S ("missing ':");
end if;
exit;
end if;
end loop;
UI_Num_Value := UI_Int_Value;
end if;
if not Point_Scanned then
Scale := 0;
UI_Scale := Uint_0;
else
UI_Scale := UI_From_Int (Scale);
end if;
if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then
Accumulate_Checksum ('e');
Scan_Ptr := Scan_Ptr + 1;
Exponent_Is_Negative := False;
if Source (Scan_Ptr) = '+' then
Accumulate_Checksum ('+');
Scan_Ptr := Scan_Ptr + 1;
elsif Source (Scan_Ptr) = '-' then
Accumulate_Checksum ('-');
if not Point_Scanned then
Error_Msg_S
("negative exponent not allowed for integer literal");
else
Exponent_Is_Negative := True;
end if;
Scan_Ptr := Scan_Ptr + 1;
end if;
UI_Int_Value := Uint_0;
if Source (Scan_Ptr) in '0' .. '9' then
Scan_Integer;
else
Error_Digit_Expected;
end if;
if Exponent_Is_Negative then
UI_Scale := UI_Scale - UI_Int_Value;
else
UI_Scale := UI_Scale + UI_Int_Value;
end if;
end if;
if Point_Scanned then
Token := Tok_Real_Literal;
Real_Literal_Value :=
UR_From_Components (
Num => UI_Num_Value,
Den => -UI_Scale,
Rbase => Base);
else
Token := Tok_Integer_Literal;
if UI_Scale = 0 then
Int_Literal_Value := UI_Num_Value;
elsif Operating_Mode /= Check_Syntax
and then (Serious_Errors_Detected = 0 or else Try_Semantics)
then
Int_Literal_Value := UI_Num_Value * UI_Base ** UI_Scale;
else
Int_Literal_Value := No_Uint;
end if;
end if;
Accumulate_Token_Checksum;
return;
end Nlit;
procedure Slit is
Delimiter : Character;
C : Character;
Code : Char_Code;
Err : Boolean;
procedure Error_Bad_String_Char;
procedure Error_Unterminated_String;
procedure Set_String;
procedure Error_Bad_String_Char is
C : constant Character := Source (Scan_Ptr);
begin
if C = HT then
Error_Msg_S ("horizontal tab not allowed in string");
elsif C = VT or else C = FF then
Error_Msg_S ("format effector not allowed in string");
elsif C in Upper_Half_Character then
Error_Msg_S ("(Ada 83) upper half character not allowed");
else
Error_Msg_S ("control character not allowed in string");
end if;
end Error_Bad_String_Char;
procedure Error_Unterminated_String is
begin
while Source (Scan_Ptr - 1) = ' '
or else Source (Scan_Ptr - 1) = '&'
loop
Scan_Ptr := Scan_Ptr - 1;
Unstore_String_Char;
end loop;
if Delimiter /= '''
and then Source (Scan_Ptr - 1) = '''
then
Unstore_String_Char;
Error_Msg
("incorrect string terminator character", Scan_Ptr - 1);
return;
end if;
if Source (Scan_Ptr - 1) = ';' then
Scan_Ptr := Scan_Ptr - 1;
Unstore_String_Char;
if Source (Scan_Ptr - 1) = ')' then
Scan_Ptr := Scan_Ptr - 1;
Unstore_String_Char;
end if;
end if;
Error_Msg_S ("missing string quote");
end Error_Unterminated_String;
procedure Set_String is
Slen : constant Int := Int (Scan_Ptr - Token_Ptr - 2);
C1 : Character;
C2 : Character;
C3 : Character;
begin
if Slen = 1 then
C1 := Source (Token_Ptr + 1);
case C1 is
when '=' =>
Token_Name := Name_Op_Eq;
when '>' =>
Token_Name := Name_Op_Gt;
when '<' =>
Token_Name := Name_Op_Lt;
when '+' =>
Token_Name := Name_Op_Add;
when '-' =>
Token_Name := Name_Op_Subtract;
when '&' =>
Token_Name := Name_Op_Concat;
when '*' =>
Token_Name := Name_Op_Multiply;
when '/' =>
Token_Name := Name_Op_Divide;
when others =>
null;
end case;
elsif Slen = 2 then
C1 := Source (Token_Ptr + 1);
C2 := Source (Token_Ptr + 2);
if C1 = '*' and then C2 = '*' then
Token_Name := Name_Op_Expon;
elsif C2 = '=' then
if C1 = '/' then
Token_Name := Name_Op_Ne;
elsif C1 = '<' then
Token_Name := Name_Op_Le;
elsif C1 = '>' then
Token_Name := Name_Op_Ge;
end if;
elsif (C1 = 'O' or else C1 = 'o') and then (C2 = 'R' or else C2 = 'r')
then
Token_Name := Name_Op_Or;
end if;
elsif Slen = 3 then
C1 := Source (Token_Ptr + 1);
C2 := Source (Token_Ptr + 2);
C3 := Source (Token_Ptr + 3);
if (C1 = 'A' or else C1 = 'a') and then (C2 = 'N' or else C2 = 'n') and then
(C3 = 'D' or else C3 = 'd')
then
Token_Name := Name_Op_And;
elsif (C1 = 'A' or else C1 = 'a') and then (C2 = 'B' or else C2 = 'b') and then
(C3 = 'S' or else C3 = 's')
then
Token_Name := Name_Op_Abs;
elsif (C1 = 'M' or else C1 = 'm') and then (C2 = 'O' or else C2 = 'o') and then
(C3 = 'D' or else C3 = 'd')
then
Token_Name := Name_Op_Mod;
elsif (C1 = 'N' or else C1 = 'n') and then (C2 = 'O' or else C2 = 'o') and then
(C3 = 'T' or else C3 = 't')
then
Token_Name := Name_Op_Not;
elsif (C1 = 'R' or else C1 = 'r') and then (C2 = 'E' or else C2 = 'e') and then
(C3 = 'M' or else C3 = 'm')
then
Token_Name := Name_Op_Rem;
elsif (C1 = 'X' or else C1 = 'x') and then (C2 = 'O' or else C2 = 'o') and then
(C3 = 'R' or else C3 = 'r')
then
Token_Name := Name_Op_Xor;
end if;
end if;
if Token_Name = Error_Name then
Token := Tok_String_Literal;
else
Token := Tok_Operator_Symbol;
end if;
end Set_String;
begin
Delimiter := Source (Scan_Ptr);
Accumulate_Checksum (Delimiter);
Start_String;
Scan_Ptr := Scan_Ptr + 1;
loop
C := Source (Scan_Ptr);
if C = Delimiter then
Accumulate_Checksum (C);
Scan_Ptr := Scan_Ptr + 1;
exit when Source (Scan_Ptr) /= Delimiter;
Code := Get_Char_Code (C);
Accumulate_Checksum (C);
Scan_Ptr := Scan_Ptr + 1;
else
if C = '"' and then Delimiter = '%' then
Error_Msg_S
("quote not allowed in percent delimited string");
Code := Get_Char_Code (C);
Scan_Ptr := Scan_Ptr + 1;
elsif (C = ESC
and then
Wide_Character_Encoding_Method
in WC_ESC_Encoding_Method)
or else
(C in Upper_Half_Character
and then
Upper_Half_Encoding)
or else
(C = '['
and then
Source (Scan_Ptr + 1) = '"'
and then
Identifier_Char (Source (Scan_Ptr + 2)))
then
Scan_Wide (Source, Scan_Ptr, Code, Err);
Accumulate_Checksum (Code);
if Err then
Error_Illegal_Wide_Character;
Code := Get_Char_Code (' ');
end if;
else
Accumulate_Checksum (C);
if C not in Graphic_Character then
if C in Line_Terminator then
Error_Unterminated_String;
exit;
elsif C in Upper_Half_Character then
if Ada_83 then
Error_Bad_String_Char;
end if;
else
Error_Bad_String_Char;
end if;
end if;
Code := Get_Char_Code (C);
Scan_Ptr := Scan_Ptr + 1;
end if;
end if;
Store_String_Char (Code);
if not In_Character_Range (Code) then
Wide_Character_Found := True;
end if;
end loop;
String_Literal_Id := End_String;
Set_String;
return;
end Slit;
begin
Prev_Token := Token;
Prev_Token_Ptr := Token_Ptr;
Token_Name := Error_Name;
loop
while Source (Scan_Ptr) = ' ' loop
if Source (Scan_Ptr + 1) /= ' ' then
Scan_Ptr := Scan_Ptr + 1;
exit;
end if;
if Source (Scan_Ptr + 2) /= ' ' then
Scan_Ptr := Scan_Ptr + 2;
exit;
end if;
if Source (Scan_Ptr + 3) /= ' ' then
Scan_Ptr := Scan_Ptr + 3;
exit;
end if;
if Source (Scan_Ptr + 4) /= ' ' then
Scan_Ptr := Scan_Ptr + 4;
exit;
end if;
if Source (Scan_Ptr + 5) /= ' ' then
Scan_Ptr := Scan_Ptr + 5;
exit;
end if;
if Source (Scan_Ptr + 6) /= ' ' then
Scan_Ptr := Scan_Ptr + 6;
exit;
end if;
if Source (Scan_Ptr + 7) /= ' ' then
Scan_Ptr := Scan_Ptr + 7;
exit;
end if;
Scan_Ptr := Scan_Ptr + 8;
end loop;
Token_Ptr := Scan_Ptr;
case Source (Scan_Ptr) is
when CR | LF | FF | VT => Line_Terminator_Case : begin
Check_End_Of_Line;
if End_Of_Line_Is_Token then
Token_Ptr := Scan_Ptr;
end if;
declare
Physical : Boolean;
begin
Skip_Line_Terminators (Scan_Ptr, Physical);
if Physical then
Current_Line_Start := Scan_Ptr;
Start_Column := Set_Start_Column;
First_Non_Blank_Location := Scan_Ptr;
if End_Of_Line_Is_Token then
Token := Tok_End_Of_Line;
return;
end if;
end if;
end;
end Line_Terminator_Case;
when HT =>
if Style_Check then Style.Check_HT; end if;
Scan_Ptr := Scan_Ptr + 1;
when EOF =>
if Scan_Ptr = Source_Last (Current_Source_File) then
Check_End_Of_Line;
Token := Tok_EOF;
return;
else
Scan_Ptr := Scan_Ptr + 1;
end if;
when '&' =>
Accumulate_Checksum ('&');
if Source (Scan_Ptr + 1) = '&' then
Error_Msg_S ("'&'& should be `AND THEN`");
Scan_Ptr := Scan_Ptr + 2;
Token := Tok_And;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Ampersand;
return;
end if;
when '*' =>
Accumulate_Checksum ('*');
if Source (Scan_Ptr + 1) = '*' then
Accumulate_Checksum ('*');
Scan_Ptr := Scan_Ptr + 2;
Token := Tok_Double_Asterisk;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Asterisk;
return;
end if;
when ':' =>
Accumulate_Checksum (':');
if Double_Char_Token ('=') then
Token := Tok_Colon_Equal;
if Style_Check then Style.Check_Colon_Equal; end if;
return;
elsif Source (Scan_Ptr + 1) = '-'
and then Source (Scan_Ptr + 2) /= '-'
then
Token := Tok_Colon_Equal;
Error_Msg (":- should be :=", Scan_Ptr);
Scan_Ptr := Scan_Ptr + 2;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Colon;
if Style_Check then Style.Check_Colon; end if;
return;
end if;
when '(' =>
Accumulate_Checksum ('(');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Left_Paren;
if Style_Check then Style.Check_Left_Paren; end if;
return;
when '[' =>
if Source (Scan_Ptr + 1) = '"' then
Name_Len := 0;
goto Scan_Identifier;
else
Error_Msg_S ("illegal character, replaced by ""(""");
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Left_Paren;
return;
end if;
when '{' =>
Error_Msg_S ("illegal character, replaced by ""(""");
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Left_Paren;
return;
when ',' =>
Accumulate_Checksum (',');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Comma;
if Style_Check then Style.Check_Comma; end if;
return;
when '.' =>
Accumulate_Checksum ('.');
if Double_Char_Token ('.') then
Token := Tok_Dot_Dot;
if Style_Check then Style.Check_Dot_Dot; end if;
return;
elsif Source (Scan_Ptr + 1) in '0' .. '9' then
Error_Msg_S ("numeric literal cannot start with point");
Scan_Ptr := Scan_Ptr + 1;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Dot;
return;
end if;
when '=' =>
Accumulate_Checksum ('=');
if Double_Char_Token ('>') then
Token := Tok_Arrow;
if Style_Check then Style.Check_Arrow; end if;
return;
elsif Source (Scan_Ptr + 1) = '=' then
Error_Msg_S ("== should be =");
Scan_Ptr := Scan_Ptr + 1;
end if;
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Equal;
return;
when '>' =>
Accumulate_Checksum ('>');
if Double_Char_Token ('=') then
Token := Tok_Greater_Equal;
return;
elsif Double_Char_Token ('>') then
Token := Tok_Greater_Greater;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Greater;
return;
end if;
when '<' =>
Accumulate_Checksum ('<');
if Double_Char_Token ('=') then
Token := Tok_Less_Equal;
return;
elsif Double_Char_Token ('>') then
Token := Tok_Box;
if Style_Check then Style.Check_Box; end if;
return;
elsif Double_Char_Token ('<') then
Token := Tok_Less_Less;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Less;
return;
end if;
when '-' => Minus_Case : begin
if Source (Scan_Ptr + 1) = '>' then
Error_Msg_S ("invalid token");
Scan_Ptr := Scan_Ptr + 2;
Token := Tok_Arrow;
return;
elsif Source (Scan_Ptr + 1) /= '-' then
Accumulate_Checksum ('-');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Minus;
return;
else if Style_Check then Style.Check_Comment; end if;
Scan_Ptr := Scan_Ptr + 2;
Start_Of_Comment := Scan_Ptr;
loop
loop
exit when Source (Scan_Ptr) not in Graphic_Character;
Scan_Ptr := Scan_Ptr + 1;
exit when Source (Scan_Ptr) not in Graphic_Character;
Scan_Ptr := Scan_Ptr + 1;
exit when Source (Scan_Ptr) not in Graphic_Character;
Scan_Ptr := Scan_Ptr + 1;
exit when Source (Scan_Ptr) not in Graphic_Character;
Scan_Ptr := Scan_Ptr + 1;
exit when Source (Scan_Ptr) not in Graphic_Character;
Scan_Ptr := Scan_Ptr + 1;
end loop;
if Source (Scan_Ptr) = HT then
if Style_Check then Style.Check_HT; end if;
Scan_Ptr := Scan_Ptr + 1;
elsif Source (Scan_Ptr) in Line_Terminator then
exit;
elsif Source (Scan_Ptr) = EOF then
exit;
elsif Source (Scan_Ptr) in Upper_Half_Character
or else Source (Scan_Ptr) = ESC
then
Scan_Ptr := Scan_Ptr + 1;
else
Error_Illegal_Character;
end if;
end loop;
if Comment_Is_Token then
Name_Len := Integer (Scan_Ptr - Start_Of_Comment);
Name_Buffer (1 .. Name_Len) :=
String (Source (Start_Of_Comment .. Scan_Ptr - 1));
Comment_Id := Name_Find;
Token := Tok_Comment;
return;
end if;
end if;
end Minus_Case;
when '"' =>
Slit;
Post_Scan;
return;
when '%' =>
if Warn_On_Obsolescent_Feature then
Error_Msg_S
("use of ""'%"" is an obsolescent feature ('R'M 'J.2(4))?");
Error_Msg_S
("\use """""" instead?");
end if;
Slit;
Post_Scan;
return;
when ''' => Char_Literal_Case : declare
Code : Char_Code;
Err : Boolean;
begin
Accumulate_Checksum (''');
Scan_Ptr := Scan_Ptr + 1;
if Prev_Token = Tok_Identifier
or else Prev_Token = Tok_Right_Paren
or else Prev_Token = Tok_All
or else Prev_Token = Tok_Project
or else Prev_Token in Token_Class_Literal
then
Token := Tok_Apostrophe;
if Style_Check then Style.Check_Apostrophe; end if;
return;
else
if (Source (Scan_Ptr) = ESC
and then
Wide_Character_Encoding_Method in WC_ESC_Encoding_Method)
or else
(Source (Scan_Ptr) in Upper_Half_Character
and then
Upper_Half_Encoding)
or else
(Source (Scan_Ptr) = '['
and then
Source (Scan_Ptr + 1) = '"')
then
Scan_Wide (Source, Scan_Ptr, Code, Err);
Accumulate_Checksum (Code);
if Err then
Error_Illegal_Wide_Character;
end if;
if Source (Scan_Ptr) /= ''' then
Error_Msg_S ("missing apostrophe");
else
Scan_Ptr := Scan_Ptr + 1;
end if;
elsif Source (Scan_Ptr + 1) /= ''' then
if Prev_Token = Tok_Range then
Token := Tok_Apostrophe;
return;
else
Scan_Ptr := Scan_Ptr - 1;
Error_Msg_S
("strings are delimited by double quote character");
Slit;
Post_Scan;
return;
end if;
else
Accumulate_Checksum (Source (Scan_Ptr));
if Source (Scan_Ptr) not in Graphic_Character then
if Source (Scan_Ptr) in Upper_Half_Character then
if Ada_83 then
Error_Illegal_Character;
end if;
else
Error_Illegal_Character;
end if;
end if;
Code := Get_Char_Code (Source (Scan_Ptr));
Scan_Ptr := Scan_Ptr + 2;
end if;
Accumulate_Checksum (''');
Token := Tok_Char_Literal;
Set_Character_Literal_Name (Code);
Token_Name := Name_Find;
Character_Code := Code;
Post_Scan;
return;
end if;
end Char_Literal_Case;
when ')' =>
Accumulate_Checksum (')');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Right_Paren;
if Style_Check then Style.Check_Right_Paren; end if;
return;
when ']' | '}' =>
Error_Msg_S ("illegal character, replaced by "")""");
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Right_Paren;
return;
when '/' =>
Accumulate_Checksum ('/');
if Double_Char_Token ('=') then
Token := Tok_Not_Equal;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Slash;
return;
end if;
when ';' =>
Accumulate_Checksum (';');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Semicolon;
if Style_Check then Style.Check_Semicolon; end if;
return;
when '|' => Vertical_Bar_Case : begin
Accumulate_Checksum ('|');
if Source (Scan_Ptr + 1) = '|' then
Error_Msg_S ("""'|'|"" should be `OR ELSE`");
Scan_Ptr := Scan_Ptr + 2;
Token := Tok_Or;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Vertical_Bar;
if Style_Check then Style.Check_Vertical_Bar; end if;
return;
end if;
end Vertical_Bar_Case;
when '!' => Exclamation_Case : begin
Accumulate_Checksum ('!');
if Warn_On_Obsolescent_Feature then
Error_Msg_S
("use of ""'!"" is an obsolescent feature ('R'M 'J.2(2))?");
Error_Msg_S
("\use ""'|"" instead?");
end if;
if Source (Scan_Ptr + 1) = '=' then
Error_Msg_S ("'!= should be /=");
Scan_Ptr := Scan_Ptr + 2;
Token := Tok_Not_Equal;
return;
else
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Vertical_Bar;
return;
end if;
end Exclamation_Case;
when '+' => Plus_Case : begin
Accumulate_Checksum ('+');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Plus;
return;
end Plus_Case;
when '0' .. '9' =>
Nlit;
if Identifier_Char (Source (Scan_Ptr)) then
Error_Msg_S
("delimiter required between literal and identifier");
end if;
Post_Scan;
return;
when 'a' .. 'z' =>
Name_Len := 1;
Name_Buffer (1) := Source (Scan_Ptr);
Accumulate_Checksum (Name_Buffer (1));
Scan_Ptr := Scan_Ptr + 1;
goto Scan_Identifier;
when 'A' .. 'Z' =>
Name_Len := 1;
Name_Buffer (1) :=
Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
Accumulate_Checksum (Name_Buffer (1));
Scan_Ptr := Scan_Ptr + 1;
goto Scan_Identifier;
when '_' =>
if Special_Characters ('_') then
Token_Ptr := Scan_Ptr;
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_Special;
Special_Character := '_';
return;
end if;
Error_Msg_S ("identifier cannot start with underline");
Name_Len := 1;
Name_Buffer (1) := '_';
Scan_Ptr := Scan_Ptr + 1;
goto Scan_Identifier;
when ' ' =>
raise Program_Error;
when Upper_Half_Character =>
if Upper_Half_Encoding then
Name_Len := 0;
goto Scan_Identifier;
else
if Identifier_Char (Source (Scan_Ptr)) then
Name_Len := 0;
goto Scan_Identifier;
else
Error_Illegal_Character;
end if;
end if;
when ESC =>
if Identifier_Char (ESC) then
Name_Len := 0;
goto Scan_Identifier;
else
Error_Illegal_Wide_Character;
end if;
when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | SO |
SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
EM | FS | GS | RS | US | DEL
=>
Error_Illegal_Character;
when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' =>
if Special_Characters (Source (Scan_Ptr)) then
Token_Ptr := Scan_Ptr;
Token := Tok_Special;
Special_Character := Source (Scan_Ptr);
Scan_Ptr := Scan_Ptr + 1;
return;
else
Error_Illegal_Character;
end if;
end case;
end loop;
<<Scan_Identifier>>
loop
if Source (Scan_Ptr) in 'a' .. 'z'
or else Source (Scan_Ptr) in '0' .. '9'
then
Name_Buffer (Name_Len + 1) := Source (Scan_Ptr);
Accumulate_Checksum (Source (Scan_Ptr));
elsif Source (Scan_Ptr) in 'A' .. 'Z' then
Name_Buffer (Name_Len + 1) :=
Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
Accumulate_Checksum (Name_Buffer (Name_Len + 1));
else
exit;
end if;
if Source (Scan_Ptr + 1) in 'a' .. 'z'
or else Source (Scan_Ptr + 1) in '0' .. '9'
then
Name_Buffer (Name_Len + 2) := Source (Scan_Ptr + 1);
Accumulate_Checksum (Source (Scan_Ptr + 1));
elsif Source (Scan_Ptr + 1) in 'A' .. 'Z' then
Name_Buffer (Name_Len + 2) :=
Character'Val (Character'Pos (Source (Scan_Ptr + 1)) + 32);
Accumulate_Checksum (Name_Buffer (Name_Len + 2));
else
Scan_Ptr := Scan_Ptr + 1;
Name_Len := Name_Len + 1;
exit;
end if;
if Source (Scan_Ptr + 2) in 'a' .. 'z'
or else Source (Scan_Ptr + 2) in '0' .. '9'
then
Name_Buffer (Name_Len + 3) := Source (Scan_Ptr + 2);
Accumulate_Checksum (Source (Scan_Ptr + 2));
elsif Source (Scan_Ptr + 2) in 'A' .. 'Z' then
Name_Buffer (Name_Len + 3) :=
Character'Val (Character'Pos (Source (Scan_Ptr + 2)) + 32);
Accumulate_Checksum (Name_Buffer (Name_Len + 3));
else
Scan_Ptr := Scan_Ptr + 2;
Name_Len := Name_Len + 2;
exit;
end if;
if Source (Scan_Ptr + 3) in 'a' .. 'z'
or else Source (Scan_Ptr + 3) in '0' .. '9'
then
Name_Buffer (Name_Len + 4) := Source (Scan_Ptr + 3);
Accumulate_Checksum (Source (Scan_Ptr + 3));
elsif Source (Scan_Ptr + 3) in 'A' .. 'Z' then
Name_Buffer (Name_Len + 4) :=
Character'Val (Character'Pos (Source (Scan_Ptr + 3)) + 32);
Accumulate_Checksum (Name_Buffer (Name_Len + 4));
else
Scan_Ptr := Scan_Ptr + 3;
Name_Len := Name_Len + 3;
exit;
end if;
Scan_Ptr := Scan_Ptr + 4;
Name_Len := Name_Len + 4;
end loop;
if Identifier_Char (Source (Scan_Ptr)) then
if Source (Scan_Ptr) = '_' then
Accumulate_Checksum ('_');
if not Identifier_Char (Source (Scan_Ptr + 1)) then
Error_Msg_S ("identifier cannot end with underline");
Scan_Ptr := Scan_Ptr + 1;
elsif Source (Scan_Ptr + 1) = '_' then
Error_No_Double_Underline;
else
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := '_';
end if;
Scan_Ptr := Scan_Ptr + 1;
goto Scan_Identifier;
elsif Source (Scan_Ptr) in Upper_Half_Character
and then not Upper_Half_Encoding
then
Accumulate_Checksum (Source (Scan_Ptr));
Store_Encoded_Character
(Get_Char_Code (Fold_Lower (Source (Scan_Ptr))));
Scan_Ptr := Scan_Ptr + 1;
goto Scan_Identifier;
elsif Source (Scan_Ptr) = '['
and then Source (Scan_Ptr + 1) /= '"'
then
null;
else
declare
Sptr : constant Source_Ptr := Scan_Ptr;
Code : Char_Code;
Err : Boolean;
Chr : Character;
begin
Scan_Wide (Source, Scan_Ptr, Code, Err);
if Err then
Error_Illegal_Wide_Character;
elsif In_Character_Range (Code)
and then Identifier_Char (Get_Character (Code))
then
Chr := Get_Character (Code);
Accumulate_Checksum (Chr);
Store_Encoded_Character
(Get_Char_Code (Fold_Lower (Chr)));
else
Accumulate_Checksum (Code);
Store_Encoded_Character (Code);
if Identifier_Character_Set /= 'w' then
Error_Msg
("wide character not allowed in identifier", Sptr);
end if;
end if;
end;
goto Scan_Identifier;
end if;
end if;
Token_Name := Name_Find;
if Get_Name_Table_Byte (Token_Name) /= 0
and then (Ada_95 or else Token_Name not in Ada_95_Reserved_Words)
then
Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
if Style_Check
and then Source (Token_Ptr) <= 'Z'
and then (Prev_Token /= Tok_Apostrophe
or else
(Token /= Tok_Access
and then Token /= Tok_Delta
and then Token /= Tok_Digits
and then Token /= Tok_Range))
then
Style.Non_Lower_Case_Keyword;
end if;
Token_Name := No_Name;
Accumulate_Token_Checksum;
return;
else
Token := Tok_Identifier;
Accumulate_Token_Checksum;
Post_Scan;
return;
end if;
end Scan;
procedure Set_Comment_As_Token (Value : Boolean) is
begin
Comment_Is_Token := Value;
end Set_Comment_As_Token;
procedure Set_End_Of_Line_As_Token (Value : Boolean) is
begin
End_Of_Line_Is_Token := Value;
end Set_End_Of_Line_As_Token;
procedure Set_Special_Character (C : Character) is
begin
case C is
when '#' | '$' | '_' | '?' | '@' | '`' | '\' | '^' | '~' =>
Special_Characters (C) := True;
when others =>
null;
end case;
end Set_Special_Character;
function Set_Start_Column return Column_Number is
Start_Column : Column_Number := 0;
begin
Tabs_Loop : loop
Blanks_Loop : loop
if Source (Scan_Ptr) = ' ' then
if Source (Scan_Ptr + 1) = ' ' then
if Source (Scan_Ptr + 2) = ' ' then
if Source (Scan_Ptr + 3) = ' ' then
if Source (Scan_Ptr + 4) = ' ' then
if Source (Scan_Ptr + 5) = ' ' then
if Source (Scan_Ptr + 6) = ' ' then
Scan_Ptr := Scan_Ptr + 7;
Start_Column := Start_Column + 7;
else
Scan_Ptr := Scan_Ptr + 6;
Start_Column := Start_Column + 6;
exit Blanks_Loop;
end if;
else
Scan_Ptr := Scan_Ptr + 5;
Start_Column := Start_Column + 5;
exit Blanks_Loop;
end if;
else
Scan_Ptr := Scan_Ptr + 4;
Start_Column := Start_Column + 4;
exit Blanks_Loop;
end if;
else
Scan_Ptr := Scan_Ptr + 3;
Start_Column := Start_Column + 3;
exit Blanks_Loop;
end if;
else
Scan_Ptr := Scan_Ptr + 2;
Start_Column := Start_Column + 2;
exit Blanks_Loop;
end if;
else
Scan_Ptr := Scan_Ptr + 1;
Start_Column := Start_Column + 1;
exit Blanks_Loop;
end if;
else
exit Blanks_Loop;
end if;
end loop Blanks_Loop;
if Source (Scan_Ptr) = HT then
if Style_Check then Style.Check_HT; end if;
Scan_Ptr := Scan_Ptr + 1;
Start_Column := (Start_Column / 8) * 8 + 8;
else
exit Tabs_Loop;
end if;
end loop Tabs_Loop;
return Start_Column;
end Set_Start_Column;
end Scng;