procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

3vtrasym.adb: Demangle Ada symbols returned by TBK$SYMBOLIZE.

Browse source 
* 3vtrasym.adb:
	Demangle Ada symbols returned by TBK$SYMBOLIZE. Correctly align line
	numbers when symbol name is too long.

	* g-signal.ads, g-signal.adb: New files

	* impunit.adb: (Non_Imp_File_Names): Added "g-signal"

	* Makefile.rtl: Introduce GNAT.Signals

	* freeze.adb: Minor reformatting

	* lib-writ.adb (Write_ALI): Never write ali file if -gnats is specified

	* par.adb, par-ch12.adb, par-ch13.adb, par-ch2.adb, par-ch3.adb,
	par-ch5.adb, par-ch6.adb, par-ch9.adb, par-util.adb:
	New handling of Id_Check parameter to improve recognition of keywords
	used as identifiers.
	Update copyright notice to include 2003

From-SVN: r73083
This commit is contained in:
Arnaud Charlet 2003-10-30 12:50:12 +01:00
parent 577d63287a
commit bde58e3208
17 changed files with 460 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

105
gcc/ada/3vtrasym.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2003 Ada Core Technologies, Inc. --
-- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@ -96,12 +97,83 @@ package body GNAT.Traceback.Symbolic is
Value, Value),
User_Act_Proc);
function Demangle_Ada (Mangled : String) return String;
-- Demangles an Ada symbol. Removes leading "_ada_" and trailing
-- __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.'
------------------
-- Demangle_Ada --
------------------
function Demangle_Ada (Mangled : String) return String is
Demangled : String (1 .. Mangled'Length);
Pos : Integer := Mangled'First;
Last : Integer := Mangled'Last;
DPos : Integer := 1;
begin
if Pos > Last then
return "";
end if;
-- Skip leading _ada_
if Mangled'Length > 4 and then Mangled (Pos .. Pos + 4) = "_ada_" then
Pos := Pos + 5;
end if;
-- Skip trailing __{DIGIT}+ or ${DIGIT}+
if Mangled (Last) in '0' .. '9' then
for J in reverse Pos + 2 .. Last - 1 loop
case Mangled (J) is
when '0' .. '9' =>
null;
when '$' =>
Last := J - 1;
exit;
when '_' =>
if Mangled (J - 1) = '_' then
Last := J - 2;
end if;
exit;
when others =>
exit;
end case;
end loop;
end if;
-- Now just copy Mangled to Demangled, converting "__" to '.' on the fly
while Pos <= Last loop
if Mangled (Pos) = '_' and then Mangled (Pos + 1) = '_'
and then Pos /= Mangled'First then
Demangled (DPos) := '.';
Pos := Pos + 2;
else
Demangled (DPos) := Mangled (Pos);
Pos := Pos + 1;
end if;
DPos := DPos + 1;
end loop;
return Demangled (1 .. DPos - 1);
end Demangle_Ada;
------------------------
-- Symbolic_Traceback --
------------------------
function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
Status : Cond_Value_Type;
Status : Cond_Value_Type;
Image_Name : ASCIC;
Image_Name_Addr : Address;
Module_Name : ASCIC;
@ -152,6 +224,11 @@ package body GNAT.Traceback.Symbolic is
declare
First : Integer := Len + 1;
Last : Integer := First + 80 - 1;
Pos : Integer;
Routine_Name_D : String := Demangle_Ada
(To_Ada
(Routine_Name.Data (1 .. size_t (Routine_Name.Count)),
False));
begin
Res (First .. Last) := (others => ' ');
@ -168,13 +245,23 @@ package body GNAT.Traceback.Symbolic is
False);
Res (First + 30 ..
First + 30 + Integer (Routine_Name.Count) - 1) :=
To_Ada
(Routine_Name.Data (1 .. size_t (Routine_Name.Count)),
False);
First + 30 + Routine_Name_D'Length - 1) :=
Routine_Name_D;
Res (First + 50 ..
First + 50 + Integer'Image (Line_Number)'Length - 1) :=
-- If routine name doesn't fit 20 characters, output
-- the line number on next line at 50th position
if Routine_Name_D'Length > 20 then
Pos := First + 30 + Routine_Name_D'Length;
Res (Pos) := ASCII.LF;
Last := Pos + 80;
Res (Pos + 1 .. Last) := (others => ' ');
Pos := Pos + 51;
else
Pos := First + 50;
end if;
Res (Pos .. Pos + Integer'Image (Line_Number)'Length - 1) :=
Integer'Image (Line_Number);
Res (Last) := ASCII.LF;

31
gcc/ada/ChangeLog
View file

@ -1,3 +1,29 @@
2003-10-30 Vasiliy Fofanov <fofanov@act-europe.fr>
* 3vtrasym.adb:
Demangle Ada symbols returned by TBK$SYMBOLIZE. Correctly align line
numbers when symbol name is too long.
2003-10-30 Ed Falis <falis@gnat.com>
* g-signal.ads, g-signal.adb: New files
* impunit.adb: (Non_Imp_File_Names): Added "g-signal"
* Makefile.rtl: Introduce GNAT.Signals
2003-10-30 Robert Dewar <dewar@gnat.com>
* freeze.adb: Minor reformatting
* lib-writ.adb (Write_ALI): Never write ali file if -gnats is specified
* par.adb, par-ch12.adb, par-ch13.adb, par-ch2.adb, par-ch3.adb,
par-ch5.adb, par-ch6.adb, par-ch9.adb, par-util.adb:
New handling of Id_Check parameter to improve recognition of keywords
used as identifiers.
Update copyright notice to include 2003
2003-10-29 Robert Dewar <dewar@gnat.com>
* 3vtrasym.adb, 5vtraent.ads, sprint.adb,
@ -8,10 +34,7 @@
2003-10-29 Vasiliy Fofanov <fofanov@act-europe.fr>
* 3vtrasym.adb:
* 5vtraent.adb:
* 5vtraent.ads:
* tb-alvms.c:
* 3vtrasym.adb, 5vtraent.adb, 5vtraent.ads, tb-alvms.c:
Support for TBK$SYMBOLIZE-based symbolic traceback.
2003-10-29 Jose Ruiz <ruiz@act-europe.fr>

1
gcc/ada/Makefile.rtl
View file

@ -38,6 +38,7 @@ GNATRTL_TASKING_OBJS= \
g-boubuf$(objext) \
g-boumai$(objext) \
g-semaph$(objext) \
g-signal$(objext) \
g-thread$(objext) \
s-asthan$(objext) \
s-inmaop$(objext) \

4
gcc/ada/freeze.adb
View file

@ -124,7 +124,7 @@ package body Freeze is
-- a subprogram type (i.e. an access to a subprogram).
function Is_Fully_Defined (T : Entity_Id) return Boolean;
-- true if T is not private and has no private components, or has a full
-- True if T is not private and has no private components, or has a full
-- view. Used to determine whether the designated type of an access type
-- should be frozen when the access type is frozen. This is done when an
-- allocator is frozen, or an expression that may involve attributes of
@ -4262,12 +4262,12 @@ package body Freeze is
elsif Is_Record_Type (T)
and not Is_Private_Type (T)
then
-- Verify that the record type has no components with
-- private types without completion.
declare
Comp : Entity_Id;
begin
Comp := First_Component (T);

71
gcc/ada/g-signal.adb Normal file
View file

@ -0,0 +1,71 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . S I G N A L S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with System.Interrupts;
package body GNAT.Signals is
package SI renames System.Interrupts;
------------------
-- Block_Signal --
------------------
procedure Block_Signal (Signal : Ada.Interrupts.Interrupt_ID) is
begin
SI.Block_Interrupt (SI.Interrupt_ID (Signal));
end Block_Signal;
----------------
-- Is_Blocked --
----------------
function Is_Blocked
(Signal : Ada.Interrupts.Interrupt_ID)
return Boolean
is
begin
return SI.Is_Blocked (SI.Interrupt_ID (Signal));
end Is_Blocked;
--------------------
-- Unblock_Signal --
--------------------
procedure Unblock_Signal (Signal : Ada.Interrupts.Interrupt_ID) is
begin
SI.Unblock_Interrupt (SI.Interrupt_ID (Signal));
end Unblock_Signal;
end GNAT.Signals;

55
gcc/ada/g-signal.ads Normal file
View file

@ -0,0 +1,55 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- G N A T . S I G N A L S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Interrupts;
-- This package provides operations for querying and setting the blocked
-- status of signals.
-- This package is supported only on targets where Ada.Interrupts.Interrupt_ID
-- corresponds to software signals on the target, and where System.Interrupts
-- provides the ability to block and unblock signals.
package GNAT.Signals is
procedure Block_Signal (Signal : Ada.Interrupts.Interrupt_ID);
-- Block "Signal" at the process level
procedure Unblock_Signal (Signal : Ada.Interrupts.Interrupt_ID);
-- Unblock "Signal" at the process level
function Is_Blocked (Signal : Ada.Interrupts.Interrupt_ID)
return Boolean;
-- "Signal" blocked at the process level?
end GNAT.Signals;

1
gcc/ada/impunit.adb
View file

@ -229,6 +229,7 @@ package body Impunit is
"g-regist", -- GNAT.Registry
"g-regpat", -- GNAT.Regpat
"g-semaph", -- GNAT.Semaphores
"g-signal", -- GNAT.Signals
"g-socket", -- GNAT.Sockets
"g-souinf", -- GNAT.Source_Info
"g-speche", -- GNAT.Spell_Checker

7
gcc/ada/lib-writ.adb
View file

@ -680,6 +680,13 @@ package body Lib.Writ is
-- Start of processing for Writ_ALI
begin
-- We never write an ALI file if the original operating mode was
-- syntax-only (-gnats switch used in compiler invocation line)
if Original_Operating_Mode = Check_Syntax then
return;
end if;
-- Build sorted source dependency table. We do this right away,
-- because it is referenced by Up_To_Date_ALI_File_Exists.

8
gcc/ada/par-ch12.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -367,12 +367,12 @@ package body Ch12 is
-- bother to check for it being exceeded.
begin
Idents (1) := P_Defining_Identifier;
Idents (1) := P_Defining_Identifier (C_Comma_Colon);
Num_Idents := 1;
while Comma_Present loop
Num_Idents := Num_Idents + 1;
Idents (Num_Idents) := P_Defining_Identifier;
Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
T_Colon;
@ -873,7 +873,7 @@ package body Ch12 is
begin
Def_Node := New_Node (N_Formal_Package_Declaration, Prev_Token_Ptr);
Scan; -- past PACKAGE
Set_Defining_Identifier (Def_Node, P_Defining_Identifier);
Set_Defining_Identifier (Def_Node, P_Defining_Identifier (C_Is));
T_Is;
T_New;
Set_Name (Def_Node, P_Qualified_Simple_Name);

4
gcc/ada/par-ch13.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -92,7 +92,7 @@ package body Ch13 is
-- Note that the name in a representation clause is always a simple
-- name, even in the attribute case, see AI-300 which made this so!
Identifier_Node := P_Identifier;
Identifier_Node := P_Identifier (C_Use);
-- Check case of qualified name to give good error message

4
gcc/ada/par-ch2.adb
View file

@ -47,7 +47,7 @@ package body Ch2 is
-- Error recovery: can raise Error_Resync (cannot return Error)
function P_Identifier return Node_Id is
function P_Identifier (C : Id_Check := None) return Node_Id is
Ident_Node : Node_Id;
begin
@ -61,7 +61,7 @@ package body Ch2 is
-- If we have a reserved identifier, manufacture an identifier with
-- a corresponding name after posting an appropriate error message
elsif Is_Reserved_Identifier then
elsif Is_Reserved_Identifier (C) then
Scan_Reserved_Identifier (Force_Msg => False);
Ident_Node := Token_Node;
Scan; -- past the node

24
gcc/ada/par-ch3.adb
View file

@ -164,7 +164,7 @@ package body Ch3 is
-- Error recovery: can raise Error_Resync
function P_Defining_Identifier return Node_Id is
function P_Defining_Identifier (C : Id_Check := None) return Node_Id is
Ident_Node : Node_Id;
begin
@ -179,7 +179,7 @@ package body Ch3 is
-- If we have a reserved identifier, manufacture an identifier with
-- a corresponding name after posting an appropriate error message
elsif Is_Reserved_Identifier then
elsif Is_Reserved_Identifier (C) then
Scan_Reserved_Identifier (Force_Msg => True);
-- Otherwise we have junk that cannot be interpreted as an identifier
@ -262,7 +262,7 @@ package body Ch3 is
Type_Loc := Token_Ptr;
Type_Start_Col := Start_Column;
T_Type;
Ident_Node := P_Defining_Identifier;
Ident_Node := P_Defining_Identifier (C_Is);
Discr_Sloc := Token_Ptr;
if P_Unknown_Discriminant_Part_Opt then
@ -732,7 +732,7 @@ package body Ch3 is
begin
Decl_Node := New_Node (N_Subtype_Declaration, Token_Ptr);
Scan; -- past SUBTYPE
Set_Defining_Identifier (Decl_Node, P_Defining_Identifier);
Set_Defining_Identifier (Decl_Node, P_Defining_Identifier (C_Is));
TF_Is;
if Token = Tok_New then
@ -1090,7 +1090,7 @@ package body Ch3 is
begin
Ident_Sloc := Token_Ptr;
Save_Scan_State (Scan_State); -- at first identifier
Idents (1) := P_Defining_Identifier;
Idents (1) := P_Defining_Identifier (C_Comma_Colon);
-- If we have a colon after the identifier, then we can assume that
-- this is in fact a valid identifier declaration and can steam ahead.
@ -1104,7 +1104,7 @@ package body Ch3 is
while Comma_Present loop
Num_Idents := Num_Idents + 1;
Idents (Num_Idents) := P_Defining_Identifier;
Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
Save_Scan_State (Scan_State); -- at colon
@ -1685,7 +1685,7 @@ package body Ch3 is
if Token = Tok_Char_Literal then
return P_Defining_Character_Literal;
else
return P_Defining_Identifier;
return P_Defining_Identifier (C_Comma_Right_Paren);
end if;
end P_Enumeration_Literal_Specification;
@ -2278,12 +2278,12 @@ package body Ch3 is
Specification_Loop : loop
Ident_Sloc := Token_Ptr;
Idents (1) := P_Defining_Identifier;
Idents (1) := P_Defining_Identifier (C_Comma_Colon);
Num_Idents := 1;
while Comma_Present loop
Num_Idents := Num_Idents + 1;
Idents (Num_Idents) := P_Defining_Identifier;
Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
T_Colon;
@ -2518,7 +2518,7 @@ package body Ch3 is
Names_List := New_List;
loop
Append (P_Identifier, Names_List);
Append (P_Identifier (C_Vertical_Bar_Arrow), Names_List);
exit when Token /= Tok_Vertical_Bar;
Scan; -- past |
end loop;
@ -2747,12 +2747,12 @@ package body Ch3 is
end if;
Ident_Sloc := Token_Ptr;
Idents (1) := P_Defining_Identifier;
Idents (1) := P_Defining_Identifier (C_Comma_Colon);
Num_Idents := 1;
while Comma_Present loop
Num_Idents := Num_Idents + 1;
Idents (Num_Idents) := P_Defining_Identifier;
Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop;
T_Colon;

4
gcc/ada/par-ch5.adb
View file

@ -1004,7 +1004,7 @@ package body Ch5 is
begin
Label_Node := New_Node (N_Label, Token_Ptr);
Scan; -- past <<
Set_Identifier (Label_Node, P_Identifier);
Set_Identifier (Label_Node, P_Identifier (C_Greater_Greater));
T_Greater_Greater;
Append_Elmt (Label_Node, Label_List);
return Label_Node;
@ -1621,7 +1621,7 @@ package body Ch5 is
New_Node (N_Loop_Parameter_Specification, Token_Ptr);
Save_Scan_State (Scan_State);
ID_Node := P_Defining_Identifier;
ID_Node := P_Defining_Identifier (C_In);
Set_Defining_Identifier (Loop_Param_Specification_Node, ID_Node);
if Token = Tok_Left_Paren then

14
gcc/ada/par-ch6.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -593,6 +593,10 @@ package body Ch6 is
-- True, a real dot has been scanned and we are positioned past it,
-- if the result is False, the scan position is unchanged.
--------------
-- Real_Dot --
--------------
function Real_Dot return Boolean is
Scan_State : Saved_Scan_State;
@ -715,7 +719,7 @@ package body Ch6 is
Set_Identifier_Casing (Current_Source_File, Determine_Token_Casing);
end if;
Ident_Node := P_Identifier;
Ident_Node := P_Identifier (C_Dot);
Merge_Identifier (Ident_Node, Tok_Return);
-- Normal case (not child library unit name)
@ -746,7 +750,7 @@ package body Ch6 is
Name_Node := New_Node (N_Selected_Component, Token_Ptr);
Scan; -- past period
Set_Prefix (Name_Node, Prefix_Node);
Ident_Node := P_Identifier;
Ident_Node := P_Identifier (C_Dot);
Set_Selector_Name (Name_Node, Ident_Node);
Prefix_Node := Name_Node;
end loop;
@ -870,7 +874,7 @@ package body Ch6 is
Ignore (Tok_Left_Paren);
Ident_Sloc := Token_Ptr;
Idents (1) := P_Defining_Identifier;
Idents (1) := P_Defining_Identifier (C_Comma_Colon);
Num_Idents := 1;
Ident_Loop : loop
@ -924,7 +928,7 @@ package body Ch6 is
T_Comma;
Num_Idents := Num_Idents + 1;
Idents (Num_Idents) := P_Defining_Identifier;
Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon);
end loop Ident_Loop;
-- Fall through the loop on encountering a colon, or deciding

20
gcc/ada/par-ch9.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -90,7 +90,7 @@ package body Ch9 is
if Token = Tok_Body then
Scan; -- past BODY
Name_Node := P_Defining_Identifier;
Name_Node := P_Defining_Identifier (C_Is);
Scope.Table (Scope.Last).Labl := Name_Node;
if Token = Tok_Left_Paren then
@ -133,7 +133,7 @@ package body Ch9 is
else
Task_Node := New_Node (N_Single_Task_Declaration, Task_Sloc);
Name_Node := P_Defining_Identifier;
Name_Node := P_Defining_Identifier (C_Is);
Set_Defining_Identifier (Task_Node, Name_Node);
Scope.Table (Scope.Last).Labl := Name_Node;
@ -141,7 +141,6 @@ package body Ch9 is
Error_Msg_SC ("discriminant part not allowed for single task");
Discard_Junk_List (P_Known_Discriminant_Part_Opt);
end if;
end if;
-- Parse optional task definition. Note that P_Task_Definition scans
@ -344,7 +343,7 @@ package body Ch9 is
if Token = Tok_Body then
Scan; -- past BODY
Name_Node := P_Defining_Identifier;
Name_Node := P_Defining_Identifier (C_Is);
Scope.Table (Scope.Last).Labl := Name_Node;
if Token = Tok_Left_Paren then
@ -381,7 +380,7 @@ package body Ch9 is
Scan; -- past TYPE
Protected_Node :=
New_Node (N_Protected_Type_Declaration, Protected_Sloc);
Name_Node := P_Defining_Identifier;
Name_Node := P_Defining_Identifier (C_Is);
Set_Defining_Identifier (Protected_Node, Name_Node);
Scope.Table (Scope.Last).Labl := Name_Node;
Set_Discriminant_Specifications
@ -390,7 +389,7 @@ package body Ch9 is
else
Protected_Node :=
New_Node (N_Single_Protected_Declaration, Protected_Sloc);
Name_Node := P_Defining_Identifier;
Name_Node := P_Defining_Identifier (C_Is);
Set_Defining_Identifier (Protected_Node, Name_Node);
if Token = Tok_Left_Paren then
@ -631,7 +630,8 @@ package body Ch9 is
Decl_Node := New_Node (N_Entry_Declaration, Token_Ptr);
Scan; -- past ENTRY
Set_Defining_Identifier (Decl_Node, P_Defining_Identifier);
Set_Defining_Identifier
(Decl_Node, P_Defining_Identifier (C_Left_Paren_Semicolon));
-- If left paren, could be (Discrete_Subtype_Definition) or Formal_Part
@ -719,7 +719,7 @@ package body Ch9 is
Scan; -- past ACCEPT
Scope.Table (Scope.Last).Labl := Token_Node;
Set_Entry_Direct_Name (Accept_Node, P_Identifier);
Set_Entry_Direct_Name (Accept_Node, P_Identifier (C_Do));
-- Left paren could be (Entry_Index) or Formal_Part, determine which
@ -932,7 +932,7 @@ package body Ch9 is
begin
Iterator_Node := New_Node (N_Entry_Index_Specification, Token_Ptr);
T_For; -- past FOR
Set_Defining_Identifier (Iterator_Node, P_Defining_Identifier);
Set_Defining_Identifier (Iterator_Node, P_Defining_Identifier (C_In));
T_In;
Set_Discrete_Subtype_Definition
(Iterator_Node, P_Discrete_Subtype_Definition);

89
gcc/ada/par-util.adb
View file

@ -24,6 +24,7 @@
-- --
------------------------------------------------------------------------------
with Csets; use Csets;
with Uintp; use Uintp;
with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
@ -419,7 +420,7 @@ package body Util is
-- Is_Reserved_Identifier --
----------------------------
function Is_Reserved_Identifier return Boolean is
function Is_Reserved_Identifier (C : Id_Check := None) return Boolean is
begin
if not Is_Reserved_Keyword (Token) then
return False;
@ -438,20 +439,88 @@ package body Util is
-- keyword casing, then we return False, since it is pretty
-- clearly intended to be a keyword.
if Ident_Casing /= Unknown
and then Key_Casing /= Unknown
and then Ident_Casing /= Key_Casing
and then Determine_Token_Casing = Key_Casing
if Ident_Casing = Unknown
or else Key_Casing = Unknown
or else Ident_Casing = Key_Casing
or else Determine_Token_Casing /= Key_Casing
then
return False;
-- Otherwise assume that an identifier was intended
else
return True;
-- Here we have a keyword written clearly with keyword casing.
-- In default mode, we would not be willing to consider this as
-- a reserved identifier, but if C is set, we may still accept it
elsif C /= None then
declare
Scan_State : Saved_Scan_State;
OK_Next_Tok : Boolean;
begin
Save_Scan_State (Scan_State);
Scan;
if Token_Is_At_Start_Of_Line then
return False;
end if;
case C is
when None =>
raise Program_Error;
when C_Comma_Right_Paren =>
OK_Next_Tok :=
Token = Tok_Comma or else Token = Tok_Right_Paren;
when C_Comma_Colon =>
OK_Next_Tok :=
Token = Tok_Comma or else Token = Tok_Colon;
when C_Do =>
OK_Next_Tok :=
Token = Tok_Do;
when C_Dot =>
OK_Next_Tok :=
Token = Tok_Dot;
when C_Greater_Greater =>
OK_Next_Tok :=
Token = Tok_Greater_Greater;
when C_In =>
OK_Next_Tok :=
Token = Tok_In;
when C_Is =>
OK_Next_Tok :=
Token = Tok_Is;
when C_Left_Paren_Semicolon =>
OK_Next_Tok :=
Token = Tok_Left_Paren or else Token = Tok_Semicolon;
when C_Use =>
OK_Next_Tok :=
Token = Tok_Use;
when C_Vertical_Bar_Arrow =>
OK_Next_Tok :=
Token = Tok_Vertical_Bar or else Token = Tok_Arrow;
end case;
Restore_Scan_State (Scan_State);
if OK_Next_Tok then
return True;
end if;
end;
end if;
end;
end if;
-- If we fall through it is not a reserved identifier
return False;
end Is_Reserved_Identifier;
----------------------

85
gcc/ada/par.adb
View file

@ -26,7 +26,6 @@
with Atree; use Atree;
with Casing; use Casing;
with Csets; use Csets;
with Debug; use Debug;
with Elists; use Elists;
with Errout; use Errout;
@ -189,6 +188,73 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- that there is a missing body, but it seems more reasonable to let the
-- later semantic checking discover this.
----------------------------------------------------
-- Handling of Reserved Words Used as Identifiers --
----------------------------------------------------
-- Note: throughout the parser, the terms reserved word and keyword
-- are used interchangably to refer to the same set of reserved
-- keywords (including until, protected, etc).
-- If a reserved word is used in place of an identifier, the parser
-- where possible tries to recover gracefully. In particular, if the
-- keyword is clearly spelled using identifier casing, e.g. Until in
-- a source program using mixed case identifiers and lower case keywords,
-- then the keyword is treated as an identifier if it appears in a place
-- where an identifier is required.
-- The situation is more complex if the keyword is spelled with normal
-- keyword casing. In this case, the parser is more reluctant to
-- consider it to be intended as an identifier, unless it has some
-- further confirmation.
-- In the case of an identifier appearing in the identifier list of a
-- declaration, the appearence of a comma or colon right after the
-- keyword on the same line is taken as confirmation. For an enumeration
-- literal, a comma or right paren right after the identifier is also
-- treated as adequate confirmation.
-- The following type is used in calls to Is_Reserved_Identifier and
-- also to P_Defining_Identifier and P_Identifier. The default for all
-- these functins is that reserved words in reserved word case are not
-- considered to be reserved identifiers. The Id_Check value indicates
-- tokens, which if they appear immediately after the identifier, are
-- taken as confirming that the use of an identifier was expected
type Id_Check is
(None,
-- Default, no special token test
C_Comma_Right_Paren,
-- Consider as identifier if followed by comma or right paren
C_Comma_Colon,
-- Consider as identifier if followed by comma or colon
C_Do,
-- Consider as identifier if followed by DO
C_Dot,
-- Consider as identifier if followed by period
C_Greater_Greater,
-- Consider as identifier if followed by >>
C_In,
-- Consider as identifier if followed by IN
C_Is,
-- Consider as identifier if followed by IS
C_Left_Paren_Semicolon,
-- Consider as identifier if followed by left paren or semicolon
C_Use,
-- Consider as identifier if followed by USE
C_Vertical_Bar_Arrow);
-- Consider as identifier if followed by | or =>
--------------------------------------------
-- Handling IS Used in Place of Semicolon --
--------------------------------------------
@ -450,9 +516,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- List that is created.
package Ch2 is
function P_Identifier return Node_Id;
function P_Pragma return Node_Id;
function P_Identifier (C : Id_Check := None) return Node_Id;
-- Scans out an identifier. The parameter C determines the treatment
-- of reserved identifiers. See declaration of Id_Check for details.
function P_Pragmas_Opt return List_Id;
-- This function scans for a sequence of pragmas in other than a
-- declaration sequence or statement sequence context. All pragmas
@ -482,7 +551,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
function P_Basic_Declarative_Items return List_Id;
function P_Constraint_Opt return Node_Id;
function P_Declarative_Part return List_Id;
function P_Defining_Identifier return Node_Id;
function P_Discrete_Choice_List return List_Id;
function P_Discrete_Range return Node_Id;
function P_Discrete_Subtype_Definition return Node_Id;
@ -503,6 +571,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- case where the source has a single declaration with multiple
-- defining identifiers.
function P_Defining_Identifier (C : Id_Check := None) return Node_Id;
-- Scan out a defining identifier. The parameter C controls the
-- treatment of errors in case a reserved word is scanned. See the
-- declaration of this type for details.
function Init_Expr_Opt (P : Boolean := False) return Node_Id;
-- If an initialization expression is present (:= expression), then
-- it is scanned out and returned, otherwise Empty is returned if no
@ -908,10 +981,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- past it, otherwise the call has no effect at all. T may be any
-- reserved word token, or comma, left or right paren, or semicolon.
function Is_Reserved_Identifier return Boolean;
function Is_Reserved_Identifier (C : Id_Check := None) return Boolean;
-- Test if current token is a reserved identifier. This test is based
-- on the token being a keyword and being spelled in typical identifier
-- style (i.e. starting with an upper case letter).
-- style (i.e. starting with an upper case letter). The parameter C
-- determines the special treatment if a reserved word is encountered
-- that has the normal casing of a reserved word.
procedure Merge_Identifier (Prev : Node_Id; Nxt : Token_Type);
-- Called when the previous token is an identifier (whose Token_Node