with Csets; use Csets;
with Err_Vars; use Err_Vars;
with Hostparm; use Hostparm;
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;
with GNAT.UTF_32; use GNAT.UTF_32;
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
if C > 16#FFFF# then
Accumulate_Checksum (Character'Val (C / 2 ** 24));
Accumulate_Checksum (Character'Val ((C / 2 ** 16) mod 256));
Accumulate_Checksum (Character'Val ((C / 256) mod 256));
else
Accumulate_Checksum (Character'Val (C / 256));
end if;
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 (Index : Source_File_Index) is
begin
Scans.Initialize_Ada_Keywords;
Current_Source_File := Index;
Source := Source_Text (Current_Source_File);
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;
Wide_Char_Byte_Count := 0;
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;
Underline_Found : Boolean;
Wptr : 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) -
Wide_Char_Byte_Count;
begin
if Style_Check then
Style.Check_Line_Terminator (Len);
end if;
if Style_Check and Style_Check_Max_Line_Length then
Style.Check_Line_Max_Length (Len);
elsif Len > Max_Line_Length then
Error_Long_Line;
end if;
Wide_Char_Byte_Count := 0;
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 ("illegal wide character", Wptr);
end Error_Illegal_Wide_Character;
procedure Error_Long_Line is
begin
Error_Msg
("this line is too long",
Current_Line_Start + Source_Ptr (Max_Line_Length));
end Error_Long_Line;
procedure Error_No_Double_Underline is
begin
Underline_Found := False;
if Source (Scan_Ptr) = '_' then
if Source (Scan_Ptr - 1) = '_' then
Error_Msg_S
("two consecutive underlines not permitted");
else
Error_Msg_S
("underline cannot follow punctuation character");
end if;
else
if Source (Scan_Ptr - 1) = '_' then
Error_Msg_S
("punctuation character cannot follow underline");
else
Error_Msg_S
("two consecutive punctuation characters not permitted");
end if;
end if;
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;
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 = ':' then
Obsolescent_Check (Scan_Ptr);
if 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;
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
Wptr := Scan_Ptr;
Scan_Wide (Source, Scan_Ptr, Code, Err);
if Err then
Error_Illegal_Wide_Character;
Code := Get_Char_Code (' ');
end if;
Accumulate_Checksum (Code);
if Ada_Version >= Ada_05
and then Is_UTF_32_Non_Graphic (UTF_32 (Code))
then
Error_Msg
("(Ada 2005) non-graphic character not permitted " &
"in string literal", Wptr);
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_Version = 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;
<<Scan_Next_Character>>
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 =>
goto Scan_Line_Terminator;
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;
if Style_Check then
Style.Check_EOF;
end if;
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
goto Scan_Wide_Character;
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;
if Replace_In_Comments then
Token := Tok_Comment;
return;
end if;
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) = ESC
and then Identifier_Char (ESC))
or else
(Source (Scan_Ptr) in Upper_Half_Character
and then Upper_Half_Encoding)
then
declare
Wptr : constant Source_Ptr := Scan_Ptr;
Code : Char_Code;
Err : Boolean;
begin
Scan_Wide (Source, Scan_Ptr, Code, Err);
if Err then
Scan_Ptr := Wptr + 1;
elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then
Scan_Ptr := Wptr;
exit;
end if;
end;
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 '%' =>
Obsolescent_Check (Token_Ptr);
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
Wptr := Scan_Ptr;
Scan_Wide (Source, Scan_Ptr, Code, Err);
Accumulate_Checksum (Code);
if Err then
Error_Illegal_Wide_Character;
Code := Character'Pos (' ');
elsif Ada_Version >= Ada_05
and then Is_UTF_32_Non_Graphic (UTF_32 (Code))
then
Error_Msg
("(Ada 2005) non-graphic character not permitted " &
"in character literal", Wptr);
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_Version = 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 ('!');
Obsolescent_Check (Token_Ptr);
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;
Underline_Found := False;
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;
Underline_Found := False;
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;
Underline_Found := False;
goto Scan_Identifier;
when ' ' =>
raise Program_Error;
when Upper_Half_Character =>
if Upper_Half_Encoding then
goto Scan_Wide_Character;
else
if Identifier_Char (Source (Scan_Ptr)) then
Name_Len := 0;
Underline_Found := False;
goto Scan_Identifier;
else
Error_Illegal_Character;
end if;
end if;
when ESC =>
if Identifier_Char (ESC) then
Name_Len := 0;
goto Scan_Wide_Character;
else
Error_Illegal_Character;
end if;
when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | ASCII.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_Wide_Character>>
declare
Code : Char_Code;
Cat : Category;
Err : Boolean;
begin
Wptr := Scan_Ptr;
Scan_Wide (Source, Scan_Ptr, Code, Err);
if Err then
Error_Illegal_Wide_Character;
goto Scan_Next_Character;
end if;
Cat := Get_Category (UTF_32 (Code));
if Is_UTF_32_Letter (Cat) then
Scan_Ptr := Wptr;
Name_Len := 0;
Underline_Found := False;
goto Scan_Identifier;
elsif Is_UTF_32_Space (Cat) then
goto Scan_Next_Character;
elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then
Scan_Ptr := Wptr;
goto Scan_Line_Terminator;
elsif Is_UTF_32_Punctuation (Cat) then
Error_Msg
("identifier cannot start with punctuation", Wptr);
Scan_Ptr := Wptr;
Name_Len := 0;
Underline_Found := False;
goto Scan_Identifier;
elsif Is_UTF_32_Mark (Cat) then
Error_Msg
("identifier cannot start with mark character", Wptr);
Scan_Ptr := Wptr;
Name_Len := 0;
Underline_Found := False;
goto Scan_Identifier;
elsif Is_UTF_32_Other (Cat) then
Error_Msg
("identifier cannot start with other format character", Wptr);
Scan_Ptr := Wptr;
Name_Len := 0;
Underline_Found := False;
goto Scan_Identifier;
elsif Is_UTF_32_Digit (Cat) then
Error_Msg
("identifier cannot start with digit character", Wptr);
Scan_Ptr := Wptr;
Name_Len := 0;
Underline_Found := False;
goto Scan_Identifier;
else
Error_Illegal_Wide_Character;
goto Scan_Next_Character;
end if;
end;
<<Scan_Line_Terminator>>
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;
goto Scan_Next_Character;
<<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;
Underline_Found := False;
Scan_Ptr := Scan_Ptr + 1;
Name_Len := Name_Len + 1;
end loop;
if Identifier_Char (Source (Scan_Ptr)) then
if Source (Scan_Ptr) = '_' then
Accumulate_Checksum ('_');
if Underline_Found then
Error_No_Double_Underline;
else
Underline_Found := True;
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;
Underline_Found := False;
goto Scan_Identifier;
elsif Source (Scan_Ptr) = '['
and then Source (Scan_Ptr + 1) /= '"'
then
null;
else
declare
Code : Char_Code;
Err : Boolean;
Chr : Character;
Cat : Category;
begin
Wptr := Scan_Ptr;
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)));
Underline_Found := False;
else
if Identifier_Character_Set /= 'w'
and then Ada_Version < Ada_05
then
Error_Msg
("wide character not allowed in identifier", Wptr);
end if;
Cat := Get_Category (UTF_32 (Code));
if Is_UTF_32_Letter (Cat) then
Code :=
Char_Code (UTF_32_To_Upper_Case (UTF_32 (Code)));
Accumulate_Checksum (Code);
Store_Encoded_Character (Code);
Underline_Found := False;
elsif Is_UTF_32_Digit (Cat)
or else Is_UTF_32_Mark (Cat)
then
Accumulate_Checksum (Code);
Store_Encoded_Character (Code);
Underline_Found := False;
elsif Is_UTF_32_Punctuation (Cat) then
Accumulate_Checksum (Code);
if Underline_Found then
declare
Cend : constant Source_Ptr := Scan_Ptr;
begin
Scan_Ptr := Wptr;
Error_No_Double_Underline;
Scan_Ptr := Cend;
end;
else
Store_Encoded_Character (Code);
Underline_Found := True;
end if;
elsif Is_UTF_32_Other (Cat) then
null;
elsif Is_UTF_32_Space (Cat) then
goto Scan_Identifier_Complete;
else
Error_Msg
("invalid wide character in identifier", Wptr);
end if;
end if;
goto Scan_Identifier;
end;
end if;
end if;
<<Scan_Identifier_Complete>>
Token_Name := Name_Find;
if Underline_Found then
Underline_Found := False;
if Source (Scan_Ptr - 1) = '_' then
Error_Msg
("identifier cannot end with underline", Scan_Ptr - 1);
else
Error_Msg
("identifier cannot end with punctuation character", Wptr);
end if;
end if;
if Is_Keyword_Name (Token_Name) 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_Mod and then
Token /= Tok_Range))
and then (Token /= Tok_Interface
or else
(Token = Tok_Interface
and then Prev_Token /= Tok_Pragma))
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;