Skip to content

R
riscv-gcc-1
Commit 3373589b by Arnaud Charlet
Options

[multiple changes] 

2015-10-26  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb (Resolve_Generalized_Indexing): In ASIS mode, when
	restoring original node, remove Generalized_Indexing operation
	so that it is recreated during re- analysis.

2015-10-26  Javier Miranda  <miranda@adacore.com>

	* exp_unst.adb: (Unnest_Subprogram):
	Replace absolute references to 1 and 0 by their counterpart
	relative references through Subps_First.

2015-10-26  Ed Schonberg  <schonberg@adacore.com>

	* par-ch3.adb (P_Declarative_Items): In case of misplaced
	aspect specifications, ensure that flag Done is properly set to
	continue parse.
	* sem_prag.adb, sem_prag.ads: Remove Build_Generic_Class_Condition,
	unused.

From-SVN: r229362
parent 64dfccae
Showing with 33 additions and 266 deletions
gcc/ada/ChangeLog
2015-10-26 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Generalized_Indexing): In ASIS mode, when
restoring original node, remove Generalized_Indexing operation
so that it is recreated during re- analysis.
2015-10-26 Javier Miranda <miranda@adacore.com>
* exp_unst.adb: (Unnest_Subprogram):
Replace absolute references to 1 and 0 by their counterpart
relative references through Subps_First.
2015-10-26 Ed Schonberg <schonberg@adacore.com>
* par-ch3.adb (P_Declarative_Items): In case of misplaced
aspect specifications, ensure that flag Done is properly set to
continue parse.
* sem_prag.adb, sem_prag.ads: Remove Build_Generic_Class_Condition,
unused.
2015-10-26 Emmanuel Briot <briot@adacore.com>
* s-os_lib.adb (Argument_String_To_List): Remove backslashes in
......
gcc/ada/exp_unst.adb
......@@ -275,9 +275,9 @@ package body Exp_Unst is
-- First step, we must mark all nested subprograms that require a static
-- link (activation record) because either they contain explicit uplevel
-- references (as indicated by ??? being set at this
-- point), or they make calls to other subprograms in the same nest that
-- require a static link (in which case we set this flag).
-- references (as indicated by Is_Uplevel_Referenced_Entity being set at
-- this point), or they make calls to other subprograms in the same nest
-- that require a static link (in which case we set this flag).
-- This is a recursive definition, and to implement this, we have to
-- build a call graph for the set of nested subprograms, and then go
......@@ -684,7 +684,7 @@ package body Exp_Unst is
Modified : Boolean;
begin
Subps.Table (1).Reachable := True;
Subps.Table (Subps_First).Reachable := True;
-- We use a simple minded algorithm as follows (obviously this can
-- be done more efficiently, using one of the standard algorithms
......@@ -822,13 +822,13 @@ package body Exp_Unst is
-- Remove unreachable subprograms from Subps table. Note that we do
-- this after eliminating entries from the other two tables, since
-- thos elimination steps depend on referencing the Subps table.
-- those elimination steps depend on referencing the Subps table.
declare
New_SI : SI_Type;
begin
New_SI := 0;
New_SI := Subps_First - 1;
for J in Subps_First .. Subps.Last loop
declare
STJ : Subp_Entry renames Subps.Table (J);
......
gcc/ada/par-ch3.adb
......@@ -4560,6 +4560,11 @@ package body Ch3 is
Scan; -- past RECORD
TF_Semicolon;
-- This might happen because of misplaced aspect specification.
-- After discarding the misplaced aspects we can continue the
-- scan.
Done := False;
else
Restore_Scan_State (Scan_State); -- to END
Done := True;
......
gcc/ada/sem_prag.adb
......@@ -22932,10 +22932,6 @@ package body Sem_Prag is
end if;
end if;
if Class_Present (N) then
Build_Generic_Class_Condition (Spec_Id, N);
end if;
Preanalyze_Assert_Expression (Expr, Standard_Boolean);
-- For a class-wide condition, a reference to a controlling formal must
......@@ -25727,251 +25723,6 @@ package body Sem_Prag is
return False;
end Appears_In;
-----------------------------------
-- Build_Generic_Class_Condition --
-----------------------------------
procedure Build_Generic_Class_Condition
(Subp : Entity_Id;
Prag : Node_Id)
is
Expr : constant Node_Id :=
Get_Pragma_Arg
(First (Pragma_Argument_Associations (Prag)));
Loc : constant Source_Ptr := Sloc (Prag);
Map : constant Elist_Id := New_Elmt_List;
New_Expr : constant Node_Id := New_Copy_Tree (Expr);
New_Pred : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_External_Name (Chars (Subp), "Pre", -1));
Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
function Replace_Formal (N : Node_Id) return Traverse_Result;
-- Replace occurrence of a formal parameter of the original expression
-- in the precondition, with the formal of the generic function created
-- for it.
--------------------
-- Replace_Formal --
--------------------
function Replace_Formal (N : Node_Id) return Traverse_Result is
Loc : constant Source_Ptr := Sloc (N);
El : Elmt_Id;
F : Entity_Id;
New_F : Entity_Id;
begin
if Nkind (N) = N_Identifier
and then (Nkind (Parent (N)) /= N_Parameter_Association
or else N /= Selector_Name (Parent (N)))
and then Present (Entity (N))
and then Is_Formal (Entity (N))
then
El := First_Elmt (Map);
while Present (El) loop
F := Node (El);
if Chars (F) = Chars (N) then
New_F := Node (Next_Elmt (El));
-- If this is a controlling formal, in the generic it
-- becomes a conversion to the controlling formal of the
-- operation with the class-wide precondition. If the formal
-- is an access parameter, a reference to F becomes
-- Root (New_F.all)'access.
if Is_Controlling_Formal (F) then
if Is_Access_Type (Etype (F)) then
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix =>
Unchecked_Convert_To (
Designated_Type (Etype (F)),
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (New_F, Loc))),
Attribute_Name => Name_Access));
else
Rewrite (N,
Unchecked_Convert_To
(Etype (F), New_Occurrence_Of (New_F, Sloc (N))));
end if;
-- Noncontrolling formals retain their original type
else
Rewrite (N, New_Occurrence_Of (New_F, Sloc (N)));
end if;
return OK;
end if;
Next_Elmt (El);
Next_Elmt (El);
end loop;
elsif Nkind (N) = N_Parameter_Association then
Set_Next_Named_Actual (N, Empty);
elsif Nkind (N) = N_Function_Call then
Set_First_Named_Actual (N, Empty);
end if;
return OK;
end Replace_Formal;
procedure Map_Formals is new Traverse_Proc (Replace_Formal);
-- Local variables
Bod : Node_Id;
Decl : Node_Id;
F : Entity_Id;
New_F : Entity_Id;
New_Form : List_Id;
New_Typ : Entity_Id;
Par_Typ : Entity_Id;
Root_Typ : Entity_Id;
Spec : Node_Id;
-- Start of processing for Build_Generic_Class_Pre
begin
-- Nothing to do if previous error or expansion disabled.
if not Expander_Active then
return;
end if;
if Chars (Pragma_Identifier (Prag)) = Name_Postcondition then
return;
end if;
-- Build list of controlling formals and their renamings in the new
-- generic operation.
New_Form := New_List;
New_Typ := Empty;
F := First_Formal (Subp);
while Present (F) loop
New_F :=
Make_Defining_Identifier (Loc, New_External_Name (Chars (F), "GF"));
Set_Ekind (New_F, Ekind (F));
Append_Elmt (F, Map);
Append_Elmt (New_F, Map);
if Is_Controlling_Formal (F) then
Root_Typ := Etype (F);
if Is_Access_Type (Etype (F)) then
Root_Typ := Designated_Type (Root_Typ);
New_Typ :=
Make_Defining_Identifier (Loc,
Chars =>
New_External_Name
(Chars (Designated_Type (Etype (F))), "GT"));
Par_Typ :=
Make_Access_Definition (Loc,
Subtype_Mark => New_Occurrence_Of (New_Typ, Loc));
else
New_Typ :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Etype (F)), "GT"));
Par_Typ := New_Occurrence_Of (New_Typ, Loc);
end if;
Append_To (New_Form,
Make_Parameter_Specification (Loc,
Defining_Identifier => New_F,
Parameter_Type => Par_Typ));
else
-- If formal has a class-wide type, build same attribute for new
-- formal.
if Is_Class_Wide_Type (Etype (F)) then
Append_To (New_Form,
Make_Parameter_Specification (Loc,
Defining_Identifier => New_F,
Parameter_Type =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Etype (Etype (F)), Loc),
Attribute_Name => Name_Class)));
else
-- If it is an anonymous access type, create a similar type
-- definition.
if Ekind (Etype (F)) = E_Anonymous_Access_Type then
Par_Typ := New_Copy_Tree (Parameter_Type (Parent (F)));
else
Par_Typ := New_Occurrence_Of (Etype (F), Loc);
end if;
Append_To (New_Form,
Make_Parameter_Specification (Loc,
Defining_Identifier => New_F,
Parameter_Type => Par_Typ));
end if;
end if;
Next_Formal (F);
end loop;
-- If no controlling formal found, pre/postcondition is incorrect.
if No (New_Typ) then
return;
end if;
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => New_Pred,
Parameter_Specifications => New_Form,
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc));
Decl :=
Make_Generic_Subprogram_Declaration (Loc,
Specification => Spec,
Generic_Formal_Declarations => New_List (
Make_Formal_Type_Declaration (Loc,
Defining_Identifier => New_Typ,
Formal_Type_Definition =>
Make_Formal_Derived_Type_Definition (Loc,
Subtype_Mark => New_Occurrence_Of (Root_Typ, Loc),
Private_Present => True))));
Preanalyze (New_Expr);
Map_Formals (New_Expr);
Bod :=
Make_Subprogram_Body (Loc,
Specification => New_Copy_Tree (Spec),
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression => New_Expr))));
-- Generic function must be analyzed after type is frozen, and will be
-- instantiated when subprogram contract for operation or any of its
-- overridings is expanded.
Append_Freeze_Actions (Typ, New_List (Decl, Bod));
-- We need to convey the existence of the generic to the point at which
-- we expand the contract. We replace the expression in the pragma with
-- name of the generic function, to be instantiated when expanding the
-- contract for the subprogram or some overriding of it. See
-- Exp_ch6.Expand_Subprogram_Contract.Build_Pragma_Check_Equivalent.
-- (TBD)
Set_Ekind (New_Pred, E_Generic_Function);
Set_Scope (New_Pred, Current_Scope);
end Build_Generic_Class_Condition;
-----------------------------
-- Check_Applicable_Policy --
-----------------------------
......
gcc/ada/sem_prag.ads
......@@ -231,17 +231,6 @@ package Sem_Prag is
procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id);
-- Perform preanalysis of pragma Test_Case
procedure Build_Generic_Class_Condition
(Subp : Entity_Id;
Prag : Node_Id);
-- AI12-113 modifies the semantics of classwide pre- and postconditions,
-- as well as type invariants, so that the expression used in an inherited
-- operation uses the actual type and is statically bound, rather than
-- using T'Class and dispatching. This new semantics is implemented by
-- building a generic function for the corresponding condition and
-- instantiating it for each descendant type. Checking the condition is
-- implemented as a call to that instantiation.
procedure Check_Applicable_Policy (N : Node_Id);
-- N is either an N_Aspect or an N_Pragma node. There are two cases. If
-- the name of the aspect or pragma is not one of those recognized as
......
gcc/ada/sem_res.adb
......@@ -8110,6 +8110,7 @@ package body Sem_Res is
end if;
Analyze_Dimension (N);
-- Note: No Eval processing is required for an explicit dereference,
-- because such a name can never be static.
......@@ -8166,6 +8167,7 @@ package body Sem_Res is
Indexes := Parameter_Associations (Call);
Pref := Remove_Head (Indexes);
Set_Expressions (N, Indexes);
Set_Generalized_Indexing (N, Empty);
Set_Prefix (N, Pref);
end if;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment