[multiple changes]

2012-03-15  Robert Dewar  <dewar@adacore.com>

	* par-ch6.adb, einfo.ads, sem_eval.adb, sem_eval.ads,
	sem_case.adb: Minor reformatting.

2012-03-15  Robert Dewar  <dewar@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference): Add handling
	of First_Valid/Last_Valid.
	* sem_attr.adb (Check_First_Last_Valid): New procedure
	(Analyze_Attribute): Add handling of First_Valid and Last_Valid
	(Eval_Attribute): ditto.
	* snames.ads-tmpl: Add entries for First_Valid and Last_Valid.

2012-03-15  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch5.adb (Expand_Predicated_Loop): Suppress warnings on
	loop variable, for the unusual case where the range has a single
	element and the loop variable has no visible assignment to it.

2012-03-15  Vincent Pucci  <pucci@adacore.com>

	* exp_ch4.adb (Expand_N_Quantified_Expression): Expand the
	original quantified expression node.
	* sem_ch4.adb (Analyze_Quantified_Expression): Properly analyze
	the quantified expression and preserve the original non-analyzed
	quantified expression when an expansion is needed.
	* sem_ch5.adb (Analyze_Iteration_Scheme): Special treatment
	for quantified expressions.
	(Analyze_Iterator_Specification): Special treatment for quantified
	expressions.

2012-03-15  Ed Falis  <falis@adacore.com>

	* s-vxwork-ppc.ads: Update FP_CONTEXT so name of former pad
	field matches VxWorks headers.

From-SVN: r185409
This commit is contained in:
Arnaud Charlet 2012-03-15 09:39:05 +01:00
parent 5457d860af
commit 011f9d5d67
14 changed files with 282 additions and 81 deletions

View File

@ -1,3 +1,40 @@
2012-03-15 Robert Dewar <dewar@adacore.com>
* par-ch6.adb, einfo.ads, sem_eval.adb, sem_eval.ads,
sem_case.adb: Minor reformatting.
2012-03-15 Robert Dewar <dewar@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference): Add handling
of First_Valid/Last_Valid.
* sem_attr.adb (Check_First_Last_Valid): New procedure
(Analyze_Attribute): Add handling of First_Valid and Last_Valid
(Eval_Attribute): ditto.
* snames.ads-tmpl: Add entries for First_Valid and Last_Valid.
2012-03-15 Ed Schonberg <schonberg@adacore.com>
* exp_ch5.adb (Expand_Predicated_Loop): Suppress warnings on
loop variable, for the unusual case where the range has a single
element and the loop variable has no visible assignment to it.
2012-03-15 Vincent Pucci <pucci@adacore.com>
* exp_ch4.adb (Expand_N_Quantified_Expression): Expand the
original quantified expression node.
* sem_ch4.adb (Analyze_Quantified_Expression): Properly analyze
the quantified expression and preserve the original non-analyzed
quantified expression when an expansion is needed.
* sem_ch5.adb (Analyze_Iteration_Scheme): Special treatment
for quantified expressions.
(Analyze_Iterator_Specification): Special treatment for quantified
expressions.
2012-03-15 Ed Falis <falis@adacore.com>
* s-vxwork-ppc.ads: Update FP_CONTEXT so name of former pad
field matches VxWorks headers.
2012-03-14 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* gcc-interface/Makefile.in (mips-sgi-irix6*): Remove.

View File

@ -3682,13 +3682,14 @@ package Einfo is
-- Static_Predicate (List25)
-- Present in discrete types/subtypes with predicates (Has_Predicates
-- set True). Points to a list of expression and N_Range nodes that
-- represent the predicate in canonical form. The canonical form has
-- entries sorted in ascending order, with all duplicates eliminated,
-- and adjacent ranges coalesced, so that there is always a gap in the
-- values between successive entries. The entries in this list are
-- fully analyzed and typed with the base type of the subtype. Note
-- that all entries are static and have values within the subtype range.
-- set True). Set if the type/subtype has a static predicate. Points to
-- a list of expression and N_Range nodes that represent the predicate
-- in canonical form. The canonical form has entries sorted in ascending
-- order, with duplicates eliminated, and adjacent ranges coalesced, so
-- that there is always a gap in the values between successive entries.
-- The entries in this list are fully analyzed and typed with the base
-- type of the subtype. Note that all entries are static and have values
-- within the subtype range.
-- Storage_Size_Variable (Node15) [implementation base type only]
-- Present in access types and task type entities. This flag is set

View File

@ -5701,10 +5701,12 @@ package body Exp_Attr is
Attribute_Enabled |
Attribute_Epsilon |
Attribute_Fast_Math |
Attribute_First_Valid |
Attribute_Has_Access_Values |
Attribute_Has_Discriminants |
Attribute_Has_Tagged_Values |
Attribute_Large |
Attribute_Last_Valid |
Attribute_Machine_Emax |
Attribute_Machine_Emin |
Attribute_Machine_Mantissa |

View File

@ -7891,9 +7891,22 @@ package body Exp_Ch4 is
Cond : Node_Id;
Decl : Node_Id;
I_Scheme : Node_Id;
Original_N : Node_Id;
Test : Node_Id;
begin
-- Retrieve the original quantified expression (non analyzed)
if Present (Loop_Parameter_Specification (N)) then
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
Rewrite (N, Original_N);
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Tnn,
@ -7904,13 +7917,6 @@ package body Exp_Ch4 is
Cond := Relocate_Node (Condition (N));
-- Reset flag analyzed in the condition to force its analysis. Required
-- since the previous analysis was done with expansion disabled (see
-- Resolve_Quantified_Expression) and hence checks were not inserted
-- and record comparisons have not been expanded.
Reset_Analyzed_Flags (Cond);
if Is_Universal then
Cond := Make_Op_Not (Loc, Cond);
end if;
@ -7926,9 +7932,14 @@ package body Exp_Ch4 is
Make_Exit_Statement (Loc)));
if Present (Loop_Parameter_Specification (N)) then
I_Scheme := Relocate_Node (Parent (Loop_Parameter_Specification (N)));
I_Scheme :=
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Loop_Parameter_Specification (N));
else
I_Scheme := Relocate_Node (Parent (Iterator_Specification (N)));
I_Scheme :=
Make_Iteration_Scheme (Loc,
Iterator_Specification => Iterator_Specification (N));
end if;
Append_To (Actions,

View File

@ -3759,6 +3759,14 @@ package body Exp_Ch5 is
Set_Analyzed (Loop_Id, False);
Set_Ekind (Loop_Id, E_Variable);
-- In most loops the loop variable is assigned in various
-- alternatives in the body. However, in the rare case when
-- the range specifies a single element, the loop variable
-- may trigger a spurious warning that is could be constant.
-- This warning might as well be suppressed.
Set_Warnings_Off (Loop_Id);
-- Loop to create branches of case statement
Alts := New_List;

View File

@ -128,7 +128,8 @@ package body Ch6 is
-- other subprogram constructs.
-- EXPRESSION_FUNCTION ::=
-- FUNCTION SPECIFICATION IS (EXPRESSION);
-- FUNCTION SPECIFICATION IS (EXPRESSION)
-- [ASPECT_SPECIFICATIONS];
-- The value in Pf_Flags indicates which of these possible declarations
-- is acceptable to the caller:

View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1998-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2011, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -44,9 +44,9 @@ package System.VxWorks is
type Fpr_Array is array (1 .. FP_NUM_DREGS) of IC.double;
type FP_CONTEXT is record
fpr : Fpr_Array;
fpcsr : IC.int;
pad : IC.int;
fpr : Fpr_Array;
fpcsr : IC.int;
fpcsrCopy : IC.int;
end record;
pragma Convention (C, FP_CONTEXT);

View File

@ -217,9 +217,13 @@ package body Sem_Attr is
-- allowed with a type that has predicates. If the type is a generic
-- actual, then the message is a warning, and we generate code to raise
-- program error with an appropriate reason. No error message is given
-- for internally generated uses of the attributes.
-- The legality rule only applies to scalar types, even though the
-- current AI mentions all subtypes.
-- for internally generated uses of the attributes. This legality rule
-- only applies to scalar types.
procedure Check_Ada_2012_Attribute;
-- Check that we are in Ada 2012 mode for an Ada 2012 attribute, and
-- issue appropriate messages if not (and return to caller even in
-- the error case).
procedure Check_Array_Or_Scalar_Type;
-- Common procedure used by First, Last, Range attribute to check
@ -270,6 +274,9 @@ package body Sem_Attr is
-- reference when analyzing an inlined body will lose a proper warning
-- on a useless with_clause.
procedure Check_First_Last_Valid;
-- Perform all checks for First_Valid and Last_Valid attributes
procedure Check_Fixed_Point_Type;
-- Verify that prefix of attribute N is a fixed type
@ -862,6 +869,21 @@ package body Sem_Attr is
end if;
end Bad_Attribute_For_Predicate;
------------------------------
-- Check_Ada_2012_Attribute --
------------------------------
procedure Check_Ada_2012_Attribute is
begin
if Ada_Version < Ada_2012 then
Error_Msg_Name_1 := Aname;
Error_Msg_N
("attribute % is an Ada 2012 feature", N);
Error_Msg_N
("\unit must be compiled with -gnat2012 switch", N);
end if;
end Check_Ada_2012_Attribute;
--------------------------------
-- Check_Array_Or_Scalar_Type --
--------------------------------
@ -1244,6 +1266,37 @@ package body Sem_Attr is
end if;
end Check_Enum_Image;
----------------------------
-- Check_First_Last_Valid --
----------------------------
procedure Check_First_Last_Valid is
begin
Check_Ada_2012_Attribute;
Check_Discrete_Type;
if not Is_Static_Subtype (P_Type) then
Error_Attr_P ("prefix of % attribute must be a static subtype");
end if;
if Has_Predicates (P_Type)
and then No (Static_Predicate (P_Type))
then
Error_Attr_P
("prefix of % attribute may not have dynamic predicate");
end if;
if Expr_Value (Type_Low_Bound (P_Type)) >
Expr_Value (Type_High_Bound (P_Type))
or else (Has_Predicates (P_Type)
and then Is_Empty_List (Static_Predicate (P_Type)))
then
Error_Attr_P
("prefix of % attribute must be subtype with "
& "at least one value");
end if;
end Check_First_Last_Valid;
----------------------------
-- Check_Fixed_Point_Type --
----------------------------
@ -3240,6 +3293,14 @@ package body Sem_Attr is
Check_Component;
Set_Etype (N, Universal_Integer);
-----------------
-- First_Valid --
-----------------
when Attribute_First_Valid =>
Check_First_Last_Valid;
Set_Etype (N, P_Type);
-----------------
-- Fixed_Value --
-----------------
@ -3456,6 +3517,14 @@ package body Sem_Attr is
Check_Component;
Set_Etype (N, Universal_Integer);
----------------
-- Last_Valid --
----------------
when Attribute_Last_Valid =>
Check_First_Last_Valid;
Set_Etype (N, P_Type);
------------------
-- Leading_Part --
------------------
@ -3928,12 +3997,7 @@ package body Sem_Attr is
----------------------
when Attribute_Overlaps_Storage =>
if Ada_Version < Ada_2012 then
Error_Msg_N
("attribute Overlaps_Storage is an Ada 2012 feature", N);
Error_Msg_N
("\unit must be compiled with -gnat2012 switch", N);
end if;
Check_Ada_2012_Attribute;
Check_E1;
-- Both arguments must be objects of any type
@ -4425,13 +4489,7 @@ package body Sem_Attr is
------------------
when Attribute_Same_Storage =>
if Ada_Version < Ada_2012 then
Error_Msg_N
("attribute Same_Storage is an Ada 2012 feature", N);
Error_Msg_N
("\unit must be compiled with -gnat2012 switch", N);
end if;
Check_Ada_2012_Attribute;
Check_E1;
-- The arguments must be objects of any type
@ -5388,10 +5446,11 @@ package body Sem_Attr is
-- Used for First, Last and Length attributes applied to an array or
-- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low
-- and high bound expressions for the index referenced by the attribute
-- designator (i.e. the first index if no expression is present, and
-- the N'th index if the value N is present as an expression). Also
-- used for First and Last of scalar types. Static is reset to False
-- if the type or index type is not statically constrained.
-- designator (i.e. the first index if no expression is present, and the
-- N'th index if the value N is present as an expression). Also used for
-- First and Last of scalar types and for First_Valid and Last_Valid.
-- Static is reset to False if the type or index type is not statically
-- constrained.
function Statically_Denotes_Entity (N : Node_Id) return Boolean;
-- Verify that the prefix of a potentially static array attribute
@ -6459,6 +6518,31 @@ package body Sem_Attr is
end if;
end First_Attr;
-----------------
-- First_Valid --
-----------------
when Attribute_First_Valid => First_Valid :
begin
if Has_Predicates (P_Type)
and then Present (Static_Predicate (P_Type))
then
declare
FirstN : constant Node_Id := First (Static_Predicate (P_Type));
begin
if Nkind (FirstN) = N_Range then
Fold_Uint (N, Expr_Value (Low_Bound (FirstN)), Static);
else
Fold_Uint (N, Expr_Value (FirstN), Static);
end if;
end;
else
Set_Bounds;
Fold_Uint (N, Expr_Value (Lo_Bound), Static);
end if;
end First_Valid;
-----------------
-- Fixed_Value --
-----------------
@ -6634,7 +6718,7 @@ package body Sem_Attr is
-- Last --
----------
when Attribute_Last => Last :
when Attribute_Last => Last_Attr :
begin
Set_Bounds;
@ -6658,7 +6742,32 @@ package body Sem_Attr is
else
Check_Concurrent_Discriminant (Hi_Bound);
end if;
end Last;
end Last_Attr;
----------------
-- Last_Valid --
----------------
when Attribute_Last_Valid => Last_Valid :
begin
if Has_Predicates (P_Type)
and then Present (Static_Predicate (P_Type))
then
declare
LastN : constant Node_Id := Last (Static_Predicate (P_Type));
begin
if Nkind (LastN) = N_Range then
Fold_Uint (N, Expr_Value (High_Bound (LastN)), Static);
else
Fold_Uint (N, Expr_Value (LastN), Static);
end if;
end;
else
Set_Bounds;
Fold_Uint (N, Expr_Value (Hi_Bound), Static);
end if;
end Last_Valid;
------------------
-- Leading_Part --
@ -8568,14 +8677,13 @@ package body Sem_Attr is
if Ada_Version >= Ada_2005
and then (Is_Local_Anonymous_Access (Btyp)
-- Handle cases where Btyp is the
-- anonymous access type of an Ada 2012
-- stand-alone object.
-- Handle cases where Btyp is the anonymous access
-- type of an Ada 2012 stand-alone object.
or else Nkind (Associated_Node_For_Itype (Btyp)) =
N_Object_Declaration)
and then Object_Access_Level (P)
> Deepest_Type_Access_Level (Btyp)
and then
Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
and then Attr_Id = Attribute_Access
then
-- In an instance, this is a runtime check, but one we

View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1996-2012, 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- --
@ -530,8 +530,8 @@ package body Sem_Case is
begin
if Case_Table'Last = 0 then
-- Special case: only an others case is present.
-- The others case covers the full range of the type.
-- Special case: only an others case is present. The others case
-- covers the full range of the type.
if Is_Static_Subtype (Choice_Type) then
Choice := New_Occurrence_Of (Choice_Type, Loc);
@ -543,8 +543,8 @@ package body Sem_Case is
return;
end if;
-- Establish the bound values for the choice depending upon whether
-- the type of the case statement is static or not.
-- Establish the bound values for the choice depending upon whether the
-- type of the case statement is static or not.
if Is_OK_Static_Subtype (Choice_Type) then
Exp_Lo := Type_Low_Bound (Choice_Type);

View File

@ -3390,14 +3390,25 @@ package body Sem_Ch4 is
-----------------------------------
procedure Analyze_Quantified_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ent : constant Entity_Id :=
New_Internal_Entity
(E_Loop, Current_Scope, Sloc (N), 'L');
Loc : constant Source_Ptr := Sloc (N);
Ent : constant Entity_Id :=
New_Internal_Entity
(E_Loop, Current_Scope, Sloc (N), 'L');
Needs_Expansion : constant Boolean :=
Operating_Mode /= Check_Semantics
and then not Alfa_Mode;
Iterator : Node_Id;
Iterator : Node_Id;
Original_N : Node_Id;
begin
-- Preserve the original node used for the expansion of the quantified
-- expression.
if Needs_Expansion then
Original_N := Copy_Separate_Tree (N);
end if;
Set_Etype (Ent, Standard_Void_Type);
Set_Scope (Ent, Current_Scope);
Set_Parent (Ent, N);
@ -3433,7 +3444,15 @@ package body Sem_Ch4 is
Analyze (Condition (N));
End_Scope;
Set_Etype (N, Standard_Boolean);
-- Attach the original node to the iteration scheme created above
if Needs_Expansion then
Set_Etype (Original_N, Standard_Boolean);
Set_Parent (Iterator, Original_N);
end if;
end Analyze_Quantified_Expression;
-------------------

View File

@ -2087,7 +2087,17 @@ package body Sem_Ch5 is
Check_Controlled_Array_Attribute (DS);
Make_Index (DS, LP, In_Iter_Schm => True);
-- The index is not processed during the analysis of a
-- quantified expression but delayed to its expansion where the
-- quantified expression is transformed into an expression with
-- actions.
if Nkind (Parent (N)) /= N_Quantified_Expression
or else Operating_Mode = Check_Semantics
or else Alfa_Mode
then
Make_Index (DS, LP, In_Iter_Schm => True);
end if;
Set_Ekind (Id, E_Loop_Parameter);
@ -2097,14 +2107,7 @@ package body Sem_Ch5 is
-- because the second one may be created in a different scope,
-- e.g. a precondition procedure, leading to a crash in GIGI.
-- Note that if the parent node is a quantified expression,
-- this preservation is delayed until the expansion of the
-- quantified expression where the node is rewritten as an
-- expression with actions.
if (No (Etype (Id)) or else Etype (Id) = Any_Type)
and then Nkind (Parent (N)) /= N_Quantified_Expression
then
if No (Etype (Id)) or else Etype (Id) = Any_Type then
Set_Etype (Id, Etype (DS));
end if;
@ -2241,14 +2244,14 @@ package body Sem_Ch5 is
-- If domain of iteration is an expression, create a declaration for
-- it, so that finalization actions are introduced outside of the loop.
-- The declaration must be a renaming because the body of the loop may
-- assign to elements.
-- Note that if the parent node is a quantified expression, this
-- declaration is created during the expansion of the quantified
-- expression where the node is rewritten as an expression with actions.
-- assign to elements. In case of a quantified expression, this
-- declaration is delayed to its expansion where the node is rewritten
-- as an expression with actions.
if not Is_Entity_Name (Iter_Name)
and then Nkind (Parent (Parent (N))) /= N_Quantified_Expression
and then (Nkind (Parent (Parent (N))) /= N_Quantified_Expression
or else Operating_Mode = Check_Semantics
or else Alfa_Mode)
then
declare
Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);

View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -4310,8 +4310,8 @@ package body Sem_Eval is
return
Ekind (Typ) = E_String_Literal_Subtype
or else
(Is_OK_Static_Subtype (Component_Type (Typ))
and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
(Is_OK_Static_Subtype (Component_Type (Typ))
and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
-- Scalar types
@ -4401,9 +4401,8 @@ package body Sem_Eval is
elsif Is_String_Type (Typ) then
return
Ekind (Typ) = E_String_Literal_Subtype
or else
(Is_Static_Subtype (Component_Type (Typ))
and then Is_Static_Subtype (Etype (First_Index (Typ))));
or else (Is_Static_Subtype (Component_Type (Typ))
and then Is_Static_Subtype (Etype (First_Index (Typ))));
-- Scalar types

View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -196,7 +196,15 @@ package Sem_Eval is
function Is_Static_Subtype (Typ : Entity_Id) return Boolean;
-- Determines whether a subtype fits the definition of an Ada static
-- subtype as given in (RM 4.9(26)).
-- subtype as given in (RM 4.9(26)). Important note: This check does not
-- include the Ada 2012 case of a non-static predicate which results in an
-- otherwise static subtype being non-static. Such a subtype will return
-- True for this test, so if the distinction is important, the caller must
-- deal with this.
--
-- Implementation note: an attempt to include this Ada 2012 case failed,
-- since it appears that this routine is called in some cases before the
-- Static_Predicate field is set ???
function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean;
-- Like Is_Static_Subtype but also makes sure that the bounds of the

View File

@ -770,6 +770,7 @@ package Snames is
Name_Fast_Math : constant Name_Id := N + $; -- GNAT
Name_First : constant Name_Id := N + $;
Name_First_Bit : constant Name_Id := N + $;
Name_First_Valid : constant Name_Id := N + $; -- Ada 12
Name_Fixed_Value : constant Name_Id := N + $; -- GNAT
Name_Fore : constant Name_Id := N + $;
Name_Has_Access_Values : constant Name_Id := N + $; -- GNAT
@ -784,6 +785,7 @@ package Snames is
Name_Large : constant Name_Id := N + $; -- Ada 83
Name_Last : constant Name_Id := N + $;
Name_Last_Bit : constant Name_Id := N + $;
Name_Last_Valid : constant Name_Id := N + $; -- Ada 12
Name_Leading_Part : constant Name_Id := N + $;
Name_Length : constant Name_Id := N + $;
Name_Machine_Emax : constant Name_Id := N + $;
@ -1332,6 +1334,7 @@ package Snames is
Attribute_Fast_Math,
Attribute_First,
Attribute_First_Bit,
Attribute_First_Valid,
Attribute_Fixed_Value,
Attribute_Fore,
Attribute_Has_Access_Values,
@ -1346,6 +1349,7 @@ package Snames is
Attribute_Large,
Attribute_Last,
Attribute_Last_Bit,
Attribute_Last_Valid,
Attribute_Leading_Part,
Attribute_Length,
Attribute_Machine_Emax,