+2011-08-31 Tristan Gingold <gingold@adacore.com>
+
+ * 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 <obry@adacore.com>
+
+ * projects.texi: Minor reformatting.
+
+2011-08-31 Tristan Gingold <gingold@adacore.com>
+
+ * 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 <schonberg@adacore.com>
+
+ * 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 <moy@adacore.com>
+
+ * 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 <dismukes@adacore.com>
+
+ * 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 <dismukes@adacore.com>
+
+ * 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 <moy@adacore.com>
+
+ * alfa_test.adb: Code clean up.
+
+2011-08-31 Marc Sango <sango@adacore.com>
+
+ * 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 <dewar@adacore.com>
* exp_ch5.adb, exp_alfa.ads, prj.ads, sem_attr.adb,
s-powtab$(objext) \
s-purexc$(objext) \
s-rannum$(objext) \
+ s-ransee$(objext) \
s-regexp$(objext) \
s-regpat$(objext) \
s-restri$(objext) \
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
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
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
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
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);
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 --
-------------------------------------------
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 --
----------------------------------------
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;
-- 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
-- <original loop statements>
-- 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');
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,
-----------------------------
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:
-- 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;
-- 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;
-- 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
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;
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,
Analyze (Counter_Decl);
end if;
- Finalizer_Decls := New_List;
Jump_Alts := New_List;
end if;
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
-- 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));
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
-- 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
-- Generate:
-- Abort_Id : constant Boolean := <A_Expr>;
- 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));
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;
---------------------------
---------------------------
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;
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
else
Stmt :=
- Make_Raise_Program_Error (Loc,
+ Make_Raise_Program_Error (Data.Loc,
Reason => PE_Finalize_Raised_Exception);
end if;
-- 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;
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
-- 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;
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
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;
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);
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 :=
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;
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;
---------------------------------
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);
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
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;
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));
-----------------------------
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);
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);
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
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);
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,
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;
-------------------------------
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);
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);
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
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);
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,
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;
-- 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:
-- 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) =
-- 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:
--
-- 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
-- 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));
-- 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,
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.
-- 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
-- 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
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
more qualifiers).
@end itemize
-
@c ---------------------------------------------
@node Global Attributes
@subsection Global Attributes
upon this subsystem.
@end table
-
@c ---------------------------------------------
@node Using Library Projects
@subsection Using Library Projects
must exist in the object directory.
@end table
-
@c ---------------------------------------------
@node Installing a library with project files
@subsection Installing a library with project files
for Project_Files use ("myproject.gpr");
end Agg;
-
with "prj.gpr"; -- searched on Agg'Project_Path
project MyProject is
...
It describes compilers and other tools to @code{gprbuild}.
@end table
-
@c ---------------------------------------------
@node Declarations
@subsection Declarations
whose selector is a package name in that project.
@end itemize
-
@c ---------------------------------------------
@node Attributes
@subsection Attributes
@noindent
-
@menu
* gnatmake and Project Files::
* The GNAT Driver and Project Files::
(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
@item @option{-Xnm=val} : Specify an external reference for Project Files.
@end itemize
-
-
-
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))
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))
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
-with Ada.Calendar; use Ada.Calendar;
with Ada.Unchecked_Conversion;
+with System.Random_Seed;
with Interfaces; use Interfaces;
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);
-----------
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);
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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 --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- 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;
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
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);
-- 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.
-- 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);
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.
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
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;
-- 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;
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));
-- 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;
-- 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;
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);
-- 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;
projects / platform / upstream / gcc.git / commitdiff