Skip to content

R
riscv-gcc-1
Commit 2383acbd by Arnaud Charlet
Options

[multiple changes] 

2010-06-17  Robert Dewar  <dewar@adacore.com>

	* par.adb: Minor comment fix
	* sem_aggr.adb, sem_ch3.adb: Minor reformatting

2010-06-17  Doug Rupp  <rupp@adacore.com>

	* s-auxdec-vms_64.ads: Revert Integer to Long_Integer change, instead
	change Address to Short_Address in functions where both must be the
	same size for intrinsics to work.

2010-06-17  Thomas Quinot  <quinot@adacore.com>

	* sem_ch4.adb (Analyze_Selected_Component): A selected component may
	not denote a (private) component of a protected object.

2010-06-17  Bob Duff  <duff@adacore.com>

	* par-labl.adb (Try_Loop): Test whether the label and the goto are in
	the same list.

2010-06-17  Joel Brobecker  <brobecker@adacore.com brobecker>

	* gnat_ugn.texi: Update the documentation about GDB re: exception
	catchpoints.

From-SVN: r160919
parent 2f203433
Showing with 134 additions and 69 deletions
gcc/ada/ChangeLog
2010-06-17 Robert Dewar <dewar@adacore.com>
* par.adb: Minor comment fix
* sem_aggr.adb, sem_ch3.adb: Minor reformatting
2010-06-17 Doug Rupp <rupp@adacore.com>
* s-auxdec-vms_64.ads: Revert Integer to Long_Integer change, instead
change Address to Short_Address in functions where both must be the
same size for intrinsics to work.
2010-06-17 Thomas Quinot <quinot@adacore.com>
* sem_ch4.adb (Analyze_Selected_Component): A selected component may
not denote a (private) component of a protected object.
2010-06-17 Bob Duff <duff@adacore.com>
* par-labl.adb (Try_Loop): Test whether the label and the goto are in
the same list.
2010-06-17 Joel Brobecker <brobecker@adacore.com brobecker>
* gnat_ugn.texi: Update the documentation about GDB re: exception
catchpoints.
2010-06-17 Arnaud Charlet <charlet@adacore.com>
* gnatvsn.ads: Bump to 4.6 version.
......
gcc/ada/gnat_ugn.texi
......@@ -22520,11 +22520,10 @@ and execution encounters the breakpoint, then the program
stops and @code{GDB} signals that the breakpoint was encountered by
printing the line of code before which the program is halted.
@item breakpoint exception @var{name}
A special form of the breakpoint command which breakpoints whenever
exception @var{name} is raised.
If @var{name} is omitted,
then a breakpoint will occur when any exception is raised.
@item catch exception @var{name}
This command causes the program execution to stop whenever exception
@var{name} is raised. If @var{name} is omitted, then the execution is
suspended when any exception is raised.
@item print @var{expression}
This will print the value of the given expression. Most simple
......@@ -22686,25 +22685,25 @@ The value returned is always that from the first return statement
that was stepped through.
@node Ada Exceptions
@section Breaking on Ada Exceptions
@section Stopping when Ada Exceptions are Raised
@cindex Exceptions
@noindent
You can set breakpoints that trip when your program raises
selected exceptions.
You can set catchpoints that stop the program execution when your program
raises selected exceptions.
@table @code
@item break exception
Set a breakpoint that trips whenever (any task in the) program raises
any exception.
@item catch exception
Set a catchpoint that stops execution whenever (any task in the) program
raises any exception.
@item break exception @var{name}
Set a breakpoint that trips whenever (any task in the) program raises
the exception @var{name}.
@item catch exception @var{name}
Set a catchpoint that stops execution whenever (any task in the) program
raises the exception @var{name}.
@item break exception unhandled
Set a breakpoint that trips whenever (any task in the) program raises an
exception for which there is no handler.
@item catch exception unhandled
Set a catchpoint that stops executino whenever (any task in the) program
raises an exception for which there is no handler.
@item info exceptions
@itemx info exceptions @var{regexp}
gcc/ada/par-labl.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2009, 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- --
......@@ -375,7 +375,15 @@ procedure Labl is
and then Matches (Node (N), Node (S1))
then
if not Found then
if Parent (Node (N)) = Parent (Node (S1)) then
-- If the label and the goto are both in the same statement
-- list, then we've found a loop. Note that labels and goto
-- statements are always part of some list, so
-- List_Containing always makes sense.
if
List_Containing (Node (N)) = List_Containing (Node (S1))
then
Source := S1;
Found := True;
......
gcc/ada/par.adb
......@@ -1182,12 +1182,12 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
--------------
procedure Labl;
-- This procedure creates implicit label declarations for all label that
-- are declared in the current unit. Note that this could conceptually
-- be done at the point where the labels are declared, but it is tricky
-- to do it then, since the tree is not hooked up at the point where the
-- label is declared (e.g. a sequence of statements is not yet attached
-- to its containing scope at the point a label in the sequence is found)
-- This procedure creates implicit label declarations for all labels that
-- are declared in the current unit. Note that this could conceptually be
-- done at the point where the labels are declared, but it is tricky to do
-- it then, since the tree is not hooked up at the point where the label is
-- declared (e.g. a sequence of statements is not yet attached to its
-- containing scope at the point a label in the sequence is found).
--------------
-- Par.Load --
......
gcc/ada/s-auxdec-vms_64.ads
......@@ -107,10 +107,10 @@ package System.Aux_DEC is
Address_Size : constant := Standard'Address_Size;
Short_Address_Size : constant := 32;
function "+" (Left : Address; Right : Long_Integer) return Address;
function "+" (Left : Long_Integer; Right : Address) return Address;
function "-" (Left : Address; Right : Address) return Long_Integer;
function "-" (Left : Address; Right : Long_Integer) return Address;
function "+" (Left : Short_Address; Right : Integer) return Short_Address;
function "+" (Left : Integer; Right : Short_Address) return Short_Address;
function "-" (Left : Short_Address; Right : Short_Address) return Integer;
function "-" (Left : Short_Address; Right : Integer) return Short_Address;
pragma Import (Intrinsic, "+");
pragma Import (Intrinsic, "-");
......@@ -230,16 +230,16 @@ package System.Aux_DEC is
type Unsigned_Quadword_Array is
array (Integer range <>) of Unsigned_Quadword;
function To_Address (X : Integer) return Address;
function To_Address (X : Integer) return Short_Address;
pragma Pure_Function (To_Address);
function To_Address_Long (X : Unsigned_Longword) return Address;
function To_Address_Long (X : Unsigned_Longword) return Short_Address;
pragma Pure_Function (To_Address_Long);
function To_Integer (X : Address) return Integer;
function To_Integer (X : Short_Address) return Integer;
function To_Unsigned_Longword (X : Address) return Unsigned_Longword;
function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword;
function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword;
function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword;
-- Conventional names for static subtypes of type UNSIGNED_LONGWORD
......@@ -657,31 +657,31 @@ private
-- want warnings when we compile on such systems.
function To_Address_A is new
Ada.Unchecked_Conversion (Integer, Address);
Ada.Unchecked_Conversion (Integer, Short_Address);
pragma Pure_Function (To_Address_A);
function To_Address (X : Integer) return Address
function To_Address (X : Integer) return Short_Address
renames To_Address_A;
pragma Pure_Function (To_Address);
function To_Address_Long_A is new
Ada.Unchecked_Conversion (Unsigned_Longword, Address);
Ada.Unchecked_Conversion (Unsigned_Longword, Short_Address);
pragma Pure_Function (To_Address_Long_A);
function To_Address_Long (X : Unsigned_Longword) return Address
function To_Address_Long (X : Unsigned_Longword) return Short_Address
renames To_Address_Long_A;
pragma Pure_Function (To_Address_Long);
function To_Integer_A is new
Ada.Unchecked_Conversion (Address, Integer);
Ada.Unchecked_Conversion (Short_Address, Integer);
function To_Integer (X : Address) return Integer
function To_Integer (X : Short_Address) return Integer
renames To_Integer_A;
function To_Unsigned_Longword_A is new
Ada.Unchecked_Conversion (Address, Unsigned_Longword);
Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword);
function To_Unsigned_Longword (X : Address) return Unsigned_Longword
function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword
renames To_Unsigned_Longword_A;
function To_Unsigned_Longword_A is new
......
gcc/ada/sem_aggr.adb
......@@ -2489,8 +2489,8 @@ package body Sem_Aggr is
-- This routine checks whether this is indeed the case and if so returns
-- False, signaling that no value for Discr should appear in N's
-- aggregate part. Also, in this case, the routine appends to
-- New_Assoc_List the discriminant value specified in the ancestor
-- part.
-- New_Assoc_List the discriminant value specified in the ancestor part.
--
-- If the aggregate is in a context with expansion delayed, it will be
-- reanalyzed, The inherited discriminant values must not be reinserted
-- in the component list to prevent spurious errors, but it must be
......@@ -2507,6 +2507,7 @@ package body Sem_Aggr is
-- a list of N_Component_Association nodes.
-- What is this referring to??? There is no "following function" in
-- sight???
--
-- If no component association has a choice for the searched component,
-- the value provided by the others choice is returned, if there is one,
-- and Consider_Others_Choice is set to true. Otherwise Empty is
......@@ -2585,6 +2586,7 @@ package body Sem_Aggr is
if Inherited_Discriminant (Comp_Assoc) then
return True;
end if;
Next (Comp_Assoc);
end loop;
end if;
......
gcc/ada/sem_ch3.adb
......@@ -17491,7 +17491,7 @@ package body Sem_Ch3 is
Make_Class_Wide_Type (Typ);
Error_Msg_N
("incomplete view of tagged type should be declared tagged?",
Parent (Current_Entity (Typ)));
Parent (Current_Entity (Typ)));
end if;
return;
......@@ -17499,13 +17499,12 @@ package body Sem_Ch3 is
Inc_T := Make_Defining_Identifier (Loc, Chars (Typ));
Decl := Make_Incomplete_Type_Declaration (Loc, Inc_T);
-- Type has already been inserted into the current scope.
-- Remove it, and add incomplete declaration for type, so
-- that subsequent anonymous access types can use it.
-- The entity is unchained from the homonym list and from
-- immediate visibility. After analysis, the entity in the
-- incomplete declaration becomes immediately visible in the
-- record declaration that follows.
-- Type has already been inserted into the current scope. Remove
-- it, and add incomplete declaration for type, so that subsequent
-- anonymous access types can use it. The entity is unchained from
-- the homonym list and from immediate visibility. After analysis,
-- the entity in the incomplete declaration becomes immediately
-- visible in the record declaration that follows.
H := Current_Entity (Typ);
......@@ -17526,8 +17525,9 @@ package body Sem_Ch3 is
Set_Full_View (Inc_T, Typ);
if Is_Tagged then
-- Create a common class-wide type for both views, and set
-- the Etype of the class-wide type to the full view.
-- Create a common class-wide type for both views, and set the
-- Etype of the class-wide type to the full view.
Make_Class_Wide_Type (Inc_T);
Set_Class_Wide_Type (Typ, Class_Wide_Type (Inc_T));
......
gcc/ada/sem_ch4.adb
......@@ -3105,8 +3105,8 @@ package body Sem_Ch4 is
-- Analyze_Selected_Component --
--------------------------------
-- Prefix is a record type or a task or protected type. In the
-- later case, the selector must denote a visible entry.
-- Prefix is a record type or a task or protected type. In the latter case,
-- the selector must denote a visible entry.
procedure Analyze_Selected_Component (N : Node_Id) is
Name : constant Node_Id := Prefix (N);
......@@ -3124,6 +3124,9 @@ package body Sem_Ch4 is
-- a class-wide type, we use its root type, whose components are
-- present in the class-wide type.
Is_Single_Concurrent_Object : Boolean;
-- Set True if the prefix is a single task or a single protected object
function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean;
-- It is known that the parent of N denotes a subprogram call. Comp
-- is an overloadable component of the concurrent type of the prefix.
......@@ -3294,6 +3297,15 @@ package body Sem_Ch4 is
Type_To_Use := Root_Type (Prefix_Type);
end if;
-- If the prefix is a single concurrent object, use its name in error
-- messages, rather than that of its anonymous type.
Is_Single_Concurrent_Object :=
Is_Concurrent_Type (Prefix_Type)
and then Is_Internal_Name (Chars (Prefix_Type))
and then not Is_Derived_Type (Prefix_Type)
and then Is_Entity_Name (Name);
Comp := First_Entity (Type_To_Use);
-- If the selector has an original discriminant, the node appears in
......@@ -3532,9 +3544,8 @@ package body Sem_Ch4 is
return;
else
Error_Msg_NE
("invisible selector for }",
N, First_Subtype (Prefix_Type));
Error_Msg_Node_2 := First_Subtype (Prefix_Type);
Error_Msg_NE ("invisible selector& for }", N, Sel);
Set_Entity (Sel, Any_Id);
Set_Etype (N, Any_Type);
end if;
......@@ -3579,8 +3590,13 @@ package body Sem_Ch4 is
Has_Candidate := True;
end if;
-- Note: a selected component may not denote a component of a
-- protected type (4.1.3(7)).
elsif Ekind_In (Comp, E_Discriminant, E_Entry_Family)
or else (In_Scope and then Is_Entity_Name (Name))
or else (In_Scope
and then not Is_Protected_Type (Prefix_Type)
and then Is_Entity_Name (Name))
then
Set_Entity_With_Style_Check (Sel, Comp);
Generate_Reference (Comp, Sel);
......@@ -3644,6 +3660,28 @@ package body Sem_Ch4 is
end if;
end if;
if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then
-- Case of a prefix of a protected type: selector might denote
-- an invisible private component.
Comp := First_Private_Entity (Base_Type (Prefix_Type));
while Present (Comp) and then Chars (Comp) /= Chars (Sel) loop
Next_Entity (Comp);
end loop;
if Present (Comp) then
if Is_Single_Concurrent_Object then
Error_Msg_Node_2 := Entity (Name);
Error_Msg_NE ("invisible selector& for &", N, Sel);
else
Error_Msg_Node_2 := First_Subtype (Prefix_Type);
Error_Msg_NE ("invisible selector& for }", N, Sel);
end if;
return;
end if;
end if;
Set_Is_Overloaded (N, Is_Overloaded (Sel));
else
......@@ -3656,15 +3694,7 @@ package body Sem_Ch4 is
if Etype (N) = Any_Type then
-- If the prefix is a single concurrent object, use its name in the
-- error message, rather than that of its anonymous type.
if Is_Concurrent_Type (Prefix_Type)
and then Is_Internal_Name (Chars (Prefix_Type))
and then not Is_Derived_Type (Prefix_Type)
and then Is_Entity_Name (Name)
then
if Is_Single_Concurrent_Object then
Error_Msg_Node_2 := Entity (Name);
Error_Msg_NE ("no selector& for&", N, Sel);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment