diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 35 | ||||
| -rw-r--r-- | gcc/ada/a-cbdlli.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/a-cbdlli.ads | 11 | ||||
| -rw-r--r-- | gcc/ada/a-rbtgbo.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/comperr.adb | 70 | ||||
| -rw-r--r-- | gcc/ada/comperr.ads | 5 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.ads | 29 | ||||
| -rw-r--r-- | gcc/ada/exp_intr.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/gnat1drv.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/init.c | 10 | ||||
| -rw-r--r-- | gcc/ada/put_scos.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/s-rannum.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/s-ransee.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/s-ransee.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/seh_init.c | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 11 |
19 files changed, 171 insertions, 71 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 24abfaed4db..3240bcdfda5 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 cf2422748d2..a8a7c5eafbc 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 32e992fa60d..0443c304a8a 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 afa98f89c03..f420438efac 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 da6c8a688ed..676995fef1c 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 04a60621897..a45faf16245 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 1a1159b2a19..ab966963a69 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 5203885712d..0f184552a95 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 8a0be81bac2..8ea71916e26 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 16325829314..2d478467474 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 d712570d920..bc323a8afd4 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 3c2b5f4df98..98998fff9f0 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 9601dc690d1..0e6fb11745c 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 32427df7817..1ff3cb3aefd 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 d0b14fdf9db..4e5e1d55797 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 dec22dbf4dc..ad0833a26f2 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 7a2dedd7e12..ffae8323c04 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 610df54d6ab..89c9ea48e09 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 ccd431fb651..f8f00395c48 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); |