+2013-10-10 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch3.adb (Expand_N_Variant_Part): Expand statically
+ predicated subtype which appears in Discrete_Choices list.
+ * exp_ch5.adb (Expand_N_Case_Statement): Expand statically
+ predicated subtype which appears in Discrete_Choices list of
+ case statement alternative.
+ * exp_util.ads, exp_util.adb (Expand_Static_Predicates_In_Choices): New
+ procedure.
+ * sem_case.adb: Minor reformatting (Analyze_Choices): Don't
+ expand out Discrete_Choices that are names of subtypes with
+ static predicates. This is now done in the analyzer so that the
+ -gnatct tree is properly formed for ASIS.
+ * sem_case.ads (Generic_Choices_Processing): Does not apply
+ to aggregates any more, so change doc accordingly, and remove
+ unneeded Get_Choices argument.
+ * sem_ch3.adb (Analyze_Variant_Part): Remove no
+ longer used Get_Choices argument in instantiation of
+ Generic_Choices_Processing.
+ * sem_ch4.adb (Analyze_Case_Expression): Remove no
+ longer used Get_Choices argument in instantiation of
+ Generic_Choices_Processing.
+ * sem_ch5.adb (Analyze_Case_Statement): Remove no
+ longer used Get_Choices argument in instantiation of
+ Generic_Choices_Processing.
+ * sinfo.ads: For N_Variant_Part, and N_Case_Statement_Alternative,
+ document that choices that are names of statically predicated
+ subtypes are expanded in the code generation tree passed to the
+ back end, but not in the ASIS tree generated for -gnatct.
+
+2013-10-10 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch7.adb: Revert previous change.
+
+2013-10-10 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): In the case where
+ the Storage_Pool aspect is specified by an aspect clause and a
+ renaming is used to capture the evaluation of the pool name,
+ insert the renaming in front of the aspect's associated entity
+ declaration rather than in front of the corresponding attribute
+ definition (which hasn't been appended to the declaration
+ list yet).
+
+2013-10-10 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Is_Interface_Conformant): The controlling type
+ of the interface operation is obtained from the ultimate alias
+ of the interface primitive parameter, because that may be in
+ fact an implicit inherited operation whose signature involves
+ the type extension and not the desired interface.
+
+2013-10-10 Ed Schonberg <schonberg@adacore.com>
+
+ * par-ch13.adb (Aspect_Specifications_Present): In Ada 2012,
+ recognize an aspect specification with a misspelled name if it
+ is followed by a a comma or semicolon.
+
+2013-10-10 Vadim Godunko <godunko@adacore.com>
+
+ * s-atocou.adb, s-atocou.ads, s-atocou-x86.adb, s-atocou-builtin.adb:
+ Fix copyright notice.
+
+2013-10-10 Yannick Moy <moy@adacore.com>
+
+ * lib-xref-spark_specific.adb (Enclosing_Subprogram_Or_Package): Get
+ enclosing subprogram for precondition/postcondition/contract cases.
+
2013-10-10 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Minor fix.
-- Expand_N_Variant_Part --
---------------------------
- -- If the last variant does not contain the Others choice, replace it with
- -- an N_Others_Choice node since Gigi always wants an Others. Note that we
- -- do not bother to call Analyze on the modified variant part, since its
- -- only effect would be to compute the Others_Discrete_Choices node
- -- laboriously, and of course we already know the list of choices that
- -- corresponds to the others choice (it's the list we are replacing!)
-
procedure Expand_N_Variant_Part (N : Node_Id) is
Last_Var : constant Node_Id := Last_Non_Pragma (Variants (N));
Others_Node : Node_Id;
+ Variant : Node_Id;
+
begin
+ -- If the last variant does not contain the Others choice, replace it
+ -- with an N_Others_Choice node since Gigi always wants an Others. Note
+ -- that we do not bother to call Analyze on the modified variant part,
+ -- since its only effect would be to compute the Others_Discrete_Choices
+ -- node laboriously, and of course we already know the list of choices
+ -- corresponding to the others choice (it's the list we're replacing!)
+
if Nkind (First (Discrete_Choices (Last_Var))) /= N_Others_Choice then
Others_Node := Make_Others_Choice (Sloc (Last_Var));
Set_Others_Discrete_Choices
(Others_Node, Discrete_Choices (Last_Var));
Set_Discrete_Choices (Last_Var, New_List (Others_Node));
end if;
+
+ -- Deal with any static predicates in the variant choices. Note that we
+ -- don't have to look at the last variant, since we know it is an others
+ -- choice, because we just rewrote it that way if necessary.
+
+ Variant := First_Non_Pragma (Variants (N));
+ while Variant /= Last_Var loop
+ Expand_Static_Predicates_In_Choices (Variant);
+ Next_Non_Pragma (Variant);
+ end loop;
end Expand_N_Variant_Part;
---------------------------------
-- if statement, since this can result in subsequent optimizations.
-- This helps not only with case statements in the source of a
-- simple form, but also with generated code (discriminant check
- -- functions in particular)
+ -- functions in particular).
+
+ -- Note: it is OK to do this before expanding out choices for any
+ -- static predicates, since the if statement processing will handle
+ -- the static predicate case fine.
elsif Len = 2 then
Chlist := Discrete_Choices (First (Alternatives (N)));
Set_Discrete_Choices (Last_Alt, New_List (Others_Node));
end if;
- Alt := First (Alternatives (N));
- while Present (Alt)
- and then Nkind (Alt) = N_Case_Statement_Alternative
- loop
+ -- Deal with possible declarations of controlled objects, and also
+ -- with rewriting choice sequences for static predicate references.
+
+ Alt := First_Non_Pragma (Alternatives (N));
+ while Present (Alt) loop
Process_Statements_For_Controlled_Objects (Alt);
- Next (Alt);
+ Expand_Static_Predicates_In_Choices (Alt);
+ Next_Non_Pragma (Alt);
end loop;
end;
end Expand_N_Case_Statement;
end if;
end Evolve_Or_Else;
+ -----------------------------------------
+ -- Expand_Static_Predicates_In_Choices --
+ -----------------------------------------
+
+ procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
+ pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant));
+
+ Choices : constant List_Id := Discrete_Choices (N);
+
+ Choice : Node_Id;
+ Next_C : Node_Id;
+ P : Node_Id;
+ C : Node_Id;
+
+ begin
+ Choice := First (Choices);
+ while Present (Choice) loop
+ Next_C := Next (Choice);
+
+ -- Check for name of subtype with static predicate
+
+ if Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ and then Has_Predicates (Entity (Choice))
+ then
+ -- Loop through entries in predicate list, converting to choices
+ -- and inserting in the list before the current choice. Note that
+ -- if the list is empty, corresponding to a False predicate, then
+ -- no choices are inserted.
+
+ P := First (Static_Predicate (Entity (Choice)));
+ while Present (P) loop
+
+ -- If low bound and high bounds are equal, copy simple choice
+
+ if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then
+ C := New_Copy (Low_Bound (P));
+
+ -- Otherwise copy a range
+
+ else
+ C := New_Copy (P);
+ end if;
+
+ -- Change Sloc to referencing choice (rather than the Sloc of
+ -- the predicate declarationo element itself).
+
+ Set_Sloc (C, Sloc (Choice));
+ Insert_Before (Choice, C);
+ Next (P);
+ end loop;
+
+ -- Delete the predicated entry
+
+ Remove (Choice);
+ end if;
+
+ -- Move to next choice to check
+
+ Choice := Next_C;
+ end loop;
+ end Expand_Static_Predicates_In_Choices;
+
------------------------------
-- Expand_Subtype_From_Expr --
------------------------------
-- indicating that no checks were required). The Sloc field of the
-- constructed N_Or_Else node is copied from Cond1.
+ procedure Expand_Static_Predicates_In_Choices (N : Node_Id);
+ -- N is either a case alternative or a variant. The Discrete_Choices field
+ -- of N points to a list of choices. If any of these choices is the name
+ -- of a (statically) predicated subtype, then it is rewritten as the series
+ -- of choices that correspond to the values allowed for the subtype.
+
procedure Expand_Subtype_From_Expr
(N : Node_Id;
Unc_Type : Entity_Id;
Result := Defining_Unit_Name (Specification (Result));
exit;
- -- The enclosing subprogram for a pre- or postconditions should be
- -- the subprogram to which the pragma is attached. This is not
- -- always the case in the AST, as the pragma may be declared after
- -- the declaration of the subprogram. Return Empty in this case.
-
when N_Pragma =>
+
+ -- The enclosing subprogram for a precondition, a
+ -- postcondition, or a contract case should be the subprogram
+ -- to which the pragma is attached, which can be found by
+ -- following previous elements in the list to which the
+ -- pragma belongs.
+
if Get_Pragma_Id (Result) = Pragma_Precondition
or else
Get_Pragma_Id (Result) = Pragma_Postcondition
+ or else
+ Get_Pragma_Id (Result) = Pragma_Contract_Cases
then
- return Empty;
+ if Is_List_Member (Result)
+ and then Present (Prev (Result))
+ then
+ Result := Prev (Result);
+ else
+ Result := Parent (Result);
+ end if;
+
else
Result := Parent (Result);
end if;
-- are in Ada 2012 mode, Strict is False, and we consider that we have
-- an aspect specification if the identifier is an aspect name (even if
-- not followed by =>) or the identifier is not an aspect name but is
- -- followed by =>. P_Aspect_Specifications will generate messages if the
- -- aspect specification is ill-formed.
+ -- followed by =>, by a comma, or by a semicolon. The last two cases
+ -- correspond to (misspelled) Boolean aspects with a defaulted value of
+ -- True. P_Aspect_Specifications will generate messages if the aspect
+ -- specification is ill-formed.
elsif not Strict then
if Get_Aspect_Id (Token_Name) /= No_Aspect then
Result := True;
else
Scan; -- past identifier
- Result := Token = Tok_Arrow;
+ Result := Token = Tok_Arrow
+ or else Token = Tok_Comma
+ or else Token = Tok_Semicolon;
end if;
-- If earlier than Ada 2012, check for valid aspect identifier (possibly
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2013, AdaCore --
+-- Copyright (C) 2011-2013, 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- --
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2013, AdaCore --
+-- Copyright (C) 2011-2013, 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- --
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2013, AdaCore --
+-- Copyright (C) 2011-2013, 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- --
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2013, AdaCore --
+-- Copyright (C) 2011-2013, 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- --
-- to the choice node itself.
type Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
- -- Table type used to sort the choices present in a case statement, array
- -- aggregate or record variant. The actual entries are stored in 1 .. Last,
- -- but we have a 0 entry for convenience in sorting.
+ -- Table type used to sort the choices present in a case statement or
+ -- record variant. The actual entries are stored in 1 .. Last, but we
+ -- have a 0 entry for use in sorting.
-----------------------
-- Local Subprograms --
procedure Missing_Choices (Pred : Node_Id; Prev_Hi : Uint);
-- Emit an error message for each non-covered static predicate set.
- -- Prev_Hi denotes the upper bound of the last choice that covered a
- -- set.
+ -- Prev_Hi denotes the upper bound of the last choice covering a set.
procedure Move_Choice (From : Natural; To : Natural);
-- Move routine for sorting the Choice_Table
else
Illegal_Range (Loc, Choice_Lo, Choice_Hi);
Error := True;
-
return;
end if;
if Nkind (Case_Node) = N_Variant_Part then
Error_Msg_NE
- ("bounds of & are not static," &
- " alternatives must cover base type", Expr, Expr);
+ ("bounds of & are not static, "
+ & "alternatives must cover base type!", Expr, Expr);
-- If this is a case statement, the expression may be non-static
-- or else the subtype may be at fault.
elsif Is_Entity_Name (Expr) then
Error_Msg_NE
- ("bounds of & are not static," &
- " alternatives must cover base type", Expr, Expr);
+ ("bounds of & are not static, "
+ & "alternatives must cover base type!", Expr, Expr);
else
Error_Msg_N
- ("subtype of expression is not static,"
- & " alternatives must cover base type!", Expr);
+ ("subtype of expression is not static, "
+ & "alternatives must cover base type!", Expr);
end if;
-- Otherwise the expression is not static, even if the bounds of the
if Nkind (Alt) = N_Pragma then
Analyze (Alt);
- -- Otherwise check each choice against its base type
+ -- Otherwise we have an alternative. In most cases the semantic
+ -- processing leaves the list of choices unchanged
+
+ -- Check each choice against its base type
else
- Choice := First (Get_Choices (Alt));
+ Choice := First (Discrete_Choices (Alt));
while Present (Choice) loop
Delete_Choice := False;
Analyze (Choice);
then
Bad_Predicated_Subtype_Use
("cannot use subtype& with non-static "
- & "predicate as case alternative", Choice, E,
- Suggest_Static => True);
+ & "predicate as case alternative",
+ Choice, E, Suggest_Static => True);
- -- Static predicate case
+ -- Static predicate case
else
declare
- Copy : constant List_Id := Empty_List;
- P : Node_Id;
- C : Node_Id;
+ P : Node_Id;
+ C : Node_Id;
begin
-- Loop through entries in predicate list,
- -- converting to choices. Note that if the
+ -- checking each entry. Note that if the
-- list is empty, corresponding to a False
- -- predicate, then no choices are inserted.
+ -- predicate, then no choices are checked.
P := First (Static_Predicate (E));
while Present (P) loop
C := New_Copy (P);
Set_Sloc (C, Sloc (Choice));
- Append_To (Copy, C);
+ Check (C, Low_Bound (C), High_Bound (C));
Next (P);
end loop;
-
- Insert_List_After (Choice, Copy);
- Delete_Choice := True;
end;
end if;
Resolve_Discrete_Subtype_Indication
(Choice, Expected_Type);
- -- Here for other than predicated subtype case
-
if Etype (Choice) /= Any_Type then
declare
C : constant Node_Id := Constraint (Choice);
-- alternative and as its only choice.
elsif Kind = N_Others_Choice then
- if not (Choice = First (Get_Choices (Alt))
- and then Choice = Last (Get_Choices (Alt))
- and then Alt = Last (Get_Alternatives (N)))
+ if not (Choice = First (Discrete_Choices (Alt))
+ and then Choice = Last (Discrete_Choices (Alt))
+ and then Alt = Last (Get_Alternatives (N)))
then
Error_Msg_N
("the choice OTHERS must appear alone and last",
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2013, 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- --
generic
with function Get_Alternatives (N : Node_Id) return List_Id;
- -- Function needed to get to the actual list of case statement
- -- alternatives, or array aggregate component associations or
- -- record variants from which we can then access the actual lists
- -- of discrete choices. N is the node for the original construct
- -- i.e. a case statement, an array aggregate or a record variant.
-
- with function Get_Choices (A : Node_Id) return List_Id;
- -- Given a case statement alternative, array aggregate component
- -- association or record variant A we need different access functions
- -- to get to the actual list of discrete choices.
+ -- Function used to get the list of case statement alternatives or
+ -- record variants, from which we can then access the actual lists of
+ -- discrete choices. N is the node for the original construct (case
+ -- statement or a record variant).
with procedure Process_Empty_Choice (Choice : Node_Id);
- -- Processing to carry out for an empty Choice
+ -- Processing to carry out for an empty Choice. Set to No_Op (declared
+ -- above) if no such processing is required.
with procedure Process_Non_Static_Choice (Choice : Node_Id);
-- Processing to carry out for a non static Choice
with procedure Process_Associated_Node (A : Node_Id);
- -- Associated with each case alternative, aggregate component
- -- association or record variant A there is a node or list of nodes
- -- that need semantic processing. This routine implements that
- -- processing.
+ -- Associated with each case alternative or record variant A there is
+ -- a node or list of nodes that need semantic processing. This routine
+ -- implements that processing.
package Generic_Choices_Processing is
Subtyp : Entity_Id;
Raises_CE : out Boolean;
Others_Present : out Boolean);
- -- From a case expression, case statement, array aggregate or record
- -- variant N, this routine analyzes the corresponding list of discrete
- -- choices. Subtyp is the subtype of the discrete choices. The type
- -- against which the discrete choices must be resolved is its base type.
+ -- From a case expression, case statement, or record variant N, this
+ -- routine analyzes the corresponding list of discrete choices. Subtyp
+ -- is the subtype of the discrete choices. The type against which the
+ -- discrete choices must be resolved is its base type.
--
- -- In one of the bounds of a discrete choice raises a constraint
+ -- If one of the bounds of a discrete choice raises a constraint
-- error the flag Raise_CE is set.
--
-- Finally Others_Present is set to True if an Others choice is present
Name => Expr);
begin
- Insert_Before (N, Rnode);
+ -- If the attribute definition clause comes from an aspect
+ -- clause, then insert the renaming before the associated
+ -- entity's declaration, since the attribute clause has
+ -- not yet been appended to the declaration list.
+
+ if From_Aspect_Specification (N) then
+ Insert_Before (Parent (Entity (N)), Rnode);
+ else
+ Insert_Before (N, Rnode);
+ end if;
+
Analyze (Rnode);
Set_Associated_Storage_Pool (U_Ent, Pool);
end;
package Variant_Choices_Processing is new
Generic_Choices_Processing
(Get_Alternatives => Variants,
- Get_Choices => Discrete_Choices,
Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => Process_Declarations);
package Case_Choices_Processing is new
Generic_Choices_Processing
(Get_Alternatives => Alternatives,
- Get_Choices => Discrete_Choices,
Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => No_OP);
Next (Param);
end loop;
- -- One of the specs has additional formals, there is no match,
- -- unless this may be an indexing of a parameterless call.
+ -- One of the specs has additional formals; there is no match, unless
+ -- this may be an indexing of a parameterless call.
-- Note that when expansion is disabled, the corresponding record
-- type of synchronized types is not constructed, so that there is
and then not Expander_Active
then
return True;
-
else
return False;
end if;
package Case_Choices_Processing is new
Generic_Choices_Processing
(Get_Alternatives => Alternatives,
- Get_Choices => Discrete_Choices,
Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => Process_Statements);
Iface_Prim : Entity_Id;
Prim : Entity_Id) return Boolean
is
- Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim);
+ -- The operation may in fact be an inherited (implicit) operation
+ -- rather than the original interface primitive, so retrieve the
+ -- ultimate ancestor.
+
+ Iface : constant Entity_Id :=
+ Find_Dispatching_Type (Ultimate_Alias (Iface_Prim));
Typ : constant Entity_Id := Find_Dispatching_Type (Prim);
function Controlling_Formal (Prim : Entity_Id) return Entity_Id;
return False;
else
return
- Type_Conformant (Prim, Iface_Prim,
+ Type_Conformant (Prim, Ultimate_Alias (Iface_Prim),
Skip_Controlling_Formals => True);
end if;
-- If one of the non-generic parents is itself on the scope
-- stack, do not install its private declarations: they are
-- installed in due time when the private part of that parent
- -- is analyzed.
+ -- is analyzed. This is delicate ???
else
while Present (Inst_Par)
and then (not In_Open_Scopes (Inst_Par)
or else not In_Private_Part (Inst_Par))
loop
- if Nkind (Inst_Node) = N_Formal_Package_Declaration
- or else
- not Is_Ancestor_Package
- (Inst_Par, Cunit_Entity (Current_Sem_Unit))
- then
- Install_Private_Declarations (Inst_Par);
- Set_Use (Private_Declarations
- (Specification
- (Unit_Declaration_Node (Inst_Par))));
- Inst_Par := Scope (Inst_Par);
-
- else
- exit;
- end if;
+ Install_Private_Declarations (Inst_Par);
+ Set_Use (Private_Declarations
+ (Specification
+ (Unit_Declaration_Node (Inst_Par))));
+ Inst_Par := Scope (Inst_Par);
end loop;
exit;
-- Present_Expr (Uint3-Sem)
-- Dcheck_Function (Node5-Sem)
+ -- Note: in the list of Discrete_Choices, the tree passed to the back
+ -- end does not have choice entries corresponding to names of statically
+ -- predicated subtypes. Such entries are always expanded out to the list
+ -- of equivalent values or ranges. The ASIS tree generated in -gnatct
+ -- mode does not have this expansion, and has the original choices.
+
---------------------------------
-- 3.8.1 Discrete Choice List --
---------------------------------
-- Discrete_Choices (List4)
-- Statements (List3)
+ -- Note: in the list of Discrete_Choices, the tree passed to the back
+ -- end does not have choice entries corresponding to names of statically
+ -- predicated subtypes. Such entries are always expanded out to the list
+ -- of equivalent values or ranges. The ASIS tree generated in -gnatct
+ -- mode does not have this expansion, and has the original choices.
+
-------------------------
-- 5.5 Loop Statement --
-------------------------
projects / thirdparty / gcc.git / commitdiff
