Skip to content

R
riscv-gcc-1
Commit 804670f1 by Arnaud Charlet
Options

[multiple changes] 

2012-04-02  Emmanuel Briot  <briot@adacore.com>

	* g-expect.adb (Expect_Internal): Fix leak of the input file descriptor.

2012-04-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb (Expand_N_Quantified_Expression): Reimplemented.
	The expansion no longer uses the copy of the original QE created
	during analysis.
	* sem.adb (Analyze): Add processing for loop parameter specifications.
	* sem_ch4.adb (Analyze_Quantified_Expression): Reimplemented. The
	routine no longer creates a copy of the original QE. All
	constituents of a QE are now preanalyzed and resolved.
	* sem_ch5.adb (Analyze_Iteration_Scheme): Remove the guard which
	bypasses all processing when the iteration scheme is related to a
	QE. Relovate the code which analyzes loop parameter specifications
	to a separate routine.	(Analyze_Iterator_Specification):
	Preanalyze the iterator name. This action was originally
	done in Analyze_Iteration_Scheme. Update the check which
	detects an iterator specification in the context of a QE.
	(Analyze_Loop_Parameter_Specification): New routine. This
	procedure allows for a stand-alone analysis of a loop parameter
	specification without the need of a parent iteration scheme. Add
	code to update the type of the loop variable when the range
	generates an itype and the context is a QE.
	(Pre_Analyze_Range): Renamed to Preanalyze_Range. Update all references
	to the routine.
	* sem_ch5.ads: Code reformatting.
	(Analyze_Loop_Parameter_Specification): New routine.
	* sem_ch6.adb (Fully_Conformant_Expressions): Detect a case
	when establishing conformance between two QEs utilizing different
	specifications.
	* sem_res.adb (Proper_Current_Scope): New routine.
	(Resolve): Do not resolve a QE as there is nothing to be done now.
	Ignore any loop scopes generated for QEs when detecting an expression
	function as the scopes are cosmetic and do not appear in the tree.
	(Resolve_Quantified_Expression): Removed. All resolution of
	QE constituents is now performed during analysis. This ensures
	that loop variables appearing in array aggregates are properly
	resolved.

2012-04-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_util.adb (Build_Default_Subtype): If the base type is
	private and its full view is available, use the full view in
	the subtype declaration.

From-SVN: r186074
parent a7942a0e
Showing with 196 additions and 176 deletions
gcc/ada/ChangeLog
2012-04-02 Emmanuel Briot <briot@adacore.com>
* g-expect.adb (Expect_Internal): Fix leak of the input file descriptor.
2012-04-02 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch4.adb (Expand_N_Quantified_Expression): Reimplemented.
The expansion no longer uses the copy of the original QE created
during analysis.
* sem.adb (Analyze): Add processing for loop parameter specifications.
* sem_ch4.adb (Analyze_Quantified_Expression): Reimplemented. The
routine no longer creates a copy of the original QE. All
constituents of a QE are now preanalyzed and resolved.
* sem_ch5.adb (Analyze_Iteration_Scheme): Remove the guard which
bypasses all processing when the iteration scheme is related to a
QE. Relovate the code which analyzes loop parameter specifications
to a separate routine. (Analyze_Iterator_Specification):
Preanalyze the iterator name. This action was originally
done in Analyze_Iteration_Scheme. Update the check which
detects an iterator specification in the context of a QE.
(Analyze_Loop_Parameter_Specification): New routine. This
procedure allows for a stand-alone analysis of a loop parameter
specification without the need of a parent iteration scheme. Add
code to update the type of the loop variable when the range
generates an itype and the context is a QE.
(Pre_Analyze_Range): Renamed to Preanalyze_Range. Update all references
to the routine.
* sem_ch5.ads: Code reformatting.
(Analyze_Loop_Parameter_Specification): New routine.
* sem_ch6.adb (Fully_Conformant_Expressions): Detect a case
when establishing conformance between two QEs utilizing different
specifications.
* sem_res.adb (Proper_Current_Scope): New routine.
(Resolve): Do not resolve a QE as there is nothing to be done now.
Ignore any loop scopes generated for QEs when detecting an expression
function as the scopes are cosmetic and do not appear in the tree.
(Resolve_Quantified_Expression): Removed. All resolution of
QE constituents is now performed during analysis. This ensures
that loop variables appearing in array aggregates are properly
resolved.
2012-04-02 Ed Schonberg <schonberg@adacore.com>
* sem_util.adb (Build_Default_Subtype): If the base type is
private and its full view is available, use the full view in
the subtype declaration.
2012-04-02 Jose Ruiz <ruiz@adacore.com> 2012-04-02 Jose Ruiz <ruiz@adacore.com>
* gnat_ugn.texi: Add some minimal documentation about how to * gnat_ugn.texi: Add some minimal documentation about how to
......
gcc/ada/exp_ch4.adb
...@@ -7884,73 +7884,78 @@ package body Exp_Ch4 is ...@@ -7884,73 +7884,78 @@ package body Exp_Ch4 is
-- given by an iterator specification, not a loop parameter specification. -- given by an iterator specification, not a loop parameter specification.
procedure Expand_N_Quantified_Expression (N : Node_Id) is procedure Expand_N_Quantified_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); Actions : constant List_Id := New_List;
Is_Universal : constant Boolean := All_Present (N); For_All : constant Boolean := All_Present (N);
Actions : constant List_Id := New_List; Iter_Spec : constant Node_Id := Iterator_Specification (N);
Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); Loc : constant Source_Ptr := Sloc (N);
Cond : Node_Id; Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N);
Decl : Node_Id; Cond : Node_Id;
I_Scheme : Node_Id; Flag : Entity_Id;
Original_N : Node_Id; Scheme : Node_Id;
Test : Node_Id; Stmts : List_Id;
begin begin
-- Retrieve the original quantified expression (non analyzed) -- Create the declaration of the flag which tracks the status of the
-- quantified expression. Generate:
if Present (Loop_Parameter_Specification (N)) then -- Flag : Boolean := (True | False);
Original_N := Parent (Parent (Loop_Parameter_Specification (N)));
else
Original_N := Parent (Parent (Iterator_Specification (N)));
end if;
-- Rewrite N with the original quantified expression Flag := Make_Temporary (Loc, 'T', N);
Rewrite (N, Original_N); Append_To (Actions,
Decl :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Tnn, Defining_Identifier => Flag,
Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
Expression => Expression =>
New_Occurrence_Of (Boolean_Literals (Is_Universal), Loc)); New_Occurrence_Of (Boolean_Literals (For_All), Loc)));
Append_To (Actions, Decl);
-- Construct the circuitry which tracks the status of the quantified
-- expression. Generate:
-- if [not] Cond then
-- Flag := (False | True);
-- exit;
-- end if;
Cond := Relocate_Node (Condition (N)); Cond := Relocate_Node (Condition (N));
if Is_Universal then if For_All then
Cond := Make_Op_Not (Loc, Cond); Cond := Make_Op_Not (Loc, Cond);
end if; end if;
Test := Stmts := New_List (
Make_Implicit_If_Statement (N, Make_Implicit_If_Statement (N,
Condition => Cond, Condition => Cond,
Then_Statements => New_List ( Then_Statements => New_List (
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Tnn, Loc), Name => New_Occurrence_Of (Flag, Loc),
Expression => Expression =>
New_Occurrence_Of (Boolean_Literals (not Is_Universal), Loc)), New_Occurrence_Of (Boolean_Literals (not For_All), Loc)),
Make_Exit_Statement (Loc))); Make_Exit_Statement (Loc))));
if Present (Loop_Parameter_Specification (N)) then -- Build the loop equivalent of the quantified expression
I_Scheme :=
if Present (Iter_Spec) then
Scheme :=
Make_Iteration_Scheme (Loc, Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification => Iterator_Specification => Iter_Spec);
Loop_Parameter_Specification (N));
else else
I_Scheme := Scheme :=
Make_Iteration_Scheme (Loc, Make_Iteration_Scheme (Loc,
Iterator_Specification => Iterator_Specification (N)); Loop_Parameter_Specification => Loop_Spec);
end if; end if;
Append_To (Actions, Append_To (Actions,
Make_Loop_Statement (Loc, Make_Loop_Statement (Loc,
Iteration_Scheme => I_Scheme, Iteration_Scheme => Scheme,
Statements => New_List (Test), Statements => Stmts,
End_Label => Empty)); End_Label => Empty));
-- Transform the quantified expression
Rewrite (N, Rewrite (N,
Make_Expression_With_Actions (Loc, Make_Expression_With_Actions (Loc,
Expression => New_Occurrence_Of (Tnn, Loc), Expression => New_Occurrence_Of (Flag, Loc),
Actions => Actions)); Actions => Actions));
Analyze_And_Resolve (N, Standard_Boolean); Analyze_And_Resolve (N, Standard_Boolean);
......
gcc/ada/g-expect.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2000-2011, AdaCore -- -- Copyright (C) 2000-2012, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -33,7 +33,7 @@ with System; use System; ...@@ -33,7 +33,7 @@ with System; use System;
with System.OS_Constants; use System.OS_Constants; with System.OS_Constants; use System.OS_Constants;
with Ada.Calendar; use Ada.Calendar; with Ada.Calendar; use Ada.Calendar;
with GNAT.IO; with GNAT.IO; use GNAT.IO;
with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Regpat; use GNAT.Regpat; with GNAT.Regpat; use GNAT.Regpat;
...@@ -678,6 +678,7 @@ package body GNAT.Expect is ...@@ -678,6 +678,7 @@ package body GNAT.Expect is
-- ??? Note that ddd tries again up to three times -- ??? Note that ddd tries again up to three times
-- in that case. See LiterateA.C:174 -- in that case. See LiterateA.C:174
Close (Descriptors (D).Input_Fd);
Descriptors (D).Input_Fd := Invalid_FD; Descriptors (D).Input_Fd := Invalid_FD;
Result := Expect_Process_Died; Result := Expect_Process_Died;
return; return;
...@@ -893,7 +894,8 @@ package body GNAT.Expect is ...@@ -893,7 +894,8 @@ package body GNAT.Expect is
begin begin
Non_Blocking_Spawn Non_Blocking_Spawn
(Process, Command, Arguments, Err_To_Out => Err_To_Out); (Process, Command, Arguments, Err_To_Out => Err_To_Out,
Buffer_Size => 0);
if Input'Length > 0 then if Input'Length > 0 then
Send (Process, Input); Send (Process, Input);
...@@ -1055,17 +1057,18 @@ package body GNAT.Expect is ...@@ -1055,17 +1057,18 @@ package body GNAT.Expect is
Command_With_Path : String_Access; Command_With_Path : String_Access;
begin begin
-- Create the rest of the pipes
Set_Up_Communications
(Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
Command_With_Path := Locate_Exec_On_Path (Command); Command_With_Path := Locate_Exec_On_Path (Command);
if Command_With_Path = null then if Command_With_Path = null then
raise Invalid_Process; raise Invalid_Process;
end if; end if;
-- Create the rest of the pipes once we know we will be able to
-- execute the process.
Set_Up_Communications
(Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
-- Fork a new process -- Fork a new process
Descriptor.Pid := Fork; Descriptor.Pid := Fork;
...@@ -1365,6 +1368,8 @@ package body GNAT.Expect is ...@@ -1365,6 +1368,8 @@ package body GNAT.Expect is
end if; end if;
if Create_Pipe (Pipe2) /= 0 then if Create_Pipe (Pipe2) /= 0 then
Close (Pipe1.Input);
Close (Pipe1.Output);
return; return;
end if; end if;
...@@ -1389,7 +1394,7 @@ package body GNAT.Expect is ...@@ -1389,7 +1394,7 @@ package body GNAT.Expect is
-- Create a separate pipe for standard error -- Create a separate pipe for standard error
if Create_Pipe (Pipe3) /= 0 then if Create_Pipe (Pipe3) /= 0 then
return; Pipe3.all := Pipe2.all;
end if; end if;
end if; end if;
......
gcc/ada/sem.adb
...@@ -314,6 +314,9 @@ package body Sem is ...@@ -314,6 +314,9 @@ package body Sem is
when N_Label => when N_Label =>
Analyze_Label (N); Analyze_Label (N);
when N_Loop_Parameter_Specification =>
Analyze_Loop_Parameter_Specification (N);
when N_Loop_Statement => when N_Loop_Statement =>
Analyze_Loop_Statement (N); Analyze_Loop_Statement (N);
...@@ -681,7 +684,6 @@ package body Sem is ...@@ -681,7 +684,6 @@ package body Sem is
N_Generic_Association | N_Generic_Association |
N_Index_Or_Discriminant_Constraint | N_Index_Or_Discriminant_Constraint |
N_Iteration_Scheme | N_Iteration_Scheme |
N_Loop_Parameter_Specification |
N_Mod_Clause | N_Mod_Clause |
N_Modular_Type_Definition | N_Modular_Type_Definition |
N_Ordinary_Fixed_Point_Definition | N_Ordinary_Fixed_Point_Definition |
......
gcc/ada/sem_ch4.adb
...@@ -47,7 +47,6 @@ with Sem_Aux; use Sem_Aux; ...@@ -47,7 +47,6 @@ with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case; with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat; with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3; with Sem_Ch3; use Sem_Ch3;
with Sem_Ch5; use Sem_Ch5;
with Sem_Ch6; use Sem_Ch6; with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8; with Sem_Ch8; use Sem_Ch8;
with Sem_Dim; use Sem_Dim; with Sem_Dim; use Sem_Dim;
...@@ -3403,101 +3402,38 @@ package body Sem_Ch4 is ...@@ -3403,101 +3402,38 @@ package body Sem_Ch4 is
----------------------------------- -----------------------------------
procedure Analyze_Quantified_Expression (N : Node_Id) is procedure Analyze_Quantified_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); QE_Scop : Entity_Id;
Ent : constant Entity_Id :=
New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L');
Need_Preanalysis : constant Boolean :=
Operating_Mode /= Check_Semantics
and then not Alfa_Mode;
Iterator : Node_Id;
Original_N : Node_Id;
begin begin
-- The approach in this procedure is very non-standard and at the
-- very least, extensive comments are required saying why this very
-- non-standard approach is needed???
-- Also general comments are needed in any case saying what is going
-- on here, since tree rewriting of this kind should normally be done
-- by the expander and not by the analyzer ??? Probably Ent, Iterator,
-- and Original_N, and Needs_Preanalysis, all need comments above ???
-- Preserve the original node used for the expansion of the quantified
-- expression.
-- This is a very unusual use of Copy_Separate_Tree, needs looking at???
if Need_Preanalysis then
Original_N := Copy_Separate_Tree (N);
end if;
Set_Etype (Ent, Standard_Void_Type);
Set_Scope (Ent, Current_Scope);
Set_Parent (Ent, N);
Check_SPARK_Restriction ("quantified expression is not allowed", N); Check_SPARK_Restriction ("quantified expression is not allowed", N);
-- The following seems like expansion activity done at analysis -- Create a scope to emulate the loop-like behavior of the quantified
-- time, which seems weird ??? -- expression. The scope is needed to provide proper visibility of the
-- loop variable.
if Present (Loop_Parameter_Specification (N)) then QE_Scop := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L');
Iterator := Set_Etype (QE_Scop, Standard_Void_Type);
Make_Iteration_Scheme (Loc, Set_Scope (QE_Scop, Current_Scope);
Loop_Parameter_Specification => Set_Parent (QE_Scop, N);
Loop_Parameter_Specification (N));
else
Iterator :=
Make_Iteration_Scheme (Loc,
Iterator_Specification =>
Iterator_Specification (N));
end if;
Push_Scope (Ent); Push_Scope (QE_Scop);
Set_Parent (Iterator, N);
Analyze_Iteration_Scheme (Iterator);
-- The loop specification may have been converted into an iterator -- All constituents are preanalyzed and resolved to avoid untimely
-- specification during its analysis. Update the quantified node -- generation of various temporaries and types. Full analysis and
-- accordingly. -- expansion is carried out when the quantified expression is
-- transformed into an expression with actions.
if Present (Iterator_Specification (Iterator)) then if Present (Iterator_Specification (N)) then
Set_Iterator_Specification Preanalyze (Iterator_Specification (N));
(N, Iterator_Specification (Iterator));
Set_Loop_Parameter_Specification (N, Empty);
Set_Parent (Iterator_Specification (Iterator), Iterator);
end if;
if Need_Preanalysis then
-- The full analysis will be performed during the expansion of the
-- quantified expression, only a preanalysis of the condition needs
-- to be done.
-- This is strange for two reasons
-- First, there is almost no situation in which Preanalyze vs
-- Analyze should be conditioned on -gnatc mode (since error msgs
-- must be 100% unaffected by -gnatc). Seconed doing a Preanalyze
-- with no resolution almost certainly means that some messages are
-- either missed, or flagged differently in the two cases.
Preanalyze (Condition (N));
else else
Analyze (Condition (N)); Preanalyze (Loop_Parameter_Specification (N));
end if; end if;
Preanalyze_And_Resolve (Condition (N), Standard_Boolean);
End_Scope; End_Scope;
Set_Etype (N, Standard_Boolean); Set_Etype (N, Standard_Boolean);
-- Attach the original node to the iteration scheme created above
if Need_Preanalysis then
Set_Etype (Original_N, Standard_Boolean);
Set_Parent (Iterator, Original_N);
end if;
end Analyze_Quantified_Expression; end Analyze_Quantified_Expression;
------------------- -------------------
......
gcc/ada/sem_ch5.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -27,19 +27,20 @@ with Types; use Types; ...@@ -27,19 +27,20 @@ with Types; use Types;
package Sem_Ch5 is package Sem_Ch5 is
procedure Analyze_Assignment (N : Node_Id); procedure Analyze_Assignment (N : Node_Id);
procedure Analyze_Block_Statement (N : Node_Id); procedure Analyze_Block_Statement (N : Node_Id);
procedure Analyze_Case_Statement (N : Node_Id); procedure Analyze_Case_Statement (N : Node_Id);
procedure Analyze_Exit_Statement (N : Node_Id); procedure Analyze_Exit_Statement (N : Node_Id);
procedure Analyze_Goto_Statement (N : Node_Id); procedure Analyze_Goto_Statement (N : Node_Id);
procedure Analyze_If_Statement (N : Node_Id); procedure Analyze_If_Statement (N : Node_Id);
procedure Analyze_Implicit_Label_Declaration (N : Node_Id); procedure Analyze_Implicit_Label_Declaration (N : Node_Id);
procedure Analyze_Iterator_Specification (N : Node_Id); procedure Analyze_Iterator_Specification (N : Node_Id);
procedure Analyze_Iteration_Scheme (N : Node_Id); procedure Analyze_Iteration_Scheme (N : Node_Id);
procedure Analyze_Label (N : Node_Id); procedure Analyze_Label (N : Node_Id);
procedure Analyze_Loop_Statement (N : Node_Id); procedure Analyze_Loop_Parameter_Specification (N : Node_Id);
procedure Analyze_Null_Statement (N : Node_Id); procedure Analyze_Loop_Statement (N : Node_Id);
procedure Analyze_Statements (L : List_Id); procedure Analyze_Null_Statement (N : Node_Id);
procedure Analyze_Statements (L : List_Id);
procedure Analyze_Label_Entity (E : Entity_Id); procedure Analyze_Label_Entity (E : Entity_Id);
-- This procedure performs direct analysis of the label entity E. It -- This procedure performs direct analysis of the label entity E. It
......
gcc/ada/sem_ch6.adb
...@@ -8702,7 +8702,9 @@ package body Sem_Ch6 is ...@@ -8702,7 +8702,9 @@ package body Sem_Ch6 is
Discrete_Subtype_Definition (L2)); Discrete_Subtype_Definition (L2));
end; end;
else -- quantified expression with an iterator elsif Present (Iterator_Specification (E1))
and then Present (Iterator_Specification (E2))
then
declare declare
I1 : constant Node_Id := Iterator_Specification (E1); I1 : constant Node_Id := Iterator_Specification (E1);
I2 : constant Node_Id := Iterator_Specification (E2); I2 : constant Node_Id := Iterator_Specification (E2);
...@@ -8719,6 +8721,12 @@ package body Sem_Ch6 is ...@@ -8719,6 +8721,12 @@ package body Sem_Ch6 is
and then FCE (Subtype_Indication (I1), and then FCE (Subtype_Indication (I1),
Subtype_Indication (I2)); Subtype_Indication (I2));
end; end;
-- The quantified expressions used different specifications to
-- walk their respective ranges.
else
return False;
end if; end if;
when N_Range => when N_Range =>
......
gcc/ada/sem_res.adb
...@@ -193,7 +193,6 @@ package body Sem_Res is ...@@ -193,7 +193,6 @@ package body Sem_Res is
procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id); procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id); procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Range (N : Node_Id; Typ : Entity_Id); procedure Resolve_Range (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id); procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id);
...@@ -1770,6 +1769,10 @@ package body Sem_Res is ...@@ -1770,6 +1769,10 @@ package body Sem_Res is
-- Try and fix up a literal so that it matches its expected type. New -- Try and fix up a literal so that it matches its expected type. New
-- literals are manufactured if necessary to avoid cascaded errors. -- literals are manufactured if necessary to avoid cascaded errors.
function Proper_Current_Scope return Entity_Id;
-- Return the current scope. Skip loop scopes created for the purpose of
-- quantified expression analysis since those do not appear in the tree.
procedure Report_Ambiguous_Argument; procedure Report_Ambiguous_Argument;
-- Additional diagnostics when an ambiguous call has an ambiguous -- Additional diagnostics when an ambiguous call has an ambiguous
-- argument (typically a controlling actual). -- argument (typically a controlling actual).
...@@ -1832,6 +1835,30 @@ package body Sem_Res is ...@@ -1832,6 +1835,30 @@ package body Sem_Res is
end if; end if;
end Patch_Up_Value; end Patch_Up_Value;
--------------------------
-- Proper_Current_Scope --
--------------------------
function Proper_Current_Scope return Entity_Id is
S : Entity_Id := Current_Scope;
begin
while Present (S) loop
-- Skip a loop scope created for quantified expression analysis
if Ekind (S) = E_Loop
and then Nkind (Parent (S)) = N_Quantified_Expression
then
S := Scope (S);
else
exit;
end if;
end loop;
return S;
end Proper_Current_Scope;
------------------------------- -------------------------------
-- Report_Ambiguous_Argument -- -- Report_Ambiguous_Argument --
------------------------------- -------------------------------
...@@ -2761,8 +2788,7 @@ package body Sem_Res is ...@@ -2761,8 +2788,7 @@ package body Sem_Res is
when N_Qualified_Expression when N_Qualified_Expression
=> Resolve_Qualified_Expression (N, Ctx_Type); => Resolve_Qualified_Expression (N, Ctx_Type);
when N_Quantified_Expression when N_Quantified_Expression => null;
=> Resolve_Quantified_Expression (N, Ctx_Type);
when N_Raise_xxx_Error when N_Raise_xxx_Error
=> Set_Etype (N, Ctx_Type); => Set_Etype (N, Ctx_Type);
...@@ -2857,10 +2883,9 @@ package body Sem_Res is ...@@ -2857,10 +2883,9 @@ package body Sem_Res is
-- Ada 2012 (AI05-177): Expression functions do not freeze. Only -- Ada 2012 (AI05-177): Expression functions do not freeze. Only
-- their use (in an expanded call) freezes. -- their use (in an expanded call) freezes.
if Ekind (Current_Scope) /= E_Function if Ekind (Proper_Current_Scope) /= E_Function
or else or else Nkind (Original_Node (Unit_Declaration_Node
Nkind (Original_Node (Unit_Declaration_Node (Current_Scope))) /= (Proper_Current_Scope))) /= N_Expression_Function
N_Expression_Function
then then
Freeze_Expression (N); Freeze_Expression (N);
end if; end if;
...@@ -8290,31 +8315,6 @@ package body Sem_Res is ...@@ -8290,31 +8315,6 @@ package body Sem_Res is
Eval_Qualified_Expression (N); Eval_Qualified_Expression (N);
end Resolve_Qualified_Expression; end Resolve_Qualified_Expression;
-----------------------------------
-- Resolve_Quantified_Expression --
-----------------------------------
procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id) is
begin
if not Alfa_Mode then
-- The loop structure is already resolved during its analysis, only
-- the resolution of the condition needs to be done. Expansion is
-- disabled so that checks and other generated code are inserted in
-- the tree after expression has been rewritten as a loop.
Expander_Mode_Save_And_Set (False);
Resolve (Condition (N), Typ);
Expander_Mode_Restore;
-- In Alfa mode, we need normal expansion in order to properly introduce
-- the necessary transient scopes.
else
Resolve (Condition (N), Typ);
end if;
end Resolve_Quantified_Expression;
------------------- -------------------
-- Resolve_Range -- -- Resolve_Range --
------------------- -------------------
......
gcc/ada/sem_util.adb
...@@ -740,12 +740,28 @@ package body Sem_Util is ...@@ -740,12 +740,28 @@ package body Sem_Util is
N : Node_Id) return Entity_Id N : Node_Id) return Entity_Id
is is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Bas : Entity_Id;
-- The base type that is to be constrained by the defaults.
Disc : Entity_Id; Disc : Entity_Id;
begin begin
if not Has_Discriminants (T) or else Is_Constrained (T) then if not Has_Discriminants (T) or else Is_Constrained (T) then
return T; return T;
end if; end if;
Bas := Base_Type (T);
-- If T is non-private but its base type is private, this is
-- the completion of a subtype declaration whose parent type
-- is private (see Complete_Private_Subtype in sem_ch3). The
-- proper discriminants are to be found in the full view of
-- the base.
if Is_Private_Type (Bas)
and then Present (Full_View (Bas))
then
Bas := Full_View (Bas);
end if;
Disc := First_Discriminant (T); Disc := First_Discriminant (T);
...@@ -770,7 +786,7 @@ package body Sem_Util is ...@@ -770,7 +786,7 @@ package body Sem_Util is
Defining_Identifier => Act, Defining_Identifier => Act,
Subtype_Indication => Subtype_Indication =>
Make_Subtype_Indication (Loc, Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (T, Loc), Subtype_Mark => New_Occurrence_Of (Bas, Loc),
Constraint => Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constraints))); Constraints => Constraints)));
......
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