aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/ada/ChangeLog35
-rw-r--r--gcc/ada/a-cbdlli.adb12
-rw-r--r--gcc/ada/a-cbdlli.ads11
-rw-r--r--gcc/ada/a-rbtgbo.adb6
-rw-r--r--gcc/ada/comperr.adb70
-rw-r--r--gcc/ada/comperr.ads5
-rw-r--r--gcc/ada/exp_ch4.adb14
-rw-r--r--gcc/ada/exp_ch5.adb2
-rw-r--r--gcc/ada/exp_ch7.ads29
-rw-r--r--gcc/ada/exp_intr.adb10
-rw-r--r--gcc/ada/exp_util.adb9
-rw-r--r--gcc/ada/gnat1drv.adb4
-rw-r--r--gcc/ada/init.c10
-rw-r--r--gcc/ada/put_scos.adb3
-rw-r--r--gcc/ada/s-rannum.adb3
-rw-r--r--gcc/ada/s-ransee.adb2
-rw-r--r--gcc/ada/s-ransee.ads4
-rw-r--r--gcc/ada/seh_init.c2
-rw-r--r--gcc/ada/sem_ch5.adb11
19 files changed, 171 insertions, 71 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 24abfae..3240bcd 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,40 @@
2011-08-31 Robert Dewar <dewar@adacore.com>
+ * exp_ch5.adb, exp_ch7.ads, sem_ch5.adb, put_scos.adb, s-rannum.adb,
+ a-rbtgbo.adb, exp_intr.adb, a-cbdlli.adb, a-cbdlli.ads: Minor
+ reformatting.
+
+2011-08-31 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_util.adb (Find_Protection_Type): Do not look for fields _object
+ if the corresponding type is malformed due to restriction violations.
+
+2011-08-31 Robert Dewar <dewar@adacore.com>
+
+ * s-ransee.ads, s-ransee.adb: Minor reformatting.
+
+2011-08-31 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Allocator): Correct faulty condition which
+ would cause the generation of Set_Finalize_Address if the target is a
+ VM and the designated type is not derived from [Limited_]Controlled.
+
+2011-08-31 Arnaud Charlet <charlet@adacore.com>
+
+ * comperr.adb, comperr.ads, gnat1drv.adb (Delete_SCIL_Files): New
+ subprogram.
+ (Compiler_Abort, Gnat1drv): Call Delete_SCIL_Files in codepeer mode in
+ case of a compilation error.
+
+2011-08-31 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * init.c (__gnat_error_handler): Standardize the stack overflow or
+ erroneous memory access message.
+ * seh_init.c (__gnat_SEH_error_handler): Standardize the stack overflow
+ or erroneous memory access message.
+
+2011-08-31 Robert Dewar <dewar@adacore.com>
+
* sem_ch4.adb: Minor reformatting.
* sem_ch6.adb: Minor code reorganization (use Ekind_In).
diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb
index cf24227..a8a7c5e 100644
--- a/gcc/ada/a-cbdlli.adb
+++ b/gcc/ada/a-cbdlli.adb
@@ -1046,6 +1046,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
Process (Cursor'(Container'Unrestricted_Access, Node));
Node := Container.Nodes (Node).Next;
end loop;
+
exception
when others =>
B := B - 1;
@@ -1055,8 +1056,9 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
B := B - 1;
end Iterate;
- function Iterate (Container : List)
- return List_Iterator_Interfaces.Reversible_Iterator'class
+ function Iterate
+ (Container : List)
+ return List_Iterator_Interfaces.Reversible_Iterator'class
is
begin
if Container.Length = 0 then
@@ -1066,8 +1068,10 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
end if;
end Iterate;
- function Iterate (Container : List; Start : Cursor)
- return List_Iterator_Interfaces.Reversible_Iterator'class
+ function Iterate
+ (Container : List;
+ Start : Cursor)
+ return List_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator := (Container'Unrestricted_Access, Start.Node);
begin
diff --git a/gcc/ada/a-cbdlli.ads b/gcc/ada/a-cbdlli.ads
index 32e992f..0443c30 100644
--- a/gcc/ada/a-cbdlli.ads
+++ b/gcc/ada/a-cbdlli.ads
@@ -44,8 +44,7 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
pragma Pure;
pragma Remote_Types;
- type List (Capacity : Count_Type) is tagged private
- with
+ type List (Capacity : Count_Type) is tagged private with
Constant_Indexing => Constant_Reference,
Variable_Indexing => Reference,
Default_Iterator => Iterate,
@@ -59,6 +58,7 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
Empty_List : constant List;
No_Element : constant Cursor;
+
function Has_Element (Position : Cursor) return Boolean;
package List_Iterator_Interfaces is new
@@ -140,10 +140,13 @@ package Ada.Containers.Bounded_Doubly_Linked_Lists is
procedure Reverse_Elements (Container : in out List);
- function Iterate (Container : List)
+ function Iterate
+ (Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'class;
- function Iterate (Container : List; Start : Cursor)
+ function Iterate
+ (Container : List;
+ Start : Cursor)
return List_Iterator_Interfaces.Reversible_Iterator'class;
procedure Swap
diff --git a/gcc/ada/a-rbtgbo.adb b/gcc/ada/a-rbtgbo.adb
index afa98f8..f420438 100644
--- a/gcc/ada/a-rbtgbo.adb
+++ b/gcc/ada/a-rbtgbo.adb
@@ -63,8 +63,11 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
Tree.Last := 0;
Tree.Root := 0;
Tree.Length := 0;
+
+ -- Why are the following commented out with no explanation ???
-- Tree.Busy
-- Tree.Lock
+
Tree.Free := -1;
end Clear_Tree;
@@ -76,7 +79,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
(Tree : in out Tree_Type'Class;
Node : Count_Type)
is
-
-- CLR p. 274
X : Count_Type;
@@ -143,7 +145,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
end if;
if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black)
- and then
+ and then
(Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black)
then
Set_Color (N (W), Red);
diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb
index da6c8a6..676995f 100644
--- a/gcc/ada/comperr.adb
+++ b/gcc/ada/comperr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -27,20 +27,23 @@
-- error is detected. Calls to these routines cause termination of the
-- current compilation with appropriate error output.
-with Atree; use Atree;
-with Debug; use Debug;
-with Errout; use Errout;
-with Gnatvsn; use Gnatvsn;
-with Namet; use Namet;
-with Opt; use Opt;
-with Osint; use Osint;
-with Output; use Output;
-with Sinput; use Sinput;
-with Sprint; use Sprint;
-with Sdefault; use Sdefault;
-with Targparm; use Targparm;
-with Treepr; use Treepr;
-with Types; use Types;
+with Atree; use Atree;
+with Debug; use Debug;
+with Errout; use Errout;
+with Gnatvsn; use Gnatvsn;
+with Lib; use Lib;
+with Namet; use Namet;
+with Opt; use Opt;
+with Osint; use Osint;
+with Output; use Output;
+with Sinfo; use Sinfo;
+with Sinput; use Sinput;
+with Sprint; use Sprint;
+with Sdefault; use Sdefault;
+with System.OS_Lib; use System.OS_Lib;
+with Targparm; use Targparm;
+with Treepr; use Treepr;
+with Types; use Types;
with Ada.Exceptions; use Ada.Exceptions;
@@ -144,6 +147,10 @@ package body Comperr is
end if;
end if;
+ if CodePeer_Mode then
+ Delete_SCIL_Files;
+ end if;
+
-- If any errors have already occurred, then we guess that the abort
-- may well be caused by previous errors, and we don't make too much
-- fuss about it, since we want to let programmer fix the errors first.
@@ -422,9 +429,40 @@ package body Comperr is
Source_Dump;
raise Unrecoverable_Error;
end if;
-
end Compiler_Abort;
+ -----------------------
+ -- Delete_SCIL_Files --
+ -----------------------
+
+ procedure Delete_SCIL_Files is
+ Main : Node_Id;
+ Success : Boolean;
+ pragma Unreferenced (Success);
+ begin
+ -- If parsing was not successful, no Main_Unit is available, so return
+ -- immediately.
+
+ if Main_Source_File = No_Source_File then
+ return;
+ end if;
+
+ -- Retrieve unit name, and remove old versions of SCIL/<unit>.scil and
+ -- SCIL/<unit>__body.scil
+
+ Main := Unit (Cunit (Main_Unit));
+
+ if Nkind (Main) = N_Subprogram_Body then
+ Get_Name_String (Chars (Defining_Unit_Name (Specification (Main))));
+ else
+ Get_Name_String (Chars (Defining_Unit_Name (Main)));
+ end if;
+
+ Delete_File ("SCIL/" & Name_Buffer (1 .. Name_Len) & ".scil", Success);
+ Delete_File
+ ("SCIL/" & Name_Buffer (1 .. Name_Len) & "__body.scil", Success);
+ end Delete_SCIL_Files;
+
-----------------
-- Repeat_Char --
-----------------
diff --git a/gcc/ada/comperr.ads b/gcc/ada/comperr.ads
index 04a6062..a45faf1 100644
--- a/gcc/ada/comperr.ads
+++ b/gcc/ada/comperr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
@@ -50,6 +50,9 @@ package Comperr is
-- end exception (with possible message stored in TSD.Current_Excep,
-- and negative (an unused value) for a GCC abort.
+ procedure Delete_SCIL_Files;
+ -- Delete SCIL files associated with the main unit
+
------------------------------
-- Use of gnat_bug.box File --
------------------------------
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 1a1159b..ab96696 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -3949,13 +3949,13 @@ package body Exp_Ch4 is
-- Types derived from [Limited_]Controlled are the only
-- ones considered since they have fields Prev and Next.
- if VM_Target /= No_VM
- and then Is_Controlled (T)
- then
- Insert_Action (N,
- Make_Attach_Call
- (Obj_Ref => New_Copy_Tree (Init_Arg1),
- Ptr_Typ => PtrT));
+ if VM_Target /= No_VM then
+ if Is_Controlled (T) then
+ Insert_Action (N,
+ Make_Attach_Call
+ (Obj_Ref => New_Copy_Tree (Init_Arg1),
+ Ptr_Typ => PtrT));
+ end if;
-- Default case, generate:
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 5203885..0f18455 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -3249,7 +3249,7 @@ package body Exp_Ch5 is
Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc),
Name => Relocate_Node (Name (I_Spec)));
- -- Create declaration for cursor.
+ -- Create declaration for cursor
Decl2 :=
Make_Object_Declaration (Loc,
diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads
index 8a0be81..8ea7191 100644
--- a/gcc/ada/exp_ch7.ads
+++ b/gcc/ada/exp_ch7.ads
@@ -41,33 +41,34 @@ package Exp_Ch7 is
-- that take care of finalization management at run-time.
-- Support of exceptions from user finalization procedures
- --
+
-- There is a specific mechanism to handle these exceptions, continue
- -- finalization and then raise PE.
- -- This mechanism is used by this package but also by exp_intr for
- -- Ada.Unchecked_Deallocation.
+ -- finalization and then raise PE. This mechanism is used by this package
+ -- but also by exp_intr for Ada.Unchecked_Deallocation.
+
-- There are 3 subprograms to use this mechanism, and the type
-- Finalization_Exception_Data carries internal data between these
-- subprograms:
--
- -- 1. Build_Object_Declaration: create the variables for the next two
- -- subprograms.
- -- 2. Build_Exception_Handler: create the exception handler for a call to
- -- a user finalization procedure.
- -- 3. Build_Raise_Stmt: create the code to potentially raise a PE exception
- -- if am exception was raise in a user finalization procedure.
+ -- 1. Build_Object_Declaration: create the variables for the next two
+ -- subprograms.
+ -- 2. Build_Exception_Handler: create the exception handler for a call
+ -- to a user finalization procedure.
+ -- 3. Build_Raise_Stmt: create code to potentially raise a PE exception
+ -- if an exception was raise in a user finalization procedure.
+
type Finalization_Exception_Data is record
- Loc : Source_Ptr;
+ Loc : Source_Ptr;
-- Sloc for the added nodes
- Abort_Id : Entity_Id;
+ Abort_Id : Entity_Id;
-- Boolean variable set to true if the finalization was triggered by
-- an abort.
- E_Id : Entity_Id;
+ E_Id : Entity_Id;
-- Variable containing the exception occurrence raised by user code
- Raised_Id : Entity_Id;
+ Raised_Id : Entity_Id;
-- Boolean variable set to true if an exception was raised in user code
end record;
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index 1632582..2d47846 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -964,19 +964,15 @@ package body Exp_Intr is
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Final_Call (
- Obj_Ref => Deref,
- Typ => Desig_T)),
+ Statements => New_List (
+ Make_Final_Call (Obj_Ref => Deref, Typ => Desig_T)),
Exception_Handlers => New_List (
Build_Exception_Handler (Finalizer_Data)))));
-- For .NET/JVM, detach the object from the containing finalization
-- collection before finalizing it.
- if VM_Target /= No_VM
- and then Is_Controlled (Desig_T)
- then
+ if VM_Target /= No_VM and then Is_Controlled (Desig_T) then
Prepend_To (Final_Code,
Make_Detach_Call (New_Copy_Tree (Arg)));
end if;
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index d712570..bc323a8 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -2313,6 +2313,15 @@ package body Exp_Util is
Typ := Corresponding_Record_Type (Typ);
end if;
+ -- Since restriction violations are not considered serious errors, the
+ -- expander remains active, but may leave the corresponding record type
+ -- malformed. In such cases, component _object is not available so do
+ -- not look for it.
+
+ if not Analyzed (Typ) then
+ return Empty;
+ end if;
+
Comp := First_Component (Typ);
while Present (Comp) loop
if Chars (Comp) = Name_uObject then
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index 3c2b5f4..98998ff 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -842,6 +842,10 @@ begin
Tree_Gen;
end if;
+ if CodePeer_Mode then
+ Comperr.Delete_SCIL_Files;
+ end if;
+
Errout.Finalize (Last_Call => True);
Exit_Program (E_Errors);
end if;
diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index 9601dc6..0e6fb11 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -358,7 +358,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext)
((volatile char *)
((long) si->si_addr & - getpagesize ()))[getpagesize ()];
exception = &storage_error;
- msg = "stack overflow (or erroneous memory access)";
+ msg = "stack overflow or erroneous memory access";
}
break;
@@ -644,7 +644,7 @@ __gnat_error_handler (int sig, siginfo_t *si ATTRIBUTE_UNUSED, void *ucontext)
that this is quite acceptable, since a "real" SIGSEGV can only
occur as the result of an erroneous program. */
exception = &storage_error;
- msg = "stack overflow (or erroneous memory access)";
+ msg = "stack overflow or erroneous memory access";
break;
case SIGBUS:
@@ -824,7 +824,7 @@ __gnat_error_handler (int sig, siginfo_t *reason, void *uc ATTRIBUTE_UNUSED)
the stack into a guard page, not an attempt to
write to .text or something. */
exception = &storage_error;
- msg = "SIGSEGV: (stack overflow or erroneous memory access)";
+ msg = "SIGSEGV: stack overflow or erroneous memory access";
}
else
{
@@ -1022,7 +1022,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext ATTRIBUTE_UNUSED)
((volatile char *)
((long) si->si_addr & - getpagesize ()))[getpagesize ()];
exception = &storage_error;
- msg = "stack overflow (or erroneous memory access)";
+ msg = "stack overflow or erroneous memory access";
}
break;
@@ -1421,7 +1421,7 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs)
else
{
exception = &storage_error;
- msg = "stack overflow (or erroneous memory access)";
+ msg = "stack overflow or erroneous memory access";
}
__gnat_adjust_context_for_raise (SS$_ACCVIO, (void *)mechargs);
break;
diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb
index 32427df..1ff3cb3 100644
--- a/gcc/ada/put_scos.adb
+++ b/gcc/ada/put_scos.adb
@@ -82,6 +82,7 @@ procedure Put_SCOs is
procedure Write_SCO_Initiate (SU : SCO_Unit_Index) is
SUT : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (SU);
+
begin
if Current_SCO_Unit /= SU then
Write_Info_Initiate ('C');
@@ -126,7 +127,7 @@ begin
T : SCO_Table_Entry renames SCO_Table.Table (Start);
Continuation : Boolean;
- Ctr : Nat;
+ Ctr : Nat;
-- Counter for statement entries
begin
diff --git a/gcc/ada/s-rannum.adb b/gcc/ada/s-rannum.adb
index d0b14fd..4e5e1d5 100644
--- a/gcc/ada/s-rannum.adb
+++ b/gcc/ada/s-rannum.adb
@@ -87,6 +87,7 @@
------------------------------------------------------------------------------
with Ada.Unchecked_Conversion;
+
with System.Random_Seed;
with Interfaces; use Interfaces;
@@ -480,7 +481,7 @@ package body System.Random_Numbers is
procedure Reset (Gen : Generator) is
X : constant Unsigned_32 :=
- Unsigned_32'Mod (Unsigned_64 (Random_Seed.Get_Seed) * 64);
+ Unsigned_32'Mod (Unsigned_64 (Random_Seed.Get_Seed) * 64);
-- Why * 64 ???
begin
diff --git a/gcc/ada/s-ransee.adb b/gcc/ada/s-ransee.adb
index dec22db..ad0833a 100644
--- a/gcc/ada/s-ransee.adb
+++ b/gcc/ada/s-ransee.adb
@@ -29,6 +29,8 @@
-- --
------------------------------------------------------------------------------
+-- Version used on all systems except Ravenscar where Calendar is unavailable
+
with Ada.Calendar; use Ada.Calendar;
package body System.Random_Seed is
diff --git a/gcc/ada/s-ransee.ads b/gcc/ada/s-ransee.ads
index 7a2dedd..ffae832 100644
--- a/gcc/ada/s-ransee.ads
+++ b/gcc/ada/s-ransee.ads
@@ -31,11 +31,13 @@
-- This package provide a seed for pseudo-random number generation using
-- the clock.
+
-- There are two separate implementations of this package:
-- o one based on Ada.Calendar
-- o one based on Ada.Real_Time
+
-- This is required because Ada.Calendar cannot be used on ravenscar, but
--- Ada.Real_Time drags the tasking runtime on regular platforms.
+-- Ada.Real_Time drags in the whole tasking runtime on regular platforms.
package System.Random_Seed is
diff --git a/gcc/ada/seh_init.c b/gcc/ada/seh_init.c
index 610df54..89c9ea4 100644
--- a/gcc/ada/seh_init.c
+++ b/gcc/ada/seh_init.c
@@ -99,7 +99,7 @@ __gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord,
{
/* otherwise it is a stack overflow */
exception = &storage_error;
- msg = "stack overflow (or erroneous memory access)";
+ msg = "stack overflow or erroneous memory access";
}
break;
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index ccd431f..f8f0039 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -2244,9 +2244,8 @@ package body Sem_Ch5 is
Typ : Entity_Id;
begin
- -- In semantics mode, introduce loop variable so that
- -- loop body can be properly analyzed. Otherwise this
- -- is one after expansion.
+ -- In semantics mode, introduce loop variable so that loop body can be
+ -- properly analyzed. Otherwise this is one after expansion.
if Operating_Mode = Check_Semantics then
Enter_Name (Def_Id);
@@ -2335,7 +2334,7 @@ package body Sem_Ch5 is
Error_Msg_N
("to iterate over the elements of an array, use OF", N);
- -- Prevent cascaded errors.
+ -- Prevent cascaded errors
Set_Ekind (Def_Id, E_Constant);
Set_Etype (Def_Id, Etype (First_Index (Typ)));
@@ -2496,11 +2495,11 @@ package body Sem_Ch5 is
or else not Expander_Active
then
if Present (Iter)
- and then Present (Iterator_Specification (Iter))
+ and then Present (Iterator_Specification (Iter))
then
declare
Id : constant Entity_Id :=
- Defining_Identifier (Iterator_Specification (Iter));
+ Defining_Identifier (Iterator_Specification (Iter));
begin
if Scope (Id) /= Current_Scope then
Enter_Name (Id);
generated by cgit v1.1 at 2024-10-28 09:27:21 +0000