+2012-07-23 Ed Schonberg <schonberg@adacore.com>
+
+ * par-ch6.adb (P_Mode): in Ada 2005, a mode indicator can apply
+ to a formal object of an anonymous access type.
+
+2012-07-23 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Try_Container_Indexing): A user-defined indexing
+ aspect can have more than one index, e.g. to describe indexing
+ of a multidimensional object.
+
+2012-07-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch4.adb (Apply_Accessibility_Check): Reimplemented. The check is
+ now more complex and contains optional finalization part and mandatory
+ deallocation part.
+
+2012-07-23 Gary Dismukes <dismukes@adacore.com>
+
+ * a-cihama.adb, a-cihase.adb, a-cimutr.adb, a-ciorma.adb, a-ciormu.adb,
+ a-ciorse.adb, a-coinho.adb, a-coinve.adb, a-cidlli.adb: Unsuppress
+ Accessibility_Check for Element_Type allocators.
+
+2012-07-23 Vasiliy Fofanov <fofanov@adacore.com>
+
+ * projects.texi: Fix typo.
+
+2012-07-23 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Explicit_Derenference): If prefix is
+ overloaded, remove those interpretations whose designated type
+ does not match the context, to avoid spurious ambiguities that
+ may be caused by the Ada 2012 conversion rule for anonymous
+ access types.
+
2012-07-23 Vincent Celier <celier@adacore.com>
* g-spitbo.adb (Substr (String)): Return full string and do not
end if;
declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
+ -- allocator in the loop below, because the one in this block would
+ -- have failed already.
+
Element : Element_Access := new Element_Type'(New_Item);
begin
New_Node := new Node_Type'(Element, null, null);
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
declare
- X : Element_Access := Position.Node.Element;
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
+ X : Element_Access := Position.Node.Element;
begin
Position.Node.Element := new Element_Type'(New_Item);
Free (X);
Position.Node.Key := new Key_Type'(Key);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the
+ -- case the actual type is class-wide or has access discriminants
+ -- (see RM 4.8(10.1) and AI12-0035).
begin
Position.Node.Element := new Element_Type'(New_Item);
exception
K : Key_Access := new Key_Type'(Key);
E : Element_Access;
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
+
begin
E := new Element_Type'(New_Item);
return new Node_Type'(K, E, Next);
Node.Key := new Key_Type'(Key);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
begin
Node.Element := new Element_Type'(New_Item);
exception
declare
X : Element_Access := Position.Node.Element;
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
begin
Position.Node.Element := new Element_Type'(New_Item);
Free_Element (X);
procedure Assign (Node : Node_Access; Item : Element_Type) is
X : Element_Access := Node.Element;
+
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case the
+ -- actual type is class-wide or has access discriminants (RM 4.8(10.1)
+ -- and AI12-0035).
begin
Node.Element := new Element_Type'(Item);
Free_Element (X);
X := Position.Node.Element;
- Position.Node.Element := new Element_Type'(New_Item);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the
+ -- case the actual type is class-wide or has access discriminants
+ -- (see RM 4.8(10.1) and AI12-0035).
+ begin
+ Position.Node.Element := new Element_Type'(New_Item);
+ end;
Free_Element (X);
end if;
--------------
function New_Node (Next : Node_Access) return Node_Access is
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
+
Element : Element_Access := new Element_Type'(New_Item);
begin
return new Node_Type'(Element, Next);
X := Node.Element;
- Node.Element := new Element_Type'(New_Item);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
+ begin
+ Node.Element := new Element_Type'(New_Item);
+ end;
Free_Element (X);
end Replace;
with "attempt to tamper with cursors (tree is busy)";
end if;
- Element := new Element_Type'(New_Item);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
+ -- allocator in the loop below, because the one in this block would
+ -- have failed already.
+ begin
+ Element := new Element_Type'(New_Item);
+ end;
+
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => Element,
others => <>);
Position.Container := Parent.Container;
- Element := new Element_Type'(New_Item);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
+ -- allocator in the loop below, because the one in this block would
+ -- have failed already.
+ begin
+ Element := new Element_Type'(New_Item);
+ end;
+
Position.Node := new Tree_Node_Type'(Parent => Parent.Node,
Element => Element,
others => <>);
with "attempt to tamper with cursors (tree is busy)";
end if;
- Element := new Element_Type'(New_Item);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
+ -- allocator in the loop below, because the one in this block would
+ -- have failed already.
+ begin
+ Element := new Element_Type'(New_Item);
+ end;
+
First := new Tree_Node_Type'(Parent => Parent.Node,
Element => Element,
others => <>);
with "attempt to tamper with elements (tree is locked)";
end if;
- E := new Element_Type'(New_Item);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
+ begin
+ E := new Element_Type'(New_Item);
+ end;
X := Position.Node.Element;
Position.Node.Element := E;
Position.Node.Key := new Key_Type'(Key);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the
+ -- case the actual type is class-wide or has access discriminants
+ -- (see RM 4.8(10.1) and AI12-0035).
begin
Position.Node.Element := new Element_Type'(New_Item);
exception
function New_Node return Node_Access is
Node : Node_Access := new Node_Type;
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
begin
Node.Key := new Key_Type'(Key);
Node.Element := new Element_Type'(New_Item);
Node.Key := new Key_Type'(Key);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
begin
Node.Element := new Element_Type'(New_Item);
exception
declare
X : Element_Access := Position.Node.Element;
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
begin
Position.Node.Element := new Element_Type'(New_Item);
Free_Element (X);
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-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 New_Node return Node_Access is
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
+
Element : Element_Access := new Element_Type'(New_Item);
begin
declare
X : Element_Access := Node.Element;
+
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the
+ -- case the actual type is class-wide or has access discriminants
+ -- (see RM 4.8(10.1) and AI12-0035).
begin
Node.Element := new Element_Type'(Item);
Free_Element (X);
--------------
function New_Node return Node_Access is
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the
+ -- case the actual type is class-wide or has access discriminants
+ -- (see RM 4.8(10.1) and AI12-0035).
begin
Node.Element := new Element_Type'(Item); -- OK if fails
Node.Color := Red_Black_Trees.Red;
"attempt to tamper with elements (set is locked)";
end if;
- X := Position.Node.Element;
- Position.Node.Element := new Element_Type'(New_Item);
- Free_Element (X);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the
+ -- case the actual type is class-wide or has access discriminants
+ -- (see RM 4.8(10.1) and AI12-0035).
+ begin
+ X := Position.Node.Element;
+ Position.Node.Element := new Element_Type'(New_Item);
+ Free_Element (X);
+ end;
end if;
end Include;
--------------
function New_Node return Node_Access is
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
+
Element : Element_Access := new Element_Type'(New_Item);
begin
"attempt to tamper with elements (set is locked)";
end if;
- X := Node.Element;
- Node.Element := new Element_Type'(New_Item);
- Free_Element (X);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
+ begin
+ X := Node.Element;
+ Node.Element := new Element_Type'(New_Item);
+ Free_Element (X);
+ end;
end Replace;
---------------------
--------------
function New_Node return Node_Access is
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- the actual type is class-wide or has access discriminants (see
+ -- RM 4.8(10.1) and AI12-0035).
begin
Node.Element := new Element_Type'(Item); -- OK if fails
Node.Color := Red;
"attempt to tamper with elements (set is locked)";
end if;
- Node.Element := new Element_Type'(Item);
- Free_Element (X);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the
+ -- case the actual type is class-wide or has access discriminants
+ -- (see RM 4.8(10.1) and AI12-0035).
+ begin
+ Node.Element := new Element_Type'(Item);
+ Free_Element (X);
+ end;
return;
end if;
"attempt to tamper with elements (set is locked)";
end if;
- Node.Element := new Element_Type'(Item);
- Free_Element (X);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the
+ -- case actual type is class-wide or has access discriminants
+ -- (see RM 4.8(10.1) and AI12-0035).
+ begin
+ Node.Element := new Element_Type'(Item);
+ Free_Element (X);
+ end;
return;
end if;
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
--- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S --
+-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2011, Free Software Foundation, Inc. --
+-- Copyright (C) 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- --
raise Program_Error with "attempt to tamper with elements";
end if;
- Free (Container.Element);
- Container.Element := new Element_Type'(New_Item);
+ declare
+ X : Element_Access := Container.Element;
+
+ pragma Unsuppress (Accessibility_Check);
+ -- Element allocator may need an accessibility check in case actual
+ -- type is class-wide or has access discriminants (RM 4.8(10.1) and
+ -- AI12-0035).
+ begin
+ Container.Element := new Element_Type'(New_Item);
+ Free (X);
+ end;
end Replace_Element;
---------------
---------------
function To_Holder (New_Item : Element_Type) return Holder is
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case the
+ -- actual type is class-wide or has access discriminants (RM 4.8(10.1)
+ -- and AI12-0035).
begin
return (AF.Controlled with new Element_Type'(New_Item), 0);
end To_Holder;
-- value, in case the allocation fails (either because there is no
-- storage available, or because element initialization fails).
- Container.Elements.EA (Idx) := new Element_Type'(New_Item);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the
+ -- case actual type is class-wide or has access discriminants
+ -- (see RM 4.8(10.1) and AI12-0035).
+ begin
+ Container.Elements.EA (Idx) := new Element_Type'(New_Item);
+ end;
-- The allocation of the element succeeded, so it is now safe to
-- update the Last index, restoring container invariants.
-- because there is no storage available, or because element
-- initialization fails).
- E (Idx) := new Element_Type'(New_Item);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check
+ -- in case the actual type is class-wide or has access
+ -- discriminants (see RM 4.8(10.1) and AI12-0035).
+ begin
+ E (Idx) := new Element_Type'(New_Item);
+ end;
-- The allocation of the element succeeded, so it is now
-- safe to update the Last index, restoring container
-- K always has a value if the exception handler triggers.
K := Before;
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in
+ -- the case the actual type is class-wide or has access
+ -- discriminants (see RM 4.8(10.1) and AI12-0035).
begin
while K < Index loop
E (K) := new Element_Type'(New_Item);
-- because there is no storage available, or because element
-- initialization fails).
- Dst.EA (Idx) := new Element_Type'(New_Item);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in
+ -- the case the actual type is class-wide or has access
+ -- discriminants (see RM 4.8(10.1) and AI12-0035).
+ begin
+ Dst.EA (Idx) := new Element_Type'(New_Item);
+ end;
-- The allocation of the element succeeded, so it is now safe
-- to update the Last index, restoring container invariants.
-- already been updated), so if this allocation fails we simply
-- let it propagate.
- Dst.EA (Idx) := new Element_Type'(New_Item);
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in
+ -- the case the actual type is class-wide or has access
+ -- discriminants (see RM 4.8(10.1) and AI12-0035).
+ begin
+ Dst.EA (Idx) := new Element_Type'(New_Item);
+ end;
end loop;
end if;
end;
declare
X : Element_Access := Container.Elements.EA (Index);
+
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- where the actual type is class-wide or has access discriminants
+ -- (see RM 4.8(10.1) and AI12-0035).
begin
Container.Elements.EA (Index) := new Element_Type'(New_Item);
Free (X);
declare
X : Element_Access := Container.Elements.EA (Position.Index);
+
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- where the actual type is class-wide or has access discriminants
+ -- (see RM 4.8(10.1) and AI12-0035).
begin
Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
Free (X);
Last := Index_Type'First;
+ declare
+ pragma Unsuppress (Accessibility_Check);
+ -- The element allocator may need an accessibility check in the case
+ -- where the actual type is class-wide or has access discriminants
+ -- (see RM 4.8(10.1) and AI12-0035).
begin
loop
Elements.EA (Last) := new Element_Type'(New_Item);
-- Ada 2005 (AI-344): For an allocator with a class-wide designated
-- type, generate an accessibility check to verify that the level of the
-- type of the created object is not deeper than the level of the access
- -- type. If the type of the qualified expression is class- wide, then
+ -- type. If the type of the qualified expression is class-wide, then
-- always generate the check (except in the case where it is known to be
-- unnecessary, see comment below). Otherwise, only generate the check
-- if the level of the qualified expression type is statically deeper
(Ref : Node_Id;
Built_In_Place : Boolean := False)
is
- New_Node : Node_Id;
+ Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
+ Cond : Node_Id;
+ Free_Stmt : Node_Id;
+ Obj_Ref : Node_Id;
+ Stmts : List_Id;
begin
if Ada_Version >= Ada_2005
or else
(Is_Class_Wide_Type (Etype (Exp))
and then Scope (PtrT) /= Current_Scope))
+ and then
+ (Tagged_Type_Expansion or else VM_Target /= No_VM)
then
-- If the allocator was built in place, Ref is already a reference
-- to the access object initialized to the result of the allocator
if Built_In_Place then
Remove_Side_Effects (Ref);
- New_Node := New_Copy (Ref);
+ Obj_Ref := New_Copy (Ref);
else
- New_Node := New_Reference_To (Ref, Loc);
+ Obj_Ref := New_Reference_To (Ref, Loc);
+ end if;
+
+ -- Step 1: Create the object clean up code
+
+ Stmts := New_List;
+
+ -- Create an explicit free statement to clean up the allocated
+ -- object in case the accessibility check fails. Generate:
+
+ -- Free (Obj_Ref);
+
+ Free_Stmt := Make_Free_Statement (Loc, New_Copy (Obj_Ref));
+ Set_Storage_Pool (Free_Stmt, Pool_Id);
+
+ Append_To (Stmts, Free_Stmt);
+
+ -- Finalize the object (if applicable), but wrap the call inside
+ -- a block to ensure that the object would still be deallocated in
+ -- case the finalization fails. Generate:
+
+ -- begin
+ -- [Deep_]Finalize (Obj_Ref.all);
+ -- exception
+ -- when others =>
+ -- Free (Obj_Ref);
+ -- raise;
+ -- end;
+
+ if Needs_Finalization (DesigT) then
+ Prepend_To (Stmts,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Final_Call (
+ Obj_Ref =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Copy (Obj_Ref)),
+ Typ => DesigT)),
+
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (
+ New_Copy_Tree (Free_Stmt),
+ Make_Raise_Statement (Loc)))))));
end if;
- New_Node :=
+ -- Signal the accessibility failure through a Program_Error
+
+ Append_To (Stmts,
+ Make_Raise_Program_Error (Loc,
+ Condition => New_Reference_To (Standard_True, Loc),
+ Reason => PE_Accessibility_Check_Failed));
+
+ -- Step 2: Create the accessibility comparison
+
+ -- Generate:
+ -- Ref'Tag
+
+ Obj_Ref :=
Make_Attribute_Reference (Loc,
- Prefix => New_Node,
+ Prefix => Obj_Ref,
Attribute_Name => Name_Tag);
+ -- For tagged types, determine the accessibility level by looking
+ -- at the type specific data of the dispatch table. Generate:
+
+ -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
+
if Tagged_Type_Expansion then
- New_Node := Build_Get_Access_Level (Loc, New_Node);
+ Cond := Build_Get_Access_Level (Loc, Obj_Ref);
- elsif VM_Target /= No_VM then
- New_Node :=
- Make_Function_Call (Loc,
- Name => New_Reference_To (RTE (RE_Get_Access_Level), Loc),
- Parameter_Associations => New_List (New_Node));
+ -- Use a runtime call to determine the accessibility level when
+ -- compiling on virtual machine targets. Generate:
- -- Cannot generate the runtime check
+ -- Get_Access_Level (Ref'Tag)
else
- return;
+ Cond :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Get_Access_Level), Loc),
+ Parameter_Associations => New_List (Obj_Ref));
end if;
+ Cond :=
+ Make_Op_Gt (Loc,
+ Left_Opnd => Cond,
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Type_Access_Level (PtrT)));
+
+ -- Due to the complexity and side effects of the check, utilize an
+ -- if statement instead of the regular Program_Error circuitry.
+
Insert_Action (N,
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => New_Node,
- Right_Opnd =>
- Make_Integer_Literal (Loc, Type_Access_Level (PtrT))),
- Reason => PE_Accessibility_Check_Failed));
+ Make_If_Statement (Loc,
+ Condition => Cond,
+ Then_Statements => Stmts));
end if;
end Apply_Accessibility_Check;
("(style) IN should be omitted");
end if;
- if Token = Tok_Access then
+ -- Since Ada 2005, formal objects can have an anonymous access type,
+ -- and of course carry a mode indicator.
+
+ if Token = Tok_Access
+ and then Nkind (Node) /= N_Formal_Object_Declaration
+ then
Error_Msg_SP ("IN not allowed together with ACCESS");
Scan; -- past ACCESS
end if;
is explicitly specified.
@xref{Naming Schemes}.
-@item @code{Source Files}
- @cindex @code{Source_Files}
+@item @code{Source_Files}
+@cindex @code{Source_Files}
In some cases, source directories might contain files that should not be
included in a project. One can specify the explicit list of file names to
be considered through the @b{Source_Files} attribute.
function Try_Container_Indexing
(N : Node_Id;
Prefix : Node_Id;
- Expr : Node_Id) return Boolean;
+ Exprs : List_Id) return Boolean;
-- AI05-0139: Generalized indexing to support iterators over containers
function Try_Indexed_Call
then
return;
- elsif Try_Container_Indexing (N, P, Exp) then
+ elsif Try_Container_Indexing (N, P, Exprs) then
return;
elsif Array_Type = Any_Type then
end;
end if;
- elsif Try_Container_Indexing (N, P, First (Exprs)) then
+ elsif Try_Container_Indexing (N, P, Exprs) then
return;
end if;
function Try_Container_Indexing
(N : Node_Id;
Prefix : Node_Id;
- Expr : Node_Id) return Boolean
+ Exprs : List_Id) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
+ Assoc : List_Id;
Disc : Entity_Id;
Func : Entity_Id;
Func_Name : Node_Id;
if Has_Implicit_Dereference (Etype (Prefix)) then
Build_Explicit_Dereference
(Prefix, First_Discriminant (Etype (Prefix)));
- return Try_Container_Indexing (N, Prefix, Expr);
+ return Try_Container_Indexing (N, Prefix, Exprs);
else
return False;
end if;
end if;
+ Assoc := New_List (Relocate_Node (Prefix));
+
+ -- A generalized iterator may have nore than one index expression, so
+ -- transfer all of them to the argument list to be used in the call.
+
+ declare
+ Arg : Node_Id;
+
+ begin
+ Arg := First (Exprs);
+ while Present (Arg) loop
+ Append (Relocate_Node (Arg), Assoc);
+ Next (Arg);
+ end loop;
+ end;
+
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)));
+ Parameter_Associations => Assoc);
Rewrite (N, Indexing);
Analyze (N);
else
Indexing := Make_Function_Call (Loc,
Name => Make_Identifier (Loc, Chars (Func_Name)),
- Parameter_Associations =>
- New_List (Relocate_Node (Prefix), Relocate_Node (Expr)));
+ Parameter_Associations => Assoc);
Rewrite (N, Indexing);
end if;
if Etype (N) = Any_Type then
- Error_Msg_NE ("container cannot be indexed with&", N, Etype (Expr));
+ Error_Msg_NE ("container cannot be indexed with&",
+ N, Etype (First (Exprs)));
Rewrite (N, New_Occurrence_Of (Any_Id, Loc));
else
Analyze (N);
Loc : constant Source_Ptr := Sloc (N);
New_N : Node_Id;
P : constant Node_Id := Prefix (N);
+
+ P_Typ : Entity_Id;
+ -- The candidate prefix type, if overloaded
+
I : Interp_Index;
It : Interp;
begin
Check_Fully_Declared_Prefix (Typ, P);
+ P_Typ := Empty;
if Is_Overloaded (P) then
-- designated type.
Get_First_Interp (P, I, It);
+
while Present (It.Typ) loop
- exit when Is_Access_Type (It.Typ)
- and then Covers (Typ, Designated_Type (It.Typ));
+ if Is_Access_Type (It.Typ)
+ and then Covers (Typ, Designated_Type (It.Typ))
+ then
+ P_Typ := It.Typ;
+
+ -- Remove access types that do not match, but preserve access
+ -- to subprogram interpretations, in case a further dereference
+ -- is needed (see below).
+
+ elsif Ekind (It.Typ) /= E_Access_Subprogram_Type then
+ Remove_Interp (I);
+ end if;
+
Get_Next_Interp (I, It);
end loop;
- if Present (It.Typ) then
- Resolve (P, It.Typ);
+ if Present (P_Typ) then
+ Resolve (P, P_Typ);
+ Set_Etype (N, Designated_Type (P_Typ));
+
else
-- If no interpretation covers the designated type of the prefix,
-- this is the pathological case where not all implementations of
return;
end if;
- Set_Etype (N, Designated_Type (It.Typ));
-
else
+ -- If not overloaded, resolve P with its own type
+
Resolve (P);
end if;
projects / platform / upstream / linaro-gcc.git / commitdiff