with Uintp; use Uintp;
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
separate (Par)
package body Util is
function Bad_Spelling_Of (T : Token_Type) return Boolean is
Tname : constant String := Token_Type'Image (T);
S : String (1 .. Tname'Last - 4);
M1 : String (1 .. 42) := "incorrect spelling of keyword ************";
M2 : String (1 .. 44) := "illegal abbreviation of keyword ************";
P1 : constant := 30;
P2 : constant := 32;
SL : constant Natural := S'Length;
begin
if Token /= Tok_Identifier then
return False;
end if;
for J in S'Range loop
S (J) := Fold_Lower (Tname (Integer (J) + 4));
end loop;
Get_Name_String (Token_Name);
if T = Tok_Procedure
and then Name_Len = 7
and then Name_Buffer (1 .. 7) = "program"
then
Error_Msg_SC ("PROCEDURE expected");
Token := T;
return True;
elsif Name_Len < S'Length
and then Name_Len >= 4
and then Name_Buffer (1 .. Name_Len) = S (1 .. Name_Len)
then
for J in 1 .. S'Last loop
M2 (P2 + J - 1) := Fold_Upper (S (J));
end loop;
Error_Msg_SC (M2 (1 .. P2 - 1 + S'Last));
Token := T;
return True;
end if;
if SL < 3 or else Name_Len < 3 then
return False;
elsif Name_Len > SL + 1
and then S = Name_Buffer (1 .. SL)
then
Scan_Ptr := Token_Ptr + S'Length;
Error_Msg_S ("missing space");
Token := T;
return True;
end if;
if Is_Bad_Spelling_Of (Name_Buffer (1 .. Name_Len), S) then
for J in 1 .. S'Last loop
M1 (P1 + J - 1) := Fold_Upper (S (J));
end loop;
Error_Msg_SC (M1 (1 .. P1 - 1 + S'Last));
Token := T;
return True;
else
return False;
end if;
end Bad_Spelling_Of;
procedure Check_95_Keyword (Token_95, Next : Token_Type) is
Scan_State : Saved_Scan_State;
begin
Save_Scan_State (Scan_State); Scan;
if Token = Next then
Restore_Scan_State (Scan_State); Error_Msg_Name_1 := Token_Name;
Error_Msg_SC ("(Ada 83) keyword* cannot be used!");
Token := Token_95;
else
Restore_Scan_State (Scan_State); end if;
end Check_95_Keyword;
procedure Check_Bad_Layout is
begin
if Style.RM_Column_Check and then Token_Is_At_Start_Of_Line
and then Start_Column <= Scope.Table (Scope.Last).Ecol
then
Error_Msg_BC ("(style) incorrect layout");
end if;
end Check_Bad_Layout;
procedure Check_Misspelling_Of (T : Token_Type) is
begin
if Bad_Spelling_Of (T) then
null;
end if;
end Check_Misspelling_Of;
procedure Check_Simple_Expression (E : Node_Id) is
begin
if Expr_Form = EF_Non_Simple then
Error_Msg_N ("this expression must be parenthesized", E);
end if;
end Check_Simple_Expression;
procedure Check_Simple_Expression_In_Ada_83 (E : Node_Id) is
begin
if Expr_Form = EF_Non_Simple then
if Ada_83 then
Error_Msg_N ("(Ada 83) this expression must be parenthesized!", E);
end if;
end if;
end Check_Simple_Expression_In_Ada_83;
function Check_Subtype_Mark (Mark : Node_Id) return Node_Id is
begin
if Nkind (Mark) = N_Identifier
or else Nkind (Mark) = N_Selected_Component
or else (Nkind (Mark) = N_Attribute_Reference
and then Is_Type_Attribute_Name (Attribute_Name (Mark)))
or else Mark = Error
then
return Mark;
else
Error_Msg ("subtype mark expected", Sloc (Mark));
return Error;
end if;
end Check_Subtype_Mark;
function Comma_Present return Boolean is
Scan_State : Saved_Scan_State;
Paren_Count : Nat;
begin
if Token = Tok_Comma then
T_Comma;
return True;
elsif Token = Tok_Right_Paren then
return False;
elsif Token = Tok_Pragma then
P_Pragmas_Misplaced;
return Comma_Present;
elsif Token = Tok_Semicolon then
Save_Scan_State (Scan_State);
Scan;
if Token = Tok_Identifier then
Scan;
if Token = Tok_Arrow then
goto Assume_Comma;
end if;
end if;
Paren_Count := 0;
loop
if Token = Tok_Semicolon or else Token = Tok_EOF then
Restore_Scan_State (Scan_State);
return False;
elsif Token = Tok_Comma then
exit when Paren_Count = 0;
elsif Token = Tok_Left_Paren then
Paren_Count := Paren_Count + 1;
elsif Token = Tok_Right_Paren then
exit when Paren_Count = 0;
Paren_Count := Paren_Count - 1;
end if;
Scan;
end loop;
<<Assume_Comma>>
Restore_Scan_State (Scan_State);
Error_Msg_SC (""";"" illegal here, replaced by "",""");
Scan; return True;
elsif Token in Token_Class_Eterm then
return False;
else
T_Comma; return True;
end if;
end Comma_Present;
procedure Discard_Junk_List (L : List_Id) is
pragma Warnings (Off, L);
begin
null;
end Discard_Junk_List;
procedure Discard_Junk_Node (N : Node_Id) is
pragma Warnings (Off, N);
begin
null;
end Discard_Junk_Node;
procedure Ignore (T : Token_Type) is
begin
if Token = T then
if T = Tok_Comma then
Error_Msg_SC ("unexpected "","" ignored");
elsif T = Tok_Left_Paren then
Error_Msg_SC ("unexpected ""("" ignored");
elsif T = Tok_Right_Paren then
Error_Msg_SC ("unexpected "")"" ignored");
elsif T = Tok_Semicolon then
Error_Msg_SC ("unexpected "";"" ignored");
else
declare
Tname : constant String := Token_Type'Image (Token);
Msg : String := "unexpected keyword ????????????????????????";
begin
for J in 5 .. Tname'Last loop
Msg (J + 14) := Fold_Upper (Tname (J));
end loop;
Msg (Tname'Last + 15 .. Tname'Last + 22) := " ignored";
Error_Msg_SC (Msg (1 .. Tname'Last + 22));
end;
end if;
Scan; end if;
end Ignore;
function Is_Reserved_Identifier return Boolean is
begin
if not Is_Reserved_Keyword (Token) then
return False;
else
declare
Ident_Casing : constant Casing_Type :=
Identifier_Casing (Current_Source_File);
Key_Casing : constant Casing_Type :=
Keyword_Casing (Current_Source_File);
begin
if Ident_Casing /= Unknown
and then Key_Casing /= Unknown
and then Ident_Casing /= Key_Casing
and then Determine_Token_Casing = Key_Casing
then
return False;
else
return True;
end if;
end;
end if;
end Is_Reserved_Identifier;
procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type) is
begin
if Token /= Tok_Identifier then
return;
end if;
declare
S : Saved_Scan_State;
T : Token_Type;
begin
Save_Scan_State (S);
Scan;
T := Token;
Restore_Scan_State (S);
if T /= Nxt then
return;
end if;
end;
if Source (Token_Ptr - 1) /= ' '
or else Int (Token_Ptr) /=
Int (Prev_Token_Ptr) + Length_Of_Name (Chars (Prev)) + 1
then
return;
end if;
Get_Name_String (Chars (Token_Node));
declare
Buf : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
begin
Get_Name_String (Chars (Prev));
Add_Char_To_Name_Buffer ('_');
Add_Str_To_Name_Buffer (Buf);
Set_Chars (Prev, Name_Find);
end;
Error_Msg_Node_1 := Prev;
Error_Msg_SC
("unexpected identifier, possibly & was meant here");
Scan;
end Merge_Identifier;
procedure No_Constraint is
begin
if Token in Token_Class_Consk then
Error_Msg_SC ("constraint not allowed here");
Discard_Junk_Node (P_Constraint_Opt);
end if;
end No_Constraint;
function No_Right_Paren (Expr : Node_Id) return Node_Id is
begin
if Token = Tok_Right_Paren then
Error_Msg_SC ("unexpected right parenthesis");
Resync_Expression;
return Error;
else
return Expr;
end if;
end No_Right_Paren;
procedure Pop_Scope_Stack is
begin
pragma Assert (Scope.Last > 0);
Scope.Decrement_Last;
if Debug_Flag_P then
Error_Msg_Uint_1 := UI_From_Int (Scope.Last);
Error_Msg_SC ("decrement scope stack ptr, new value = ^!");
end if;
end Pop_Scope_Stack;
procedure Push_Scope_Stack is
begin
Scope.Increment_Last;
Scope.Table (Scope.Last).Junk := False;
Scope.Table (Scope.Last).Node := Empty;
if Debug_Flag_P then
Error_Msg_Uint_1 := UI_From_Int (Scope.Last);
Error_Msg_SC ("increment scope stack ptr, new value = ^!");
end if;
end Push_Scope_Stack;
function Separate_Present return Boolean is
Scan_State : Saved_Scan_State;
begin
if Token = Tok_Separate then
return True;
elsif Token /= Tok_Identifier then
return False;
else
Save_Scan_State (Scan_State);
Scan;
if Token = Tok_Semicolon then
Restore_Scan_State (Scan_State);
return Bad_Spelling_Of (Tok_Separate);
else
Restore_Scan_State (Scan_State);
return False;
end if;
end if;
end Separate_Present;
procedure Signal_Bad_Attribute is
begin
Error_Msg_N ("unrecognized attribute&", Token_Node);
Get_Name_String (Token_Name);
declare
AN : constant String := Name_Buffer (1 .. Name_Len);
begin
Error_Msg_Name_1 := First_Attribute_Name;
while Error_Msg_Name_1 <= Last_Attribute_Name loop
Get_Name_String (Error_Msg_Name_1);
if Is_Bad_Spelling_Of
(AN, Name_Buffer (1 .. Name_Len))
then
Error_Msg_N
("\possible misspelling of %", Token_Node);
exit;
end if;
Error_Msg_Name_1 := Error_Msg_Name_1 + 1;
end loop;
end;
end Signal_Bad_Attribute;
function Token_Is_At_Start_Of_Line return Boolean is
begin
return (Token_Ptr = First_Non_Blank_Location or else Token = Tok_EOF);
end Token_Is_At_Start_Of_Line;
end Util;