+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.
-- 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
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 |
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,
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;
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,
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;
-- 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:
-- --
-- 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- --
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);
-- 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
-- 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
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 --
--------------------------------
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 --
----------------------------
Check_Component;
Set_Etype (N, Universal_Integer);
+ -----------------
+ -- First_Valid --
+ -----------------
+
+ when Attribute_First_Valid =>
+ Check_First_Last_Valid;
+ Set_Etype (N, P_Type);
+
-----------------
-- Fixed_Value --
-----------------
Check_Component;
Set_Etype (N, Universal_Integer);
+ ----------------
+ -- Last_Valid --
+ ----------------
+
+ when Attribute_Last_Valid =>
+ Check_First_Last_Valid;
+ Set_Etype (N, P_Type);
+
------------------
-- Leading_Part --
------------------
----------------------
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
------------------
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
-- 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
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 --
-----------------
-- Last --
----------
- when Attribute_Last => Last :
+ when Attribute_Last => Last_Attr :
begin
Set_Bounds;
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 --
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
-- --
-- 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- --
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);
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);
-----------------------------------
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);
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;
-------------------
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);
-- 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;
-- 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);
-- --
-- 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- --
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
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
-- --
-- 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- --
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
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
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 + $;
Attribute_Fast_Math,
Attribute_First,
Attribute_First_Bit,
+ Attribute_First_Valid,
Attribute_Fixed_Value,
Attribute_Fore,
Attribute_Has_Access_Values,
Attribute_Large,
Attribute_Last,
Attribute_Last_Bit,
+ Attribute_Last_Valid,
Attribute_Leading_Part,
Attribute_Length,
Attribute_Machine_Emax,
projects / gcc.git / commitdiff