+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.
Process (Cursor'(Container'Unrestricted_Access, Node));
Node := Container.Nodes (Node).Next;
end loop;
+
exception
when others =>
B := B - 1;
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
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
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,
Empty_List : constant List;
No_Element : constant Cursor;
+
function Has_Element (Position : Cursor) return Boolean;
package List_Iterator_Interfaces is new
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
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;
(Tree : in out Tree_Type'Class;
Node : Count_Type)
is
-
-- CLR p. 274
X : Count_Type;
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);
-- --
-- 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- --
-- 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;
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.
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 --
-----------------
-- --
-- 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- --
-- 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 --
------------------------------
-- 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:
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,
-- 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;
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;
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
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;
((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;
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:
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
{
((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;
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;
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');
T : SCO_Table_Entry renames SCO_Table.Table (Start);
Continuation : Boolean;
- Ctr : Nat;
+ Ctr : Nat;
-- Counter for statement entries
begin
------------------------------------------------------------------------------
with Ada.Unchecked_Conversion;
+
with System.Random_Seed;
with Interfaces; use Interfaces;
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
-- --
------------------------------------------------------------------------------
+-- Version used on all systems except Ravenscar where Calendar is unavailable
+
with Ada.Calendar; use Ada.Calendar;
package body System.Random_Seed is
-- 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
{
/* otherwise it is a stack overflow */
exception = &storage_error;
- msg = "stack overflow (or erroneous memory access)";
+ msg = "stack overflow or erroneous memory access";
}
break;
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);
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)));
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);
projects / thirdparty / gcc.git / commitdiff
