+2011-08-05 Bob Duff <duff@adacore.com>
+
+ * sinfo.ads, sinfo.adb (Subpool_Handle_Name): New attribute for
+ subpools.
+ * par-ch4.adb (P_Allocator): Parse new subpool specification syntax.
+
+2011-08-05 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Try_Container_Indexing): New procedure to implement the
+ general indexing aspects of Ada2012. Called when analyzing indexed
+ components when other interpretations fail.
+ * sem_ch8.adb (Find_Direct_Name): check for implicit dereference only
+ in an expression context where overloading is meaningful. This excludes
+ the occurrence in an aspect specification (efficiency only).
+ * sem_attr.adb (Analyze_Attribute): indicate that the attributes
+ related to iterators can be set by an attribute specification, but
+ cannot be queried.
+ * sem_ch13.adb (Analyze_Aspect_Specifications): handle
+ Constant_Indexing and Variable_Indexing.
+ (Check_Indexing_Functions): New procedure to perform legality checks.
+ Additional semantic checks at end of declarations.
+
2011-08-05 Sergey Rybin <rybin@adacore.com>
* tree_io.ads: Update ASIS_Version_Number because of the change of the
--------------------
-- ALLOCATOR ::=
- -- new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
+ -- new [SUBPOOL_SPECIFICATION] SUBTYPE_INDICATION
+ -- | new [SUBPOOL_SPECIFICATION] QUALIFIED_EXPRESSION
+ --
+ -- SUBPOOL_SPECIFICATION ::= (subpool_handle_NAME)
-- The caller has checked that the initial token is NEW
Alloc_Node := New_Node (N_Allocator, Token_Ptr);
T_New;
+ -- Scan subpool_specification if present (Ada 2012 (AI05-0111-3))
+
-- Scan Null_Exclusion if present (Ada 2005 (AI-231))
+ if Token = Tok_Left_Paren then
+ Scan; -- past (
+ Set_Subpool_Handle_Name (Alloc_Node, P_Name);
+ T_Right_Paren;
+
+ if Ada_Version < Ada_2012 then
+ Error_Msg_N
+ ("|subpool specification is an Ada 2012 feature",
+ Subpool_Handle_Name (Alloc_Node));
+ Error_Msg_N
+ ("\|unit must be compiled with -gnat2012 switch",
+ Subpool_Handle_Name (Alloc_Node));
+ end if;
+ end if;
+
Null_Exclusion_Present := P_Null_Exclusion;
Set_Null_Exclusion_Present (Alloc_Node, Null_Exclusion_Present);
Type_Node := P_Subtype_Mark_Resync;
case Attr_Id is
- -- Attributes related to Ada2012 iterators (placeholder ???)
-
- when Attribute_Constant_Indexing => null;
- when Attribute_Default_Iterator => null;
- when Attribute_Implicit_Dereference => null;
- when Attribute_Iterator_Element => null;
- when Attribute_Variable_Indexing => null;
+ -- Attributes related to Ada2012 iterators. Attribute specifications
+ -- exist for these, but they cannot be queried.
+
+ when Attribute_Constant_Indexing |
+ Attribute_Default_Iterator |
+ Attribute_Implicit_Dereference |
+ Attribute_Iterator_Element |
+ Attribute_Variable_Indexing =>
+ Error_Msg_N ("illegal attribute", N);
------------------
-- Abort_Signal --
Delay_Required := False;
- -- Aspects related to container iterators (fill in later???)
+ -- Aspects related to container iterators. These aspects denote
+ -- subprograms, and thus must be delayed.
when Aspect_Constant_Indexing |
- Aspect_Default_Iterator |
- Aspect_Iterator_Element |
Aspect_Variable_Indexing =>
- null;
+
+ if not Is_Type (E) or else not Is_Tagged_Type (E) then
+ Error_Msg_N ("indexing applies to a tagged type", N);
+ end if;
+
+ Aitem :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => Ent,
+ Chars => Chars (Id),
+ Expression => Relocate_Node (Expr));
+
+ Delay_Required := True;
+ Set_Is_Delayed_Aspect (Aspect);
+
+ when Aspect_Default_Iterator |
+ Aspect_Iterator_Element =>
+
+ Aitem :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => Ent,
+ Chars => Chars (Id),
+ Expression => Relocate_Node (Expr));
+
+ Delay_Required := True;
+ Set_Is_Delayed_Aspect (Aspect);
when Aspect_Implicit_Dereference =>
if not Is_Type (E)
-- and if so gives an error message. If there is a duplicate, True is
-- returned, otherwise if there is no error, False is returned.
+ procedure Check_Indexing_Functions;
+ -- Check that the function in Constant_Indexing or Variable_Indexing
+ -- attribute has the proper type structure. If the name is overloaded,
+ -- check that all interpretations are legal.
+
-----------------------------------
-- Analyze_Stream_TSS_Definition --
-----------------------------------
end if;
end Analyze_Stream_TSS_Definition;
+ ------------------------------
+ -- Check_Indexing_Functions --
+ ------------------------------
+
+ procedure Check_Indexing_Functions is
+ Ctrl : Entity_Id;
+
+ procedure Check_One_Function (Subp : Entity_Id);
+ -- Check one possible interpretation
+
+ ------------------------
+ -- Check_One_Function --
+ ------------------------
+
+ procedure Check_One_Function (Subp : Entity_Id) is
+ begin
+ if Ekind (Subp) /= E_Function then
+ Error_Msg_N ("indexing requires a function", Subp);
+ end if;
+
+ if No (First_Formal (Subp)) then
+ Error_Msg_N
+ ("function for indexing must have parameters", Subp);
+ else
+ Ctrl := Etype (First_Formal (Subp));
+ end if;
+
+ if Ctrl = Ent
+ or else Ctrl = Class_Wide_Type (Ent)
+ or else
+ (Ekind (Ctrl) = E_Anonymous_Access_Type
+ and then
+ (Designated_Type (Ctrl) = Ent
+ or else Designated_Type (Ctrl) = Class_Wide_Type (Ent)))
+ then
+ null;
+
+ else
+ Error_Msg_N ("indexing function must apply to type&", Subp);
+ end if;
+
+ if No (Next_Formal (First_Formal (Subp))) then
+ Error_Msg_N
+ ("function for indexing must have two parameters", Subp);
+ end if;
+
+ if not Has_Implicit_Dereference (Etype (Subp)) then
+ Error_Msg_N
+ ("function for indexing must return a reference type", Subp);
+ end if;
+ end Check_One_Function;
+
+ -- Start of processing for Check_Indexing_Functions
+
+ begin
+ Analyze (Expr);
+
+ if not Is_Overloaded (Expr) then
+ Check_One_Function (Entity (Expr));
+
+ else
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (Expr, I, It);
+ while Present (It.Nam) loop
+
+ -- Note that analysis will have added the interpretation
+ -- that corresponds to the dereference. We only check the
+ -- subprogram itself.
+
+ if Is_Overloadable (It.Nam) then
+ Check_One_Function (It.Nam);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+ end Check_Indexing_Functions;
+
----------------------
-- Duplicate_Clause --
----------------------
end if;
end Component_Size_Case;
+ -----------------------
+ -- Constant_Indexing --
+ -----------------------
+
+ when Attribute_Constant_Indexing =>
+ Check_Indexing_Functions;
+
------------------
-- External_Tag --
------------------
end if;
end Value_Size;
+ -----------------------
+ -- Variable_Indexing --
+ -----------------------
+
+ when Attribute_Variable_Indexing =>
+ Check_Indexing_Functions;
+
-----------
-- Write --
-----------
Analyze (End_Decl_Expr);
Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
+ elsif A_Id = Aspect_Variable_Indexing or else
+ A_Id = Aspect_Constant_Indexing
+ then
+ Analyze (End_Decl_Expr);
+ Analyze (Aspect_Rep_Item (ASN));
+ Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr);
+
-- All other cases
else
Aspect_Value_Size =>
T := Any_Integer;
- -- Following to be done later ???
-
- when Aspect_Constant_Indexing |
- Aspect_Default_Iterator |
- Aspect_Iterator_Element |
- Aspect_Implicit_Dereference |
- Aspect_Variable_Indexing =>
- null;
-
-- Stream attribute. Special case, the expression is just an entity
-- that does not need any resolution, so just analyze.
Analyze (Expression (ASN));
return;
+ -- Same for Iterator aspects, where the expression is a function
+ -- name. Legality rules are checked separately.
+
+ when Aspect_Constant_Indexing |
+ Aspect_Default_Iterator |
+ Aspect_Iterator_Element |
+ Aspect_Implicit_Dereference |
+ Aspect_Variable_Indexing =>
+ Analyze (Expression (ASN));
+ return;
+
-- Suppress/Unsuppress/Warnings should never be delayed
when Aspect_Suppress |
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
-- Ada 2005: implementation of AI-310. An abstract non-dispatching
-- operation is not a candidate interpretation.
+ function Try_Container_Indexing
+ (N : Node_Id;
+ Prefix : Node_Id;
+ Expr : Node_Id) return Boolean;
+ -- AI05-0139: Generalized indexing to support iterators over containers
+
function Try_Indexed_Call
(N : Node_Id;
Nam : Entity_Id;
then
return;
+ elsif Try_Container_Indexing (N, P, Exp) then
+ return;
+
elsif Array_Type = Any_Type then
Set_Etype (N, Any_Type);
end if;
end Remove_Abstract_Operations;
+ ----------------------------
+ -- Try_Container_Indexing --
+ ----------------------------
+
+ function Try_Container_Indexing
+ (N : Node_Id;
+ Prefix : Node_Id;
+ Expr : Node_Id) return Boolean
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Disc : Entity_Id;
+ Func : Entity_Id;
+ Func_Name : Node_Id;
+ Indexing : Node_Id;
+ Is_Var : Boolean;
+ Ritem : Node_Id;
+
+ begin
+
+ -- Check whether type has a specified indexing aspect.
+
+ Func_Name := Empty;
+ Is_Var := False;
+ Ritem := First_Rep_Item (Etype (Prefix));
+
+ while Present (Ritem) loop
+ if Nkind (Ritem) = N_Aspect_Specification then
+
+ -- Prefer Variable_Indexing, but will settle for Constant.
+
+ if Get_Aspect_Id (Chars (Identifier (Ritem))) =
+ Aspect_Constant_Indexing
+ then
+ Func_Name := Expression (Ritem);
+
+ elsif Get_Aspect_Id (Chars (Identifier (Ritem))) =
+ Aspect_Variable_Indexing
+ then
+ Func_Name := Expression (Ritem);
+ Is_Var := True;
+ exit;
+ end if;
+ end if;
+ Next_Rep_Item (Ritem);
+ end loop;
+
+ -- If aspect does not exist the expression is illegal. Error is
+ -- diagnosed in caller.
+
+ if No (Func_Name) then
+ return False;
+ end if;
+
+ if Is_Var
+ and then not Is_Variable (Prefix)
+ then
+ Error_Msg_N ("Variable indexing cannot be applied to a constant", N);
+ end if;
+
+ if not Is_Overloaded (Func_Name) then
+ Func := Entity (Func_Name);
+ Indexing := Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Func, Loc),
+ Parameter_Associations =>
+ New_List (Relocate_Node (Prefix), Relocate_Node (Expr)));
+ Rewrite (N, Indexing);
+ Analyze (N);
+
+ -- The return type of the indexing function is a reference type, so
+ -- add the dereference as a possible interpretation.
+
+ Disc := First_Discriminant (Etype (Func));
+ while Present (Disc) loop
+ if Has_Implicit_Dereference (Disc) then
+ Add_One_Interp (N, Disc, Designated_Type (Etype (Disc)));
+ exit;
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ else
+ Indexing := Make_Function_Call (Loc,
+ Name => Make_Identifier (Loc, Chars (Func_Name)),
+ Parameter_Associations =>
+ New_List (Relocate_Node (Prefix), Relocate_Node (Expr)));
+
+ Rewrite (N, Indexing);
+
+ declare
+ I : Interp_Index;
+ It : Interp;
+ Success : Boolean;
+
+ begin
+ Get_First_Interp (Func_Name, I, It);
+ Set_Etype (N, Any_Type);
+ while Present (It.Nam) loop
+ Analyze_One_Call (N, It.Nam, False, Success);
+ if Success then
+ Set_Etype (Name (N), It.Typ);
+
+ -- Add implicit dereference interpretation.
+
+ Disc := First_Discriminant (Etype (It.Nam));
+
+ while Present (Disc) loop
+ if Has_Implicit_Dereference (Disc) then
+ Add_One_Interp
+ (N, Disc, Designated_Type (Etype (Disc)));
+ exit;
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+ end if;
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ return True;
+ end Try_Container_Indexing;
+
-----------------------
-- Try_Indirect_Call --
-----------------------
end if;
Set_Entity_Or_Discriminal (N, E);
- Check_Implicit_Dereference (N, Etype (E));
+
+ if Ada_Version >= Ada_2012
+ and then Nkind (Parent (N)) in N_Subexpr
+ then
+ Check_Implicit_Dereference (N, Etype (E));
+ end if;
end if;
end;
end Find_Direct_Name;
return Node1 (N);
end Storage_Pool;
+ function Subpool_Handle_Name
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator);
+ return Node4 (N);
+ end Subpool_Handle_Name;
+
function Strval
(N : Node_Id) return String_Id is
begin
Set_Node1 (N, Val); -- semantic field, no parent set
end Set_Storage_Pool;
+ procedure Set_Subpool_Handle_Name
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Allocator);
+ Set_Node4_With_Parent (N, Val);
+ end Set_Subpool_Handle_Name;
+
procedure Set_Strval
(N : Node_Id; Val : String_Id) is
begin
--------------------
-- ALLOCATOR ::=
- -- new [NULL_EXCLUSION] SUBTYPE_INDICATION | new QUALIFIED_EXPRESSION
+ -- new [SUBPOOL_SPECIFICATION] SUBTYPE_INDICATION
+ -- | new [SUBPOOL_SPECIFICATION] QUALIFIED_EXPRESSION
+ --
+ -- SUBPOOL_SPECIFICATION ::= (subpool_handle_NAME)
-- Sprint syntax (when storage pool present)
-- new xxx (storage_pool = pool)
+ -- or
+ -- new (subpool) xxx (storage_pool = pool)
-- N_Allocator
-- Sloc points to NEW
-- Expression (Node3) subtype indication or qualified expression
+ -- Subpool_Handle_Name (Node4) (set to Empty if not present)
-- Storage_Pool (Node1-Sem)
-- Procedure_To_Call (Node2-Sem)
-- Null_Exclusion_Present (Flag11)
function Storage_Pool
(N : Node_Id) return Node_Id; -- Node1
+ function Subpool_Handle_Name
+ (N : Node_Id) return Node_Id; -- Node4
+
function Strval
(N : Node_Id) return String_Id; -- Str3
procedure Set_Storage_Pool
(N : Node_Id; Val : Node_Id); -- Node1
+ procedure Set_Subpool_Handle_Name
+ (N : Node_Id; Val : Node_Id); -- Node4
+
procedure Set_Strval
(N : Node_Id; Val : String_Id); -- Str3
(1 => False, -- Storage_Pool (Node1-Sem)
2 => False, -- Procedure_To_Call (Node2-Sem)
3 => True, -- Expression (Node3)
- 4 => False, -- unused
+ 4 => True, -- Subpool_Handle_Name (Node4)
5 => False), -- Etype (Node5-Sem)
N_Null_Statement =>
pragma Inline (Statements);
pragma Inline (Static_Processing_OK);
pragma Inline (Storage_Pool);
+ pragma Inline (Subpool_Handle_Name);
pragma Inline (Strval);
pragma Inline (Subtype_Indication);
pragma Inline (Subtype_Mark);
pragma Inline (Set_Statements);
pragma Inline (Set_Static_Processing_OK);
pragma Inline (Set_Storage_Pool);
+ pragma Inline (Set_Subpool_Handle_Name);
pragma Inline (Set_Strval);
pragma Inline (Set_Subtype_Indication);
pragma Inline (Set_Subtype_Mark);
OSDN Git Service
