From f4a453ad5147c2a28e59be8c41f7db9a75f5181c Mon Sep 17 00:00:00 2001 From: charlet Date: Wed, 31 Aug 2011 09:14:10 +0000 Subject: [PATCH] 2011-08-31 Tristan Gingold * exp_ch7.ads, exp_ch7.adb (Finalization_Exception_Data): New type to hold variables between these following subprograms. (Build_Exception_Handler, Build_Object_Declarations, Build_Raise_Statement): Use the above type as parameter. Make the above adjustments. * exp_intr.adb (Expand_Unc_Deallocation): Adjust. 2011-08-31 Pascal Obry * projects.texi: Minor reformatting. 2011-08-31 Tristan Gingold * s-ransee.ads, s-ransee.adb: Add system.random_seed unit. * s-rannum.adb (Reset): Use Get_Seed from s-ransee. 2011-08-31 Ed Schonberg * exp_ch5.adb: Minor code cleanup. * sem_ch5.adb (Analyze_Iteration_Scheme): Set ekind of loop variable to prevent cascaded errors. (Analyze_Loop_Statement): In semantics-only mode, introduce loop variable of an iterator specification in current scope. * sem_ch6.adb (Analyze_Return_Statement, Find_what_It_Apples_To): Skip postconditions on the stack, as they contain no return statements. 2011-08-31 Yannick Moy * exp_alfa.adb (Expand_Alfa_N_Package_Declaration, Expand_Alfa_N_Subprogram_Body): Remove useless procedures which simply call Qualify_Entity_Names. (Expand_Alfa): call Qualify_Entity_Names in more cases * lib-xref-alfa.adb: Take into account system package. * sem_prag.adb Take into account restrictions in Alfa mode, contrary to CodePeer mode in which we are interested in finding bugs even if compiler cannot compile source. * sem_util.adb, sem_util.ads (Unique_Entity): Take into account case of deferred constant. 2011-08-31 Gary Dismukes * sem_ch3.adb (Constrain_Concurrent): Retrieve Base_Type of the subtype denoted by the subtype mark to ensure getting the concurrent type in the case where the subtype mark denotes a private subtype of a concurrent type (needed when using -gnatc). (Process_Subtype): For the processing specific to type kinds, case on the Base_Type kind of the Subtype_Mark_Id, to handle cases where the subtype denotes a private subtype whose base type is nonprivate (needed for subtypes of private fulfilled by task types when compiling with -gnatc). 2011-08-31 Gary Dismukes * sem_disp.adb (Check_Dispatching_Operation): Bypass registration of late primitives that override interface operations when the full expander is not active, to avoid blowups in Register_Primitive when types don't have associated secondary dispatch tables. 2011-08-31 Yannick Moy * alfa_test.adb: Code clean up. 2011-08-31 Marc Sango * restrict.adb (Check_SPARK_Restriction): Change Comes_From_Source (N) by Comes_From_Source (Original_Node (N)) in order to treat also the nodes which have been rewritten. * sem_ch4.adb (Analyze_Explicit_Dereference, Analyze_Slice): Guard the explicit dereference and slice violation in spark mode on the nodes coming only from the source code. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178365 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 73 +++++++++++ gcc/ada/Makefile.rtl | 1 + gcc/ada/alfa_test.adb | 67 ++++------ gcc/ada/exp_alfa.adb | 34 +---- gcc/ada/exp_ch5.adb | 8 +- gcc/ada/exp_ch7.adb | 324 +++++++++++++++++++++------------------------- gcc/ada/exp_ch7.ads | 55 +++++--- gcc/ada/exp_intr.adb | 38 +++--- gcc/ada/lib-xref-alfa.adb | 9 +- gcc/ada/projects.texi | 12 -- gcc/ada/restrict.adb | 4 +- gcc/ada/s-rannum.adb | 15 +-- gcc/ada/s-ransee.adb | 45 +++++++ gcc/ada/s-ransee.ads | 45 +++++++ gcc/ada/sem_ch3.adb | 11 +- gcc/ada/sem_ch4.adb | 8 +- gcc/ada/sem_ch5.adb | 30 ++++- gcc/ada/sem_ch6.adb | 8 +- gcc/ada/sem_disp.adb | 13 +- gcc/ada/sem_prag.adb | 4 +- gcc/ada/sem_util.adb | 5 + gcc/ada/sem_util.ads | 3 +- 22 files changed, 473 insertions(+), 339 deletions(-) create mode 100644 gcc/ada/s-ransee.adb create mode 100644 gcc/ada/s-ransee.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a48149e..8595b8b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,76 @@ +2011-08-31 Tristan Gingold + + * exp_ch7.ads, exp_ch7.adb (Finalization_Exception_Data): New type to + hold variables between these following subprograms. + (Build_Exception_Handler, Build_Object_Declarations, + Build_Raise_Statement): Use the above type as parameter. + Make the above adjustments. + * exp_intr.adb (Expand_Unc_Deallocation): Adjust. + +2011-08-31 Pascal Obry + + * projects.texi: Minor reformatting. + +2011-08-31 Tristan Gingold + + * s-ransee.ads, s-ransee.adb: Add system.random_seed unit. + * s-rannum.adb (Reset): Use Get_Seed from s-ransee. + +2011-08-31 Ed Schonberg + + * exp_ch5.adb: Minor code cleanup. + * sem_ch5.adb (Analyze_Iteration_Scheme): Set ekind of loop variable to + prevent cascaded errors. + (Analyze_Loop_Statement): In semantics-only mode, introduce loop + variable of an iterator specification in current scope. + * sem_ch6.adb (Analyze_Return_Statement, Find_what_It_Apples_To): Skip + postconditions on the stack, as they contain no return statements. + +2011-08-31 Yannick Moy + + * exp_alfa.adb (Expand_Alfa_N_Package_Declaration, + Expand_Alfa_N_Subprogram_Body): Remove useless procedures which simply + call Qualify_Entity_Names. + (Expand_Alfa): call Qualify_Entity_Names in more cases + * lib-xref-alfa.adb: Take into account system package. + * sem_prag.adb Take into account restrictions in Alfa mode, contrary to + CodePeer mode in which we are interested in finding bugs even if + compiler cannot compile source. + * sem_util.adb, sem_util.ads (Unique_Entity): Take into account case of + deferred constant. + +2011-08-31 Gary Dismukes + + * sem_ch3.adb (Constrain_Concurrent): Retrieve Base_Type of the subtype + denoted by the subtype mark to ensure getting the concurrent type in + the case where the subtype mark denotes a private subtype of a + concurrent type (needed when using -gnatc). + (Process_Subtype): For the processing specific to type kinds, case on + the Base_Type kind of the Subtype_Mark_Id, to handle cases where the + subtype denotes a private subtype whose base type is nonprivate (needed + for subtypes of private fulfilled by task types when compiling with + -gnatc). + +2011-08-31 Gary Dismukes + + * sem_disp.adb (Check_Dispatching_Operation): Bypass registration of + late primitives that override interface operations when the full + expander is not active, to avoid blowups in Register_Primitive when + types don't have associated secondary dispatch tables. + +2011-08-31 Yannick Moy + + * alfa_test.adb: Code clean up. + +2011-08-31 Marc Sango + + * restrict.adb (Check_SPARK_Restriction): Change Comes_From_Source (N) + by Comes_From_Source (Original_Node (N)) in order to treat also the + nodes which have been rewritten. + * sem_ch4.adb (Analyze_Explicit_Dereference, Analyze_Slice): Guard the + explicit dereference and slice violation in spark mode on the nodes + coming only from the source code. + 2011-08-31 Robert Dewar * exp_ch5.adb, exp_alfa.ads, prj.ads, sem_attr.adb, diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index adeb6fa..762ca78 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -603,6 +603,7 @@ GNATRTL_NONTASKING_OBJS= \ s-powtab$(objext) \ s-purexc$(objext) \ s-rannum$(objext) \ + s-ransee$(objext) \ s-regexp$(objext) \ s-regpat$(objext) \ s-restri$(objext) \ diff --git a/gcc/ada/alfa_test.adb b/gcc/ada/alfa_test.adb index c0cf37e..1e83477 100644 --- a/gcc/ada/alfa_test.adb +++ b/gcc/ada/alfa_test.adb @@ -39,23 +39,30 @@ with Get_Alfa; with Put_Alfa; -with Alfa; use Alfa; -with Types; use Types; +with Alfa; use Alfa; +with Types; use Types; with Ada.Command_Line; use Ada.Command_Line; with Ada.Streams; use Ada.Streams; with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; with Ada.Text_IO; +with GNAT.OS_Lib; use GNAT.OS_Lib; + procedure Alfa_Test is Infile : File_Type; + Name1 : String_Access; Outfile_1 : File_Type; + Name2 : String_Access; Outfile_2 : File_Type; C : Character; Stop : exception; -- Terminate execution + Diff_Exec : constant String_Access := Locate_Exec_On_Path ("diff"); + Diff_Result : Integer; + use ASCII; begin @@ -64,9 +71,12 @@ begin raise Stop; end if; - Create (Outfile_1, Out_File, "log1"); - Create (Outfile_2, Out_File, "log2"); + Name1 := new String'(Argument (1) & ".1"); + Name2 := new String'(Argument (1) & ".2"); + Open (Infile, In_File, Argument (1)); + Create (Outfile_1, Out_File, Name1.all); + Create (Outfile_2, Out_File, Name2.all); -- Read input file till we get to first 'F' line @@ -281,49 +291,24 @@ begin Write_Info_Terminate; - -- Now Outfile_1 and Outfile_2 should be identical - - Compare_Files : declare - Line : Natural; - Col : Natural; - C1 : Character; - C2 : Character; - - begin - Reset (Outfile_1, In_File); - Reset (Outfile_2, In_File); + -- Flush to disk - -- Loop to compare the two files + Close (Outfile_1); + Close (Outfile_2); - Line := 1; - Col := 1; - loop - C1 := Get_Char (Outfile_1); - C2 := Get_Char (Outfile_2); - exit when C1 = EOF or else C1 /= C2; - - if C1 = LF then - Line := Line + 1; - Col := 1; - else - Col := Col + 1; - end if; - end loop; + -- Now Outfile_1 and Outfile_2 should be identical - -- If we reached the end of file, then the files were identical, - -- otherwise, we have a failure in the comparison. + Diff_Result := + Spawn (Diff_Exec.all, + Argument_String_To_List + ("-u " & Name1.all & " " & Name2.all).all); - if C1 = EOF then - -- Success: exit silently + if Diff_Result /= 0 then + Ada.Text_IO.Put_Line ("diff(1) exit status" & Diff_Result'Img); + end if; - null; + OS_Exit (Diff_Result); - else - Ada.Text_IO.Put_Line - (Argument (1) & ": failure, files log1 and log2 differ at line" - & Line'Img & " column" & Col'Img); - end if; - end Compare_Files; end Process; exception diff --git a/gcc/ada/exp_alfa.adb b/gcc/ada/exp_alfa.adb index 56092c1..04c8484 100644 --- a/gcc/ada/exp_alfa.adb +++ b/gcc/ada/exp_alfa.adb @@ -51,15 +51,9 @@ package body Exp_Alfa is procedure Expand_Alfa_N_Attribute_Reference (N : Node_Id); -- Expand attributes 'Old and 'Result only - procedure Expand_Alfa_N_Package_Declaration (N : Node_Id); - -- Fully qualify names of enclosed entities - procedure Expand_Alfa_N_Simple_Return_Statement (N : Node_Id); -- Insert conversion on function return if necessary - procedure Expand_Alfa_N_Subprogram_Body (N : Node_Id); - -- Fully qualify names of enclosed entities - procedure Expand_Alfa_Simple_Function_Return (N : Node_Id); -- Expand simple return from function @@ -71,15 +65,15 @@ package body Exp_Alfa is begin case Nkind (N) is - when N_Package_Declaration => - Expand_Alfa_N_Package_Declaration (N); + when N_Package_Body | + N_Package_Declaration | + N_Subprogram_Body | + N_Block_Statement => + Qualify_Entity_Names (N); when N_Simple_Return_Statement => Expand_Alfa_N_Simple_Return_Statement (N); - when N_Subprogram_Body => - Expand_Alfa_N_Subprogram_Body (N); - when N_Function_Call | N_Procedure_Call_Statement => Expand_Alfa_Call (N); @@ -173,15 +167,6 @@ package body Exp_Alfa is end case; end Expand_Alfa_N_Attribute_Reference; - --------------------------------------- - -- Expand_Alfa_N_Package_Declaration -- - --------------------------------------- - - procedure Expand_Alfa_N_Package_Declaration (N : Node_Id) is - begin - Qualify_Entity_Names (N); - end Expand_Alfa_N_Package_Declaration; - ------------------------------------------- -- Expand_Alfa_N_Simple_Return_Statement -- ------------------------------------------- @@ -222,15 +207,6 @@ package body Exp_Alfa is return; end Expand_Alfa_N_Simple_Return_Statement; - ----------------------------------- - -- Expand_Alfa_N_Subprogram_Body -- - ----------------------------------- - - procedure Expand_Alfa_N_Subprogram_Body (N : Node_Id) is - begin - Qualify_Entity_Names (N); - end Expand_Alfa_N_Subprogram_Body; - ---------------------------------------- -- Expand_Alfa_Simple_Function_Return -- ---------------------------------------- diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 54dea9a..5203885 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2905,7 +2905,7 @@ package body Exp_Ch5 is Loc : constant Source_Ptr := Sloc (N); Container : constant Node_Id := Name (I_Spec); - Container_Typ : constant Entity_Id := Etype (Container); + Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); Cursor : Entity_Id; Iterator : Entity_Id; New_Loop : Node_Id; @@ -2990,7 +2990,7 @@ package body Exp_Ch5 is -- declare -- -- the block is added when Element_Type is controlled - -- Obj : Pack.Element_Type := Element (Iterator); + -- Obj : Pack.Element_Type := Element (Cursor); -- -- for the "of" loop form -- begin -- @@ -3156,9 +3156,11 @@ package body Exp_Ch5 is -- X in Iterate (S) : type of iterator is type of explicitly -- given Iterate function, and the loop variable is the cursor. + -- It will be assigned in the loop and must be a variable. else Cursor := Id; + Set_Ekind (Cursor, E_Variable); end if; Iterator := Make_Temporary (Loc, 'I'); @@ -3247,6 +3249,8 @@ package body Exp_Ch5 is Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc), Name => Relocate_Node (Name (I_Spec))); + -- Create declaration for cursor. + Decl2 := Make_Object_Declaration (Loc, Defining_Identifier => Cursor, diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 74de4b0..0901539 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -711,36 +711,35 @@ package body Exp_Ch7 is ----------------------------- function Build_Exception_Handler - (Loc : Source_Ptr; - E_Id : Entity_Id; - Raised_Id : Entity_Id; + (Data : Finalization_Exception_Data; For_Library : Boolean := False) return Node_Id is Actuals : List_Id; Proc_To_Call : Entity_Id; begin - pragma Assert (Present (E_Id)); - pragma Assert (Present (Raised_Id)); + pragma Assert (Present (Data.E_Id)); + pragma Assert (Present (Data.Raised_Id)); -- Generate: -- Get_Current_Excep.all.all Actuals := New_List ( - Make_Explicit_Dereference (Loc, + Make_Explicit_Dereference (Data.Loc, Prefix => - Make_Function_Call (Loc, + Make_Function_Call (Data.Loc, Name => - Make_Explicit_Dereference (Loc, + Make_Explicit_Dereference (Data.Loc, Prefix => - New_Reference_To (RTE (RE_Get_Current_Excep), Loc))))); + New_Reference_To (RTE (RE_Get_Current_Excep), + Data.Loc))))); if For_Library and then not Restricted_Profile then Proc_To_Call := RTE (RE_Save_Library_Occurrence); else Proc_To_Call := RTE (RE_Save_Occurrence); - Prepend_To (Actuals, New_Reference_To (E_Id, Loc)); + Prepend_To (Actuals, New_Reference_To (Data.E_Id, Data.Loc)); end if; -- Generate: @@ -754,23 +753,23 @@ package body Exp_Ch7 is -- end if; return - Make_Exception_Handler (Loc, + Make_Exception_Handler (Data.Loc, Exception_Choices => - New_List (Make_Others_Choice (Loc)), + New_List (Make_Others_Choice (Data.Loc)), Statements => New_List ( - Make_If_Statement (Loc, + Make_If_Statement (Data.Loc, Condition => - Make_Op_Not (Loc, - Right_Opnd => New_Reference_To (Raised_Id, Loc)), + Make_Op_Not (Data.Loc, + Right_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc)), Then_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => New_Reference_To (Raised_Id, Loc), - Expression => New_Reference_To (Standard_True, Loc)), + Make_Assignment_Statement (Data.Loc, + Name => New_Reference_To (Data.Raised_Id, Data.Loc), + Expression => New_Reference_To (Standard_True, Data.Loc)), - Make_Procedure_Call_Statement (Loc, + Make_Procedure_Call_Statement (Data.Loc, Name => - New_Reference_To (Proc_To_Call, Loc), + New_Reference_To (Proc_To_Call, Data.Loc), Parameter_Associations => Actuals))))); end Build_Exception_Handler; @@ -1052,21 +1051,14 @@ package body Exp_Ch7 is -- structures right from the start. Entities and lists are created once -- it has been established that N has at least one controlled object. - Abort_Id : Entity_Id := Empty; - -- Entity of local flag. The flag is set when finalization is triggered - -- by an abort. - Components_Built : Boolean := False; -- A flag used to avoid double initialization of entities and lists. If -- the flag is set then the following variables have been initialized: -- - -- Abort_Id -- Counter_Id - -- E_Id -- Finalizer_Decls -- Finalizer_Stmts -- Jump_Alts - -- Raised_Id Counter_Id : Entity_Id := Empty; Counter_Val : Int := 0; @@ -1076,9 +1068,8 @@ package body Exp_Ch7 is -- Declarative region of N (if available). If N is a package declaration -- Decls denotes the visible declarations. - E_Id : Entity_Id := Empty; - -- Entity of the local exception occurence. The first exception which - -- occurred during finalization is stored in E_Id and later reraised. + Finalizer_Data : Finalization_Exception_Data; + -- Data for the exception Finalizer_Decls : List_Id := No_List; -- Local variable declarations. This list holds the label declarations @@ -1140,10 +1131,6 @@ package body Exp_Ch7 is Priv_Decls : List_Id := No_List; -- The private declarations of N if N is a package declaration - Raised_Id : Entity_Id := Empty; - -- Entity for the raised flag. Along with E_Id, the flag is used in the - -- propagation of exceptions which occur during finalization. - Spec_Id : Entity_Id := Empty; Spec_Decls : List_Id := Top_Decls; Stmts : List_Id := No_List; @@ -1217,10 +1204,11 @@ package body Exp_Ch7 is Counter_Id := Make_Temporary (Loc, 'C'); Counter_Typ := Make_Temporary (Loc, 'T'); + Finalizer_Decls := New_List; + if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Build_Object_Declarations + (Finalizer_Data, Finalizer_Decls, Loc, For_Package); end if; -- Since the total number of controlled objects is always known, @@ -1280,7 +1268,6 @@ package body Exp_Ch7 is Analyze (Counter_Decl); end if; - Finalizer_Decls := New_List; Jump_Alts := New_List; end if; @@ -1442,7 +1429,7 @@ package body Exp_Ch7 is and then Exceptions_OK then Append_To (Finalizer_Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; -- Create the jump block which controls the finalization flow @@ -1533,14 +1520,6 @@ package body Exp_Ch7 is -- Abort_Undefer; -- Added if abort is allowed -- end Fin_Id; - if Has_Ctrl_Objs - and then Exceptions_OK - then - Prepend_List_To (Finalizer_Decls, - Build_Object_Declarations - (Loc, Abort_Id, E_Id, Raised_Id, For_Package)); - end if; - -- Create the body of the finalizer Body_Id := Make_Defining_Identifier (Loc, Chars (Fin_Id)); @@ -2567,7 +2546,7 @@ package body Exp_Ch7 is Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id, For_Package))))); + (Finalizer_Data, For_Package))))); -- When exception handlers are prohibited, the finalization call -- appears unprotected. Any exception raised during finalization @@ -2940,27 +2919,29 @@ package body Exp_Ch7 is -- Build_Object_Declarations -- ------------------------------- - function Build_Object_Declarations - (Loc : Source_Ptr; - Abort_Id : Entity_Id; - E_Id : Entity_Id; - Raised_Id : Entity_Id; - For_Package : Boolean := False) return List_Id + procedure Build_Object_Declarations + (Data : out Finalization_Exception_Data; + Decls : List_Id; + Loc : Source_Ptr; + For_Package : Boolean := False) is A_Expr : Node_Id; E_Decl : Node_Id; - Result : List_Id; begin + pragma Assert (Decls /= No_List); + if Restriction_Active (No_Exception_Propagation) then - return Empty_List; + Data.Abort_Id := Empty; + Data.E_Id := Empty; + Data.Raised_Id := Empty; + return; end if; - pragma Assert (Present (Abort_Id)); - pragma Assert (Present (E_Id)); - pragma Assert (Present (Raised_Id)); - - Result := New_List; + Data.Abort_Id := Make_Temporary (Loc, 'A'); + Data.E_Id := Make_Temporary (Loc, 'E'); + Data.Raised_Id := Make_Temporary (Loc, 'R'); + Data.Loc := Loc; -- In certain scenarios, finalization can be triggered by an abort. If -- the finalization itself fails and raises an exception, the resulting @@ -2990,9 +2971,9 @@ package body Exp_Ch7 is -- Generate: -- Abort_Id : constant Boolean := ; - Append_To (Result, + Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => Abort_Id, + Defining_Identifier => Data.Abort_Id, Constant_Present => True, Object_Definition => New_Reference_To (Standard_Boolean, Loc), Expression => A_Expr)); @@ -3002,23 +2983,21 @@ package body Exp_Ch7 is E_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => E_Id, + Defining_Identifier => Data.E_Id, Object_Definition => New_Reference_To (RTE (RE_Exception_Occurrence), Loc)); Set_No_Initialization (E_Decl); - Append_To (Result, E_Decl); + Append_To (Decls, E_Decl); -- Generate: -- Raised_Id : Boolean := False; - Append_To (Result, + Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => Raised_Id, + Defining_Identifier => Data.Raised_Id, Object_Definition => New_Reference_To (Standard_Boolean, Loc), Expression => New_Reference_To (Standard_False, Loc))); - - return Result; end Build_Object_Declarations; --------------------------- @@ -3026,10 +3005,7 @@ package body Exp_Ch7 is --------------------------- function Build_Raise_Statement - (Loc : Source_Ptr; - Abort_Id : Entity_Id; - E_Id : Entity_Id; - Raised_Id : Entity_Id) return Node_Id + (Data : Finalization_Exception_Data) return Node_Id is Stmt : Node_Id; @@ -3039,12 +3015,12 @@ package body Exp_Ch7 is if RTE_Available (RE_Raise_From_Controlled_Operation) then Stmt := - Make_Procedure_Call_Statement (Loc, + Make_Procedure_Call_Statement (Data.Loc, Name => New_Reference_To - (RTE (RE_Raise_From_Controlled_Operation), Loc), + (RTE (RE_Raise_From_Controlled_Operation), Data.Loc), Parameter_Associations => - New_List (New_Reference_To (E_Id, Loc))); + New_List (New_Reference_To (Data.E_Id, Data.Loc))); -- Restricted runtime: exception messages are not supported and hence -- Raise_From_Controlled_Operation is not supported. Raise Program_Error @@ -3052,7 +3028,7 @@ package body Exp_Ch7 is else Stmt := - Make_Raise_Program_Error (Loc, + Make_Raise_Program_Error (Data.Loc, Reason => PE_Finalize_Raised_Exception); end if; @@ -3064,13 +3040,13 @@ package body Exp_Ch7 is -- end if; return - Make_If_Statement (Loc, + Make_If_Statement (Data.Loc, Condition => - Make_And_Then (Loc, - Left_Opnd => New_Reference_To (Raised_Id, Loc), + Make_And_Then (Data.Loc, + Left_Opnd => New_Reference_To (Data.Raised_Id, Data.Loc), Right_Opnd => - Make_Op_Not (Loc, - Right_Opnd => New_Reference_To (Abort_Id, Loc))), + Make_Op_Not (Data.Loc, + Right_Opnd => New_Reference_To (Data.Abort_Id, Data.Loc))), Then_Statements => New_List (Stmt)); end Build_Raise_Statement; @@ -4222,18 +4198,17 @@ package body Exp_Ch7 is Last_Object : Node_Id; Related_Node : Node_Id) is - Abort_Id : Entity_Id; - Built : Boolean := False; - Desig : Entity_Id; - E_Id : Entity_Id; - Fin_Block : Node_Id; - Last_Fin : Node_Id := Empty; - Loc : Source_Ptr; - Obj_Id : Entity_Id; - Obj_Ref : Node_Id; - Obj_Typ : Entity_Id; - Raised_Id : Entity_Id; - Stmt : Node_Id; + Finalizer_Data : Finalization_Exception_Data; + Finalizer_Decls : List_Id; + Built : Boolean := False; + Desig : Entity_Id; + Fin_Block : Node_Id; + Last_Fin : Node_Id := Empty; + Loc : Source_Ptr; + Obj_Id : Entity_Id; + Obj_Ref : Node_Id; + Obj_Typ : Entity_Id; + Stmt : Node_Id; begin -- Examine all objects in the list First_Object .. Last_Object @@ -4266,13 +4241,12 @@ package body Exp_Ch7 is -- time around. if not Built then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations + (Finalizer_Data, Finalizer_Decls, Loc); - Insert_List_Before_And_Analyze (First_Object, - Build_Object_Declarations - (Loc, Abort_Id, E_Id, Raised_Id)); + Insert_List_Before_And_Analyze + (First_Object, Finalizer_Decls); Built := True; end if; @@ -4306,7 +4280,7 @@ package body Exp_Ch7 is Typ => Desig)), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); Insert_After_And_Analyze (Last_Object, Fin_Block); -- The raise statement must be inserted after all the @@ -4371,7 +4345,7 @@ package body Exp_Ch7 is and then Present (Last_Fin) then Insert_After_And_Analyze (Last_Fin, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; end Process_Transient_Objects; @@ -4760,20 +4734,19 @@ package body Exp_Ch7 is function Build_Adjust_Or_Finalize_Statements (Typ : Entity_Id) return List_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Index_List : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Typ); - Num_Dims : constant Int := Number_Dimensions (Typ); - Abort_Id : Entity_Id := Empty; - Call : Node_Id; - Comp_Ref : Node_Id; - Core_Loop : Node_Id; - Dim : Int; - E_Id : Entity_Id := Empty; - J : Entity_Id; - Loop_Id : Entity_Id; - Raised_Id : Entity_Id := Empty; - Stmts : List_Id; + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); + Finalizer_Decls : List_Id := No_List; + Finalizer_Data : Finalization_Exception_Data; + Call : Node_Id; + Comp_Ref : Node_Id; + Core_Loop : Node_Id; + Dim : Int; + J : Entity_Id; + Loop_Id : Entity_Id; + Stmts : List_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); @@ -4802,9 +4775,8 @@ package body Exp_Ch7 is Build_Indices; if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); end if; Comp_Ref := @@ -4848,7 +4820,7 @@ package body Exp_Ch7 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Call), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); else Core_Loop := Call; end if; @@ -4912,14 +4884,14 @@ package body Exp_Ch7 is if Exceptions_OK then Append_To (Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; return New_List ( Make_Block_Statement (Loc, Declarations => - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id), + Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Stmts))); end Build_Adjust_Or_Finalize_Statements; @@ -4929,24 +4901,23 @@ package body Exp_Ch7 is --------------------------------- function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Final_List : constant List_Id := New_List; - Index_List : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Typ); - Num_Dims : constant Int := Number_Dimensions (Typ); - Abort_Id : Entity_Id; - Counter_Id : Entity_Id; - Dim : Int; - E_Id : Entity_Id := Empty; - F : Node_Id; - Fin_Stmt : Node_Id; - Final_Block : Node_Id; - Final_Loop : Node_Id; - Init_Loop : Node_Id; - J : Node_Id; - Loop_Id : Node_Id; - Raised_Id : Entity_Id := Empty; - Stmts : List_Id; + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Final_List : constant List_Id := New_List; + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); + Counter_Id : Entity_Id; + Dim : Int; + F : Node_Id; + Fin_Stmt : Node_Id; + Final_Block : Node_Id; + Final_Loop : Node_Id; + Finalizer_Data : Finalization_Exception_Data; + Finalizer_Decls : List_Id := No_List; + Init_Loop : Node_Id; + J : Node_Id; + Loop_Id : Node_Id; + Stmts : List_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); @@ -5081,9 +5052,8 @@ package body Exp_Ch7 is Counter_Id := Make_Temporary (Loc, 'C'); if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); end if; -- Generate the block which houses the finalization call, the index @@ -5112,7 +5082,7 @@ package body Exp_Ch7 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Build_Finalization_Call), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); else Fin_Stmt := Build_Finalization_Call; end if; @@ -5204,14 +5174,14 @@ package body Exp_Ch7 is if Exceptions_OK then Append_To (Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); Append_To (Stmts, Make_Raise_Statement (Loc)); end if; Final_Block := Make_Block_Statement (Loc, Declarations => - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id), + Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); @@ -5583,14 +5553,13 @@ package body Exp_Ch7 is ----------------------------- function Build_Adjust_Statements (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); - Abort_Id : Entity_Id := Empty; - Bod_Stmts : List_Id; - E_Id : Entity_Id := Empty; - Raised_Id : Entity_Id := Empty; - Rec_Def : Node_Id; - Var_Case : Node_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Bod_Stmts : List_Id; + Finalizer_Data : Finalization_Exception_Data; + Finalizer_Decls : List_Id := No_List; + Rec_Def : Node_Id; + Var_Case : Node_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); @@ -5654,7 +5623,7 @@ package body Exp_Ch7 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Adj_Stmt), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); end if; Append_To (Stmts, Adj_Stmt); @@ -5792,9 +5761,8 @@ package body Exp_Ch7 is begin if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); end if; if Nkind (Typ_Def) = N_Derived_Type_Definition then @@ -5891,7 +5859,7 @@ package body Exp_Ch7 is Statements => New_List (Adj_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id)))); + (Finalizer_Data)))); end if; Prepend_To (Bod_Stmts, Adj_Stmt); @@ -5942,7 +5910,7 @@ package body Exp_Ch7 is Statements => New_List (Adj_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id)))); + (Finalizer_Data)))); end if; Append_To (Bod_Stmts, @@ -5981,14 +5949,14 @@ package body Exp_Ch7 is else if Exceptions_OK then Append_To (Bod_Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; return New_List ( Make_Block_Statement (Loc, Declarations => - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id), + Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); end if; @@ -5999,15 +5967,14 @@ package body Exp_Ch7 is ------------------------------- function Build_Finalize_Statements (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); - Abort_Id : Entity_Id := Empty; - Bod_Stmts : List_Id; - Counter : Int := 0; - E_Id : Entity_Id := Empty; - Raised_Id : Entity_Id := Empty; - Rec_Def : Node_Id; - Var_Case : Node_Id; + Loc : constant Source_Ptr := Sloc (Typ); + Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Bod_Stmts : List_Id; + Counter : Int := 0; + Finalizer_Data : Finalization_Exception_Data; + Finalizer_Decls : List_Id := No_List; + Rec_Def : Node_Id; + Var_Case : Node_Id; Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); @@ -6140,7 +6107,7 @@ package body Exp_Ch7 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Fin_Stmt), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id)))); + Build_Exception_Handler (Finalizer_Data)))); end if; Append_To (Stmts, Fin_Stmt); @@ -6372,9 +6339,8 @@ package body Exp_Ch7 is begin if Exceptions_OK then - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); + Finalizer_Decls := New_List; + Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); end if; if Nkind (Typ_Def) = N_Derived_Type_Definition then @@ -6473,7 +6439,7 @@ package body Exp_Ch7 is Statements => New_List (Fin_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id)))); + (Finalizer_Data)))); end if; Append_To (Bod_Stmts, Fin_Stmt); @@ -6526,7 +6492,7 @@ package body Exp_Ch7 is Statements => New_List (Fin_Stmt), Exception_Handlers => New_List ( Build_Exception_Handler - (Loc, E_Id, Raised_Id)))); + (Finalizer_Data)))); end if; Prepend_To (Bod_Stmts, @@ -6563,14 +6529,14 @@ package body Exp_Ch7 is else if Exceptions_OK then Append_To (Bod_Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Raise_Statement (Finalizer_Data)); end if; return New_List ( Make_Block_Statement (Loc, Declarations => - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id), + Finalizer_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Bod_Stmts))); end if; diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index dbebd8a..8a0be81 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -40,10 +40,39 @@ package Exp_Ch7 is -- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize -- that take care of finalization management at run-time. - function Build_Exception_Handler - (Loc : Source_Ptr; + -- 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. + -- 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. + type Finalization_Exception_Data is record + Loc : Source_Ptr; + -- Sloc for the added nodes + + Abort_Id : Entity_Id; + -- Boolean variable set to true if the finalization was triggered by + -- an abort. + E_Id : Entity_Id; + -- Variable containing the exception occurrence raised by user code + Raised_Id : Entity_Id; + -- Boolean variable set to true if an exception was raised in user code + end record; + + function Build_Exception_Handler + (Data : Finalization_Exception_Data; For_Library : Boolean := False) return Node_Id; -- Subsidiary to Build_Finalizer, Make_Deep_Array_Body and Make_Deep_Record -- _Body. Create an exception handler of the following form: @@ -84,15 +113,14 @@ package Exp_Ch7 is -- Build one controlling procedure when a late body overrides one of -- the controlling operations. - function Build_Object_Declarations - (Loc : Source_Ptr; - Abort_Id : Entity_Id; - E_Id : Entity_Id; - Raised_Id : Entity_Id; - For_Package : Boolean := False) return List_Id; - -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Return a - -- list containing the object declarations of boolean flag Abort_Id, the - -- exception occurrence E_Id and boolean flag Raised_Id. + procedure Build_Object_Declarations + (Data : out Finalization_Exception_Data; + Decls : List_Id; + Loc : Source_Ptr; + For_Package : Boolean := False); + -- Subsidiary to Make_Deep_Array_Body and Make_Deep_Record_Body. Create the + -- list List containing the object declarations of boolean flag Abort_Id, + -- the exception occurrence E_Id and boolean flag Raised_Id. -- -- Abort_Id : constant Boolean := -- Exception_Identity (Get_Current_Excep.all) = @@ -104,10 +132,7 @@ package Exp_Ch7 is -- Raised_Id : Boolean := False; function Build_Raise_Statement - (Loc : Source_Ptr; - Abort_Id : Entity_Id; - E_Id : Entity_Id; - Raised_Id : Entity_Id) return Node_Id; + (Data : Finalization_Exception_Data) return Node_Id; -- Subsidiary to routines Build_Finalizer, Make_Deep_Array_Body and Make_ -- Deep_Record_Body. Generate the following conditional raise statement: -- diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 0703547..1632582 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -876,23 +876,23 @@ package body Exp_Intr is -- structures to find and terminate those components. procedure Expand_Unc_Deallocation (N : Node_Id) is - Arg : constant Node_Id := First_Actual (N); - Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Etype (Arg); - Desig_T : constant Entity_Id := Designated_Type (Typ); - Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); - Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); - Stmts : constant List_Id := New_List; - - Abort_Id : Entity_Id := Empty; + Arg : constant Node_Id := First_Actual (N); + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (Arg); + Desig_T : constant Entity_Id := Designated_Type (Typ); + Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ)); + Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp); + Stmts : constant List_Id := New_List; + Needs_Fin : constant Boolean := Needs_Finalization (Desig_T); + + Finalizer_Data : Finalization_Exception_Data; + Blk : Node_Id := Empty; Deref : Node_Id; - E_Id : Entity_Id := Empty; Final_Code : List_Id; Free_Arg : Node_Id; Free_Node : Node_Id; Gen_Code : Node_Id; - Raised_Id : Entity_Id := Empty; Arg_Known_Non_Null : constant Boolean := Known_Non_Null (N); -- This captures whether we know the argument to be non-null so that @@ -909,7 +909,7 @@ package body Exp_Intr is -- Processing for pointer to controlled type - if Needs_Finalization (Desig_T) then + if Needs_Fin then Deref := Make_Explicit_Dereference (Loc, Prefix => Duplicate_Subexpr_No_Checks (Arg)); @@ -958,12 +958,7 @@ package body Exp_Intr is -- Save_Occurrence (E, Get_Current_Excep.all.all); -- end; - Abort_Id := Make_Temporary (Loc, 'A'); - E_Id := Make_Temporary (Loc, 'E'); - Raised_Id := Make_Temporary (Loc, 'R'); - - Append_List_To (Stmts, - Build_Object_Declarations (Loc, Abort_Id, E_Id, Raised_Id)); + Build_Object_Declarations (Finalizer_Data, Stmts, Loc); Final_Code := New_List ( Make_Block_Statement (Loc, @@ -974,7 +969,7 @@ package body Exp_Intr is Obj_Ref => Deref, Typ => Desig_T)), Exception_Handlers => New_List ( - Build_Exception_Handler (Loc, E_Id, Raised_Id))))); + Build_Exception_Handler (Finalizer_Data))))); -- For .NET/JVM, detach the object from the containing finalization -- collection before finalizing it. @@ -1216,9 +1211,8 @@ package body Exp_Intr is -- Raise_From_Controlled_Operation (E); -- all other cases -- end if; - if Present (Raised_Id) then - Append_To (Stmts, - Build_Raise_Statement (Loc, Abort_Id, E_Id, Raised_Id)); + if Needs_Fin then + Append_To (Stmts, Build_Raise_Statement (Finalizer_Data)); end if; -- If we know the argument is non-null, then make a block statement diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb index 81331eb..25b7b79 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-alfa.adb @@ -886,14 +886,7 @@ package body Alfa is -- Generate file and scope Alfa information for D in 1 .. Num_Sdep loop - - -- Ignore file for System - - if Units.Table (Sdep_Table (D)).Source_Index /= - System_Source_File_Index - then - Add_Alfa_File (U => Sdep_Table (D), D => D); - end if; + Add_Alfa_File (U => Sdep_Table (D), D => D); end loop; -- Fill in the spec information when relevant diff --git a/gcc/ada/projects.texi b/gcc/ada/projects.texi index 2a3e5bc..6f87ba5 100644 --- a/gcc/ada/projects.texi +++ b/gcc/ada/projects.texi @@ -985,7 +985,6 @@ The following attributes can be defined in package @code{Naming}: other than Ada. They are indexed on the language name, and contain a list of file names respectively for headers and source code. - @end table @ifclear vms @@ -1315,7 +1314,6 @@ There are two main approaches to avoiding this duplication: more qualifiers). @end itemize - @c --------------------------------------------- @node Global Attributes @subsection Global Attributes @@ -1649,7 +1647,6 @@ Other library-related attributes can be used to change the defaults: upon this subsystem. @end table - @c --------------------------------------------- @node Using Library Projects @subsection Using Library Projects @@ -1873,7 +1870,6 @@ included in the library. must exist in the object directory. @end table - @c --------------------------------------------- @node Installing a library with project files @subsection Installing a library with project files @@ -2270,7 +2266,6 @@ aggregate project Agg is for Project_Files use ("myproject.gpr"); end Agg; - with "prj.gpr"; -- searched on Agg'Project_Path project MyProject is ... @@ -2777,7 +2772,6 @@ The current list of qualifiers is: It describes compilers and other tools to @code{gprbuild}. @end table - @c --------------------------------------------- @node Declarations @subsection Declarations @@ -3226,7 +3220,6 @@ A @b{context} may be one of the following: whose selector is a package name in that project. @end itemize - @c --------------------------------------------- @node Attributes @subsection Attributes @@ -3547,7 +3540,6 @@ end MyProj; @noindent - @menu * gnatmake and Project Files:: * The GNAT Driver and Project Files:: @@ -4049,7 +4041,6 @@ When a library project file is specified, switches ^-b^/ACTION=BIND^ and (in the case of a stand-alone library) and that the library should be built. @end itemize - @c --------------------------------------------- @node The GNAT Driver and Project Files @section The GNAT Driver and Project Files @@ -4490,6 +4481,3 @@ The switches for GPRclean are: @item @option{-Xnm=val} : Specify an external reference for Project Files. @end itemize - - - diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 1860616..1bfe156 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -117,7 +117,7 @@ package body Restrict is Msg_Issued : Boolean; Save_Error_Msg_Sloc : Source_Ptr; begin - if Force or else Comes_From_Source (N) then + if Force or else Comes_From_Source (Original_Node (N)) then if Restriction_Check_Required (SPARK) and then Is_In_Hidden_Part_In_SPARK (Sloc (N)) @@ -145,7 +145,7 @@ package body Restrict is begin pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\'); - if Comes_From_Source (N) then + if Comes_From_Source (Original_Node (N)) then if Restriction_Check_Required (SPARK) and then Is_In_Hidden_Part_In_SPARK (Sloc (N)) diff --git a/gcc/ada/s-rannum.adb b/gcc/ada/s-rannum.adb index d85dd2e..d0b14fd 100644 --- a/gcc/ada/s-rannum.adb +++ b/gcc/ada/s-rannum.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2007-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- -- @@ -86,8 +86,8 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Calendar; use Ada.Calendar; with Ada.Unchecked_Conversion; +with System.Random_Seed; with Interfaces; use Interfaces; @@ -95,11 +95,6 @@ use Ada; package body System.Random_Numbers is - Y2K : constant Calendar.Time := - Calendar.Time_Of - (Year => 2000, Month => 1, Day => 1, Seconds => 0.0); - -- First day of Year 2000 (what is this for???) - Image_Numeral_Length : constant := Max_Image_Width / N; subtype Image_String is String (1 .. Max_Image_Width); @@ -484,11 +479,9 @@ package body System.Random_Numbers is ----------- procedure Reset (Gen : Generator) is - Clock : constant Time := Calendar.Clock; - Duration_Since_Y2K : constant Duration := Clock - Y2K; - X : constant Unsigned_32 := - Unsigned_32'Mod (Unsigned_64 (Duration_Since_Y2K) * 64); + Unsigned_32'Mod (Unsigned_64 (Random_Seed.Get_Seed) * 64); + -- Why * 64 ??? begin Init (Gen, X); diff --git a/gcc/ada/s-ransee.adb b/gcc/ada/s-ransee.adb new file mode 100644 index 0000000..dec22db --- /dev/null +++ b/gcc/ada/s-ransee.adb @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . R A N D O M _ S E E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 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- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; use Ada.Calendar; + +package body System.Random_Seed is + + Y2K : constant Time := + Time_Of (Year => 2000, Month => 1, Day => 1, Seconds => 0.0); + -- First day of Year 2000, to get a duration. + + function Get_Seed return Duration is + begin + return Clock - Y2K; + end Get_Seed; + +end System.Random_Seed; diff --git a/gcc/ada/s-ransee.ads b/gcc/ada/s-ransee.ads new file mode 100644 index 0000000..7a2dedd --- /dev/null +++ b/gcc/ada/s-ransee.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . R A N D O M _ S E E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 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- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- 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. + +package System.Random_Seed is + + function Get_Seed return Duration; + -- Get a seed based on the clock + +end System.Random_Seed; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index e7ec37e..25134b6 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -11340,7 +11340,10 @@ package body Sem_Ch3 is Related_Id : Entity_Id; Suffix : Character) is - T_Ent : Entity_Id := Entity (Subtype_Mark (SI)); + -- Retrieve Base_Type to ensure getting to the concurrent type in the + -- case of a private subtype (needed when only doing semantic analysis). + + T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI))); T_Val : Entity_Id; begin @@ -18570,9 +18573,11 @@ package body Sem_Ch3 is return Process_Subtype (S, Related_Nod, Related_Id, Suffix); end if; - -- Remaining processing depends on type + -- Remaining processing depends on type. Select on Base_Type kind to + -- ensure getting to the concrete type kind in the case of a private + -- subtype (needed when only doing semantic analysis). - case Ekind (Subtype_Mark_Id) is + case Ekind (Base_Type (Subtype_Mark_Id)) is when Access_Kind => Constrain_Access (Def_Id, S, Related_Nod); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index f26c6ee..3f03aee 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1763,7 +1763,9 @@ package body Sem_Ch4 is -- Start of processing for Analyze_Explicit_Dereference begin - Check_SPARK_Restriction ("explicit dereference is not allowed", N); + if Comes_From_Source (N) then + Check_SPARK_Restriction ("explicit dereference is not allowed", N); + end if; -- In formal verification mode, keep track of all reads and writes -- through explicit dereferences. @@ -4417,7 +4419,9 @@ package body Sem_Ch4 is -- Start of processing for Analyze_Slice begin - Check_SPARK_Restriction ("slice is not allowed", N); + if Comes_From_Source (N) then + Check_SPARK_Restriction ("slice is not allowed", N); + end if; Analyze (P); Analyze (D); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index c9c2463..ccd431f 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1965,6 +1965,7 @@ package body Sem_Ch5 is begin Enter_Name (Id); + Set_Ekind (Id, E_Constant); -- We always consider the loop variable to be referenced, since -- the loop may be used just for counting purposes. @@ -2243,7 +2244,14 @@ package body Sem_Ch5 is Typ : Entity_Id; begin - Enter_Name (Def_Id); + -- 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); + end if; + Set_Ekind (Def_Id, E_Variable); if Present (Subt) then @@ -2326,6 +2334,10 @@ package body Sem_Ch5 is else Error_Msg_N ("to iterate over the elements of an array, use OF", N); + + -- Prevent cascaded errors. + + Set_Ekind (Def_Id, E_Constant); Set_Etype (Def_Id, Etype (First_Index (Typ))); end if; @@ -2476,12 +2488,26 @@ package body Sem_Ch5 is -- If the expander is not active, then we want to analyze the loop body -- now even in the Ada 2012 iterator case, since the rewriting will not - -- be done. + -- be done. Insert the loop variable in the current scope, if not done + -- when analysing the iteration scheme. if No (Iter) or else No (Iterator_Specification (Iter)) or else not Expander_Active then + if Present (Iter) + and then Present (Iterator_Specification (Iter)) + then + declare + Id : constant Entity_Id := + Defining_Identifier (Iterator_Specification (Iter)); + begin + if Scope (Id) /= Current_Scope then + Enter_Name (Id); + end if; + end; + end if; + Analyze_Statements (Statements (Loop_Statement)); end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 85cdc2a..b4d5849 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1350,12 +1350,14 @@ package body Sem_Ch6 is Result : Entity_Id := Empty; begin - -- Loop outward through the Scope_Stack, skipping blocks and loops + -- Loop outward through the Scope_Stack, skipping blocks, loops, + -- and postconditions. for J in reverse 0 .. Scope_Stack.Last loop Result := Scope_Stack.Table (J).Entity; - exit when Ekind (Result) /= E_Block and then - Ekind (Result) /= E_Loop; + exit when Ekind (Result) /= E_Block + and then Ekind (Result) /= E_Loop + and then Chars (Result) /= Name_uPostconditions; end loop; pragma Assert (Present (Result)); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 7e64d98..fb20b1a 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -1156,11 +1156,14 @@ package body Sem_Disp is -- Ada 2005 (AI-251): In case of late overriding of a primitive -- that covers abstract interface subprograms we must register it -- in all the secondary dispatch tables associated with abstract - -- interfaces. We do this now only if not building static tables. - -- Otherwise the patch code is emitted after those tables are - -- built, to prevent access_before_elaboration in gigi. - - if Body_Is_Last_Primitive then + -- interfaces. We do this now only if not building static tables, + -- nor when the expander is inactive (we avoid trying to register + -- primitives in semantics-only mode, since the type may not have + -- an associated dispatch table). Otherwise the patch code is + -- emitted after those tables are built, to prevent access before + -- elaboration in gigi. + + if Body_Is_Last_Primitive and then Full_Expander_Active then declare Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); Elmt : Elmt_Id; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 1fa9376..7b1fd55 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5090,9 +5090,9 @@ package body Sem_Prag is -- Start of processing for Process_Restrictions_Or_Restriction_Warnings begin - -- Ignore all Restrictions pragma in CodePeer and Alfa modes + -- Ignore all Restrictions pragma in CodePeer mode - if CodePeer_Mode or Alfa_Mode then + if CodePeer_Mode then return; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 06a89a2..fbc72a8 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12656,6 +12656,11 @@ package body Sem_Util is begin case Ekind (E) is + when E_Constant => + if Present (Full_View (E)) then + U := Full_View (E); + end if; + when Type_Kind => if Present (Full_View (E)) then U := Full_View (E); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 97d8e80..fc408b3 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1448,7 +1448,8 @@ package Sem_Util is -- views of the same entity have the same unique defining entity: -- * package spec and body; -- * subprogram declaration, subprogram stub and subprogram body; - -- * private view and full view of a type. + -- * private view and full view of a type; + -- * private view and full view of a deferred constant. -- In other cases, return the defining entity for N. function Unique_Entity (E : Entity_Id) return Entity_Id; -- 2.7.4