with Atree; use Atree;
with Csets; use Csets;
with Errout; use Errout;
with Hostparm; use Hostparm;
with Namet; use Namet;
with Opt; use Opt;
with Scans; use Scans;
with Sinput; use Sinput;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Style;
with Widechar; use Widechar;
with System.CRC32;
with System.WCh_Con; use System.WCh_Con;
package body Scn is
use ASCII;
Used_As_Identifier : array (Token_Type) of Boolean;
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 Check_End_Of_Line;
function Determine_License return License_Type;
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;
function Set_Start_Column return Column_Number;
procedure Slit;
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 Check_End_Of_Line is
Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start);
begin
if Len > Hostparm.Max_Line_Length then
Error_Long_Line;
elsif Style_Check then
Style.Check_Line_Terminator (Len);
end if;
end Check_End_Of_Line;
function Determine_License return License_Type is
GPL_Found : Boolean := False;
function Contains (S : String) return Boolean;
procedure Skip_EOL;
function Contains (S : String) return Boolean is
CP : Natural;
SP : Source_Ptr;
SS : Source_Ptr;
begin
SP := Scan_Ptr;
while Source (SP) /= CR and then Source (SP) /= LF loop
if Source (SP) = S (S'First) then
SS := SP;
CP := S'First;
loop
SS := SS + 1;
CP := CP + 1;
if CP > S'Last then
return True;
end if;
while Source (SS) = ' ' loop
SS := SS + 1;
end loop;
exit when Source (SS) /= S (CP);
end loop;
end if;
SP := SP + 1;
end loop;
return False;
end Contains;
procedure Skip_EOL is
begin
while Source (Scan_Ptr) /= CR
and then Source (Scan_Ptr) /= LF
loop
Scan_Ptr := Scan_Ptr + 1;
end loop;
end Skip_EOL;
begin
loop
if Source (Scan_Ptr) /= '-'
or else Source (Scan_Ptr + 1) /= '-'
then
if GPL_Found then
return GPL;
else
return Unknown;
end if;
elsif Contains ("Asaspecialexception") then
if GPL_Found then
return Modified_GPL;
end if;
elsif Contains ("GNUGeneralPublicLicense") then
GPL_Found := True;
elsif
Contains
("ThisspecificationisadaptedfromtheAdaSemanticInterface")
or else
Contains
("ThisspecificationisderivedfromtheAdaReferenceManual")
then
return Unrestricted;
end if;
Skip_EOL;
Check_End_Of_Line;
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;
end if;
end;
end loop;
end Determine_License;
function Determine_Token_Casing return Casing_Type is
begin
return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1));
end Determine_Token_Casing;
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
if OpenVMS then
Error_Msg_S
("illegal wide character, check " &
"'/'W'I'D'E'_'C'H'A'R'A'C'T'E'R'_'E'N'C'O'D'I'N'G qualifer");
else
Error_Msg_S
("illegal wide character, check -gnatW switch");
end if;
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 + Hostparm.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 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
GNAT_Hedr : constant Text_Buffer (1 .. 78) := (others => '-');
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;
Set_Comes_From_Source_Default (True);
if Source_Last (Index) - Scan_Ptr > 80
and then Source (Scan_Ptr .. Scan_Ptr + 77) = GNAT_Hedr
then
Set_License (Current_Source_File, Determine_License);
end if;
Scan;
for J in Token_Type loop
Used_As_Identifier (J) := False;
end loop;
end Initialize_Scanner;
procedure Nlit is separate;
procedure Scan is
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;
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;
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;
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;
end if;
end Minus_Case;
when '"' | '%' =>
Slit;
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 in Token_Class_Literal
then
Token := Tok_Apostrophe;
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");
Scn.Slit;
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;
Token_Node := New_Node (N_Character_Literal, Token_Ptr);
Set_Char_Literal_Value (Token_Node, Code);
Set_Character_Literal_Name (Code);
Token_Name := Name_Find;
Set_Chars (Token_Node, Token_Name);
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 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;
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 '_' =>
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 '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' =>
Error_Illegal_Character;
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 ('_');
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := '_';
if Identifier_Char (Source (Scan_Ptr + 1)) then
Scan_Ptr := Scan_Ptr + 1;
if Source (Scan_Ptr) = '_' then
Error_No_Double_Underline;
end if;
else
Error_Msg_S ("identifier cannot end with underline");
Scan_Ptr := Scan_Ptr + 1;
end if;
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;
return;
else
Token_Node := New_Node (N_Identifier, Token_Ptr);
Set_Chars (Token_Node, Token_Name);
Token := Tok_Identifier;
return;
end if;
end Scan;
function Scan_First_Char return Source_Ptr is
Ptr : Source_Ptr := Current_Line_Start;
begin
loop
if Source (Ptr) = ' ' then
Ptr := Ptr + 1;
elsif Source (Ptr) = HT then
if Style_Check then Style.Check_HT; end if;
Ptr := Ptr + 1;
else
return Ptr;
end if;
end loop;
end Scan_First_Char;
procedure Scan_Reserved_Identifier (Force_Msg : Boolean) is
Token_Chars : constant String := Token_Type'Image (Token);
begin
Name_Len := 0;
for J in 5 .. Token_Chars'Length loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Fold_Lower (Token_Chars (J));
end loop;
Token_Name := Name_Find;
if not Used_As_Identifier (Token) or else Force_Msg then
Error_Msg_Name_1 := Token_Name;
Error_Msg_SC ("reserved word* cannot be used as identifier!");
Used_As_Identifier (Token) := True;
end if;
Token := Tok_Identifier;
Token_Node := New_Node (N_Identifier, Token_Ptr);
Set_Chars (Token_Node, Token_Name);
end Scan_Reserved_Identifier;
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;
procedure Slit is separate;
end Scn;