From ec621b58c93dc8c0937740e823af1384dbeec8ec Mon Sep 17 00:00:00 2001 From: charlet Date: Thu, 30 Oct 2003 11:50:12 +0000 Subject: [PATCH] * 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 git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@73083 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/3vtrasym.adb | 105 ++++++++++++++++++++++++++++++++++++++++++++++----- gcc/ada/ChangeLog | 31 +++++++++++++-- gcc/ada/Makefile.rtl | 1 + gcc/ada/freeze.adb | 4 +- gcc/ada/g-signal.adb | 71 ++++++++++++++++++++++++++++++++++ gcc/ada/g-signal.ads | 55 +++++++++++++++++++++++++++ gcc/ada/impunit.adb | 1 + gcc/ada/lib-writ.adb | 7 ++++ gcc/ada/par-ch12.adb | 8 ++-- gcc/ada/par-ch13.adb | 4 +- gcc/ada/par-ch2.adb | 4 +- gcc/ada/par-ch3.adb | 24 ++++++------ gcc/ada/par-ch5.adb | 4 +- gcc/ada/par-ch6.adb | 14 ++++--- gcc/ada/par-ch9.adb | 20 +++++----- gcc/ada/par-util.adb | 87 +++++++++++++++++++++++++++++++++++++----- gcc/ada/par.adb | 85 ++++++++++++++++++++++++++++++++++++++--- 17 files changed, 459 insertions(+), 66 deletions(-) create mode 100644 gcc/ada/g-signal.adb create mode 100644 gcc/ada/g-signal.ads diff --git a/gcc/ada/3vtrasym.adb b/gcc/ada/3vtrasym.adb index d11e26b..159c03f 100644 --- a/gcc/ada/3vtrasym.adb +++ b/gcc/ada/3vtrasym.adb @@ -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; + + -- 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 (First + 50 .. - First + 50 + Integer'Image (Line_Number)'Length - 1) := + Res (Pos .. Pos + Integer'Image (Line_Number)'Length - 1) := Integer'Image (Line_Number); Res (Last) := ASCII.LF; diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c6de5e0..d34a2a4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2003-10-30 Vasiliy Fofanov + + * 3vtrasym.adb: + Demangle Ada symbols returned by TBK$SYMBOLIZE. Correctly align line + numbers when symbol name is too long. + +2003-10-30 Ed Falis + + * 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 + + * 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 * 3vtrasym.adb, 5vtraent.ads, sprint.adb, @@ -8,10 +34,7 @@ 2003-10-29 Vasiliy Fofanov - * 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 diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index f44db99..62da397 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -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) \ diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 0ac32c3..68dc177 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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); diff --git a/gcc/ada/g-signal.adb b/gcc/ada/g-signal.adb new file mode 100644 index 0000000..605b3e7 --- /dev/null +++ b/gcc/ada/g-signal.adb @@ -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; + diff --git a/gcc/ada/g-signal.ads b/gcc/ada/g-signal.ads new file mode 100644 index 0000000..6939fe2 --- /dev/null +++ b/gcc/ada/g-signal.ads @@ -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; diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index fcc174b..d2a8645 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -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 diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 35248a4..c359011 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -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. diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index 2b9adaf..2880fe4 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.adb @@ -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); diff --git a/gcc/ada/par-ch13.adb b/gcc/ada/par-ch13.adb index cfcc380..7a7e479 100644 --- a/gcc/ada/par-ch13.adb +++ b/gcc/ada/par-ch13.adb @@ -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 diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb index 7064c5d..dd58e1f 100644 --- a/gcc/ada/par-ch2.adb +++ b/gcc/ada/par-ch2.adb @@ -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 diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index df156b9..8236c58 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -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; diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index e8c6f3d..e45b0fa 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -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 diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index e5dc9ff..cc0e898 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -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 diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb index e68c972..6bfc409 100644 --- a/gcc/ada/par-ch9.adb +++ b/gcc/ada/par-ch9.adb @@ -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); diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index d7e2e15..d23269e 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -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; + return True; - -- Otherwise assume that an identifier was intended + -- 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 - else - return True; + 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; ---------------------- diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index b536533..56629ef 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -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 -- 2.7.4