+2011-08-29 Yannick Moy <moy@adacore.com>
+
+ * gnat1drv.adb (Adjust_Global_Switches): Restore expansion of tagged
+ types and dispatching calls in Alfa mode.
+ * lib-xref-alfa.adb (Collect_ALFA): Rewrite computation of
+ correspondance between body and spec scopes, to reuse utility functions
+ (Traverse_Declarations_Or_Statements): Protect access to body for stub
+ by testing the presence of the library unit for the body
+ * sem_ch6.adb (Set_Actual_Subtypes): take into account that in Alfa
+ mode the expansion of accept statements is skipped
+ * sem_util.adb, sem_util.ads (Unique_Entity): New function returning
+ the unique entity corresponding to the one returned by
+ Unique_Defining_Entity applied to the enclosing declaration of the
+ argument.
+
+2011-08-29 Bob Duff <duff@adacore.com>
+
+ * treepr.ads: Improve debugging facilities. pn(x) no longer crashes in
+ gdb when x is not a node (it can be a node list, name_id, etc). pp is
+ an alias for pn. ppp is an alias for pt.
+
+2011-08-29 Javier Miranda <miranda@adacore.com>
+
+ * exp_aggr.adb (Expand_Record_Aggregate): Use the top-level enclosing
+ aggregate to take a consistent decision on the need to convert into
+ assignments aggregates that initialize constant objects.
+
+2011-08-29 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch4.adb (Expand_Allocator_Expression): Add a call to
+ Build_Allocate_Deallocate_Proc in order to handle allocation of
+ non-controlled objects on subpools.
+ * impunit.adb: Remove s-finmas and s-spsufi since they were never meant
+ to be end-user visible.
+ * s-finmas.adb: Add with and use clause for System.HTable.
+ Add an instantiation of Simple_HTable which provides a mapping between
+ the address of a controlled object and the corresponding
+ Finalize_Address used to clean up the object. The table is used when a
+ master is operating in heterogeneous mode.
+ (Attach): Explain why the input node is not verified on being already
+ attached.
+ (Delete_Finalize_Address): New routine.
+ (Detach): Add pragma Assert which ensures that a node is already
+ attached.
+ (Finalize): Add local variable Cleanup. Rewrite the iteration scheme
+ since nodes are no longer removed on traversal. Explain why node
+ detachment is undesirable in this case.
+ (Get_Finalize_Address): New routine.
+ (Hash): New routine.
+ (Is_Empty_List): Removed.
+ (pm): Renamed to Print_Master. Add output for discriminant
+ Is_Homogeneous.
+ Comment reformatting.
+ (Set_Finalize_Address (Address, Finalize_Address_Ptr)): New routine.
+ * s-finmas.ads: Various comments additions / improvements.
+ Type Finalization_Master has a discriminant which determines the mode of
+ operation.
+ (Delete_Finalize_Address): New routine.
+ (Get_Finalize_Address): New routine.
+ (pm): Renamed to Print_Master.
+ (Set_Finalize_Address (Address, Finalize_Address_Ptr)): New routine.
+ * s-stposu.adb: Add with clause for System.Address_Image; Add with and
+ use clause for System.IO.
+ (Allocate_Any_Controlled): Add machinery to set TSS primitive
+ Finalize_Address depending on the mode of allocation and the mode of
+ the master.
+ (Deallocate_Any_Controlled): Remove the relation pair object -
+ Finalize_Address regardless of the master mode. Add comment explaining
+ the reason.
+ (Detach): Ensure that fields Prev and Next are null after detachment.
+ (Finalize_Pool): Remove local variable Next_Ptr. Rewrite the iteration
+ scheme to check whether the list of subpools is empty. There is no
+ longer need to store the next subpool or advance the current pointer.
+ (Is_Empty_List): New routine.
+ (Print_Pool): New routine.
+ (Print_Subpool): New routine.
+ * s-stposu.ads: Various comments additions / improvements.
+ Field Master of type Root_Subpool is now a heterogeneous collection.
+ (Print_Pool): New routine.
+ (Print_Subpool): New routine.
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch5.adb (Expand_N_Iterator_Loop): Implement Ada2012 loop iterator
+ forms, using aspects of container types.
+ * sem_ch3.adb (Find_Type_Name): Preserve Has_Delayed_Aspects and
+ Has_Implicit_Dereference flags, that may be set on the partial view.
+ * sem_ch4.adb (Process_Overloaded_Indexed_Component): Prefix may be a
+ container type with an indexing aspect.
+ (Analyze_Quantified_Expression): Analyze construct with expansion
+ disabled, because it will be rewritten as a loop during expansion.
+ (Try_Container_Indexing): The prefix itself may be a container type
+ with an indexing aspect, as with a vector of vectors.
+ * sem_ch5.adb (Analyze_Iteration_Scheme): In a generic context, analyze
+ the original doamin of iteration, for name capture.
+ (Analyze_Iterator_Specification): If the domain is an expression that
+ needs finalization, create a separate declaration for it.
+ For an iterator with "of" retrieve default iterator info from aspect of
+ container type. For "in" iterator, retrieve type of Iterate function.
+ * sem_ch13.adb (Check_Iterator_Function): Fix typo.
+ (Check_Aspect_At_End_Of_Declaration): Make type unfrozen before
+ analysis, to prevent spurious errors about late attributes.
+ * sprint.adb: Handle quantified expression with either loop or iterator
+ specification.
+ * a-convec.ads, a-convec.adb: Iterate function returns a reversible
+ iterator.
+
2011-08-29 Vincent Celier <celier@adacore.com>
* make.adb (Scan_Make_Arg): Take any option as is in packages Compiler,
end Iterate;
function Iterate (Container : Vector; Start : Cursor)
- return Vector_Iterator_Interfaces.Forward_Iterator'Class
+ return Vector_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator :=
(Container'Unchecked_Access, Start.Index);
return Vector_Iterator_Interfaces.Reversible_Iterator'Class;
function Iterate (Container : Vector; Start : Cursor)
- return Vector_Iterator_Interfaces.Forward_Iterator'Class;
+ return Vector_Iterator_Interfaces.Reversible_Iterator'class;
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
-- semantics of Ada complicate the analysis and lead to anomalies in
-- the gcc back-end if the aggregate is not expanded into assignments.
+ function Has_Visible_Private_Ancestor (Id : E) return Boolean;
+ -- If any ancestor of the current type is private, the aggregate
+ -- cannot be built in place. We canot rely on Has_Private_Ancestor,
+ -- because it will not be set when type and its parent are in the
+ -- same scope, and the parent component needs expansion.
+
+ function Top_Level_Aggregate (N : Node_Id) return Node_Id;
+ -- For nested aggregates return the ultimate enclosing aggregate; for
+ -- non-nested aggregates return N.
+
----------------------------------
-- Component_Not_OK_For_Backend --
----------------------------------
return False;
end Component_Not_OK_For_Backend;
- -- Remaining Expand_Record_Aggregate variables
-
- Tag_Value : Node_Id;
- Comp : Entity_Id;
- New_Comp : Node_Id;
-
- function Has_Visible_Private_Ancestor (Id : E) return Boolean;
- -- If any ancestor of the current type is private, the aggregate
- -- cannot be built in place. We canot rely on Has_Private_Ancestor,
- -- because it will not be set when type and its parent are in the
- -- same scope, and the parent component needs expansion.
-
-----------------------------------
-- Has_Visible_Private_Ancestor --
-----------------------------------
function Has_Visible_Private_Ancestor (Id : E) return Boolean is
R : constant Entity_Id := Root_Type (Id);
T1 : Entity_Id := Id;
+
begin
loop
if Is_Private_Type (T1) then
end loop;
end Has_Visible_Private_Ancestor;
+ -------------------------
+ -- Top_Level_Aggregate --
+ -------------------------
+
+ function Top_Level_Aggregate (N : Node_Id) return Node_Id is
+ Aggr : Node_Id := N;
+
+ begin
+ while Present (Parent (Aggr))
+ and then Nkind_In (Parent (Aggr), N_Component_Association,
+ N_Aggregate)
+ loop
+ Aggr := Parent (Aggr);
+ end loop;
+
+ return Aggr;
+ end Top_Level_Aggregate;
+
+ -- Local variables
+
+ Top_Level_Aggr : constant Node_Id := Top_Level_Aggregate (N);
+ Tag_Value : Node_Id;
+ Comp : Entity_Id;
+ New_Comp : Node_Id;
+
-- Start of processing for Expand_Record_Aggregate
begin
elsif Has_Mutable_Components (Typ)
and then
- (Nkind (Parent (N)) /= N_Object_Declaration
- or else not Constant_Present (Parent (N)))
+ (Nkind (Parent (Top_Level_Aggr)) /= N_Object_Declaration
+ or else not Constant_Present (Parent (Top_Level_Aggr)))
then
Convert_To_Assignments (N, Typ);
Rewrite (Exp, New_Copy (Expression (Exp)));
end if;
else
+ Build_Allocate_Deallocate_Proc (N, True);
+
-- If we have:
-- type A is access T1;
-- X : A := new T2'(...);
Container : constant Node_Id := Name (I_Spec);
Container_Typ : constant Entity_Id := Etype (Container);
Cursor : Entity_Id;
+ Iterator : Entity_Id;
New_Loop : Node_Id;
Stats : List_Id := Statements (N);
-- the array.
if Of_Present (I_Spec) then
- Cursor := Make_Temporary (Loc, 'C');
+ Iterator := Make_Temporary (Loc, 'C');
-- Generate:
- -- Element : Component_Type renames Container (Cursor);
+ -- Element : Component_Type renames Container (Iterator);
Prepend_To (Stats,
Make_Object_Renaming_Declaration (Loc,
Make_Indexed_Component (Loc,
Prefix => Relocate_Node (Container),
Expressions => New_List (
- New_Reference_To (Cursor, Loc)))));
+ New_Reference_To (Iterator, Loc)))));
-- for Index in Array loop
--
- -- This case utilizes the already given cursor name
+ -- This case utilizes the already given iterator name
else
- Cursor := Id;
+ Iterator := Id;
end if;
-- Generate:
- -- for Cursor in [reverse] Container'Range loop
- -- Element : Component_Type renames Container (Cursor);
+ -- for Iterator in [reverse] Container'Range loop
+ -- Element : Component_Type renames Container (Iterator);
-- -- for the "of" form
--
-- <original loop statements>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Cursor,
+ Defining_Identifier => Iterator,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Container),
-- Processing for containers
else
+ -- For an iterator of the form "Of" then name is some expression,
+ -- which is transformed into a call to the default iterator.
+
+ -- For an iterator of the form "in" then name is a function call
+ -- that delivers an iterator.
+
-- The for loop is expanded into a while loop which uses a container
-- specific cursor to examine each element.
- -- Cursor : Pack.Cursor := Container.First;
- -- while Cursor /= Pack.No_Element loop
+ -- Iter : Iterator_Type := Container.Iterate;
+ -- Cursor : Cursor_type := First (Iter);
+ -- while Has_Element (Iter) loop
-- declare
-- -- the block is added when Element_Type is controlled
- -- Obj : Pack.Element_Type := Element (Cursor);
+ -- Obj : Pack.Element_Type := Element (Iterator);
-- -- for the "of" loop form
-- begin
-- <original loop statements>
-- end;
- -- Pack.Next (Cursor);
+ -- Cursor := Iter.Next (Cursor);
-- end loop;
-- If "reverse" is present, then the initialization of the cursor
declare
Element_Type : constant Entity_Id := Etype (Id);
- Pack : constant Entity_Id :=
- Scope (Base_Type (Container_Typ));
+ Pack : Entity_Id;
Decl : Node_Id;
- Cntr : Node_Id;
Name_Init : Name_Id;
Name_Step : Name_Id;
begin
- -- The "of" case uses an internally generated cursor
+ if Is_Entity_Name (Container) then
+ Pack := Scope (Etype (Container));
+
+ else
+ Pack := Scope (Entity (Name (Container)));
+ end if;
+
+ -- The "of" case uses an internally generated cursor whose type
+ -- is found in the container package.
if Of_Present (I_Spec) then
- Cursor := Make_Temporary (Loc, 'C');
+ Cursor := Make_Temporary (Loc, 'I');
+
+ declare
+ Ent : Entity_Id;
+ begin
+ Ent := First_Entity (Pack);
+ while Present (Ent) loop
+ if Chars (Ent) = Name_Cursor then
+ Set_Etype (Cursor, Etype (Ent));
+ exit;
+ end if;
+ Next_Entity (Ent);
+ end loop;
+ end;
+
else
Cursor := Id;
end if;
- -- The code below only handles containers where Element is not a
- -- primitive operation of the container. This excludes for now the
- -- Hi-Lite formal containers.
+ Iterator := Make_Temporary (Loc, 'I');
if Of_Present (I_Spec) then
-- Generate:
- -- Id : Element_Type := Pack.Element (Cursor);
+ -- Id : Element_Type renames Pack.Element (Cursor);
Decl :=
Make_Object_Renaming_Declaration (Loc,
Selector_Name =>
Make_Identifier (Loc, Chars => Name_Element)),
Expressions => New_List (
- New_Reference_To (Cursor, Loc))));
+ New_Occurrence_Of (Cursor, Loc))));
-- When the container holds controlled objects, wrap the loop
-- statements and element renaming declaration with a block.
- -- This ensures that the transient result of Element (Cursor)
+ -- This ensures that the transient result of Element (Iterator)
-- is cleaned up after each iteration of the loop.
if Needs_Finalization (Element_Type) then
-- Generate:
-- declare
- -- Id : Element_Type := Pack.Element (Cursor);
+ -- Id : Element_Type := Pack.Element (Iterator);
-- begin
-- <original loop statements>
-- end;
-- For both iterator forms, add a call to the step operation to
-- advance the cursor. Generate:
--
- -- Pack.[Next | Prev] (Cursor);
+ -- Cursor := Iterator.Next (Cursor);
+ -- or else
+ -- Cursor := Next (Cursor);
- Append_To (Stats,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Reference_To (Pack, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Step)),
+ declare
+ Rhs : Node_Id;
+ begin
+ if Of_Present (I_Spec) then
+ Rhs :=
+ Make_Function_Call (Loc,
+ Name => Make_Identifier (Loc, Name_Step),
+ Parameter_Associations =>
+ New_List (New_Reference_To (Cursor, Loc)));
+ else
+ Rhs :=
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Iterator, Loc),
+ Selector_Name => Make_Identifier (Loc, Name_Step)),
+ Parameter_Associations => New_List (
+ New_Reference_To (Cursor, Loc)));
+ end if;
- Parameter_Associations => New_List (
- New_Reference_To (Cursor, Loc))));
+ Append_To (Stats,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Cursor, Loc),
+ Expression => Rhs));
+ end;
-- Generate:
- -- while Cursor /= Pack.No_Element loop
+ -- while Iterator.Has_Element loop
-- <Stats>
-- end loop;
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd =>
- New_Reference_To (Cursor, Loc),
- Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
Make_Selected_Component (Loc,
- Prefix =>
- New_Reference_To (Pack, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_No_Element)))),
+ Prefix => New_Occurrence_Of (Pack, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Has_Element)),
+
+ Parameter_Associations =>
+ New_List (
+ New_Reference_To (Cursor, Loc)))),
Statements => Stats,
End_Label => Empty);
- Cntr := Relocate_Node (Container);
-
- -- When the container is provided by a function call, create an
- -- explicit renaming of the function result. Generate:
- --
- -- Cnn : Container_Typ renames Func_Call (...);
+ -- Create the declarations for Iterator and cursor and insert then
+ -- before the source loop. Generate:
--
- -- The renaming avoids the generation of a transient scope when
- -- initializing the cursor and the premature finalization of the
- -- container.
+ -- I : Iterator_Type := Iterate (Container);
+ -- C : Pack.Cursor_Type := Container.[First | Last];
- if Nkind (Cntr) = N_Function_Call then
- declare
- Ren_Id : constant Entity_Id := Make_Temporary (Loc, 'C');
+ declare
+ Decl1 : Node_Id;
+ Decl2 : Node_Id;
+ begin
+ Decl1 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Iterator,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Name (I_Spec)), Loc),
- begin
- Insert_Action (N,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Ren_Id,
- Subtype_Mark =>
- New_Reference_To (Container_Typ, Loc),
- Name => Cntr));
-
- Cntr := New_Reference_To (Ren_Id, Loc);
- end;
- end if;
+ Expression => Relocate_Node (Name (I_Spec)));
+ Set_Assignment_OK (Decl1);
- -- Create the declaration of the cursor and insert it before the
- -- source loop. Generate:
- --
- -- C : Pack.Cursor_Type := Container.[First | Last];
+ Decl2 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Cursor,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Cursor), Loc),
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Cursor,
- Object_Definition =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Reference_To (Pack, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Cursor)),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Iterator, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Init)));
- Expression =>
- Make_Selected_Component (Loc,
- Prefix => Cntr,
- Selector_Name =>
- Make_Identifier (Loc, Name_Init))));
+ Set_Assignment_OK (Decl2);
+
+ Insert_Actions (N,
+ New_List (Decl1, Decl2));
+ end;
- -- The cursor is not modified in the source, but of course will
+ -- The Iterator is not modified in the source, but of course will
-- be updated in the generated code. Indicate that it is actually
-- set to prevent spurious warnings.
- Set_Never_Set_In_Source (Cursor, False);
+ Set_Never_Set_In_Source (Iterator, False);
-- If the range of iteration is given by a function call that
-- returns a container, the finalization actions have been saved
Global_Discard_Names := True;
- -- Suppress the expansion of tagged types and dispatching calls
+ -- We would prefer to suppress the expansion of tagged types and
+ -- dispatching calls, so that one day GNATprove can handle them
+ -- directly. Unfortunately, this is causing problems on H513-015, so
+ -- keep this expansion for the time being.
- Tagged_Type_Expansion := False;
+ Tagged_Type_Expansion := True;
end if;
end Adjust_Global_Switches;
"s-addima", -- System.Address_Image
"s-assert", -- System.Assertions
- "s-finmas", -- System.Finalization_Masters
"s-memory", -- System.Memory
"s-parint", -- System.Partition_Interface
"s-pooglo", -- System.Pool_Global
-- GNAT Defined Additions to Ada 20012 --
-----------------------------------------
- "s-spsufi", -- System.Storage_Pools.Subpools.Finalization
"a-cofove", -- Ada.Containers.Formal_Vectors
"a-cfdlli", -- Ada.Containers.Formal_Doubly_Linked_Lists
"a-cforse", -- Ada.Containers.Formal_Ordered_Sets
declare
Srec : ALFA_Scope_Record renames ALFA_Scope_Table.Table (S);
- Body_Entity : Entity_Id;
- Spec_Entity : Entity_Id;
- Spec_Scope : Scope_Index;
+ Spec_Entity : constant Entity_Id :=
+ Unique_Entity (Srec.Scope_Entity);
+ Spec_Scope : constant Scope_Index :=
+ Entity_Hash_Table.Get (Spec_Entity);
begin
- if Ekind (Srec.Scope_Entity) = E_Subprogram_Body then
- Body_Entity := Parent (Parent (Srec.Scope_Entity));
- elsif Ekind (Srec.Scope_Entity) = E_Package_Body then
- Body_Entity := Parent (Srec.Scope_Entity);
- else
- Body_Entity := Empty;
- end if;
-
- if Present (Body_Entity) then
- if Nkind (Body_Entity) = N_Defining_Program_Unit_Name then
- Body_Entity := Parent (Body_Entity);
- elsif Nkind (Body_Entity) = N_Subprogram_Body_Stub then
- Body_Entity :=
- Proper_Body (Unit (Library_Unit (Body_Entity)));
- end if;
-
- Spec_Entity := Corresponding_Spec (Body_Entity);
- Spec_Scope := Entity_Hash_Table.Get (Spec_Entity);
-
- -- Spec of generic may be missing
+ -- Spec of generic may be missing, in which case Spec_Scope is
+ -- zero.
- if Spec_Scope /= 0 then
- Srec.Spec_File_Num :=
- ALFA_Scope_Table.Table (Spec_Scope).File_Num;
- Srec.Spec_Scope_Num :=
- ALFA_Scope_Table.Table (Spec_Scope).Scope_Num;
- end if;
+ if Spec_Entity /= Srec.Scope_Entity
+ and then Spec_Scope /= 0
+ then
+ Srec.Spec_File_Num :=
+ ALFA_Scope_Table.Table (Spec_Scope).File_Num;
+ Srec.Spec_Scope_Num :=
+ ALFA_Scope_Table.Table (Spec_Scope).Scope_Num;
end if;
end;
end loop;
end if;
when N_Package_Body_Stub =>
- declare
- Body_N : constant Node_Id := Get_Body_From_Stub (N);
- begin
- if Inside_Stubs
- and then
- Ekind (Defining_Entity (Body_N)) /= E_Generic_Package
- then
- Traverse_Package_Body (Body_N, Process, Inside_Stubs);
- end if;
- end;
+ if Present (Library_Unit (N)) then
+ declare
+ Body_N : constant Node_Id := Get_Body_From_Stub (N);
+ begin
+ if Inside_Stubs
+ and then
+ Ekind (Defining_Entity (Body_N)) /= E_Generic_Package
+ then
+ Traverse_Package_Body (Body_N, Process, Inside_Stubs);
+ end if;
+ end;
+ end if;
-- Subprogram declaration
end if;
when N_Subprogram_Body_Stub =>
- declare
- Body_N : constant Node_Id := Get_Body_From_Stub (N);
- begin
- if Inside_Stubs
- and then
- not Is_Generic_Subprogram (Defining_Entity (Body_N))
- then
- Traverse_Subprogram_Body (Body_N, Process, Inside_Stubs);
- end if;
- end;
+ if Present (Library_Unit (N)) then
+ declare
+ Body_N : constant Node_Id := Get_Body_From_Stub (N);
+ begin
+ if Inside_Stubs
+ and then
+ not Is_Generic_Subprogram (Defining_Entity (Body_N))
+ then
+ Traverse_Subprogram_Body
+ (Body_N, Process, Inside_Stubs);
+ end if;
+ end;
+ end if;
-- Block statement
with Ada.Exceptions; use Ada.Exceptions;
with System.Address_Image;
+with System.HTable; use System.HTable;
with System.IO; use System.IO;
with System.Soft_Links; use System.Soft_Links;
with System.Storage_Elements; use System.Storage_Elements;
package body System.Finalization_Masters is
+ -- Finalize_Address hash table types. In general, masters are homogeneous
+ -- collections of controlled objects. Rare cases such as allocations on a
+ -- subpool require heterogeneous masters. The following table provides a
+ -- relation between object address and its Finalize_Address routine.
+
+ type Header_Num is range 0 .. 127;
+
+ function Hash (Key : System.Address) return Header_Num;
+
+ -- Address --> Finalize_Address_Ptr
+
+ package Finalize_Address_Table is new Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Finalize_Address_Ptr,
+ No_Element => null,
+ Key => System.Address,
+ Hash => Hash,
+ Equal => "=");
+
---------------------------
-- Add_Offset_To_Address --
---------------------------
return Master.Base_Pool;
end Base_Pool;
+ -----------------------------
+ -- Delete_Finalize_Address --
+ -----------------------------
+
+ procedure Delete_Finalize_Address (Obj : System.Address) is
+ begin
+ Lock_Task.all;
+ Finalize_Address_Table.Remove (Obj);
+ Unlock_Task.all;
+ end Delete_Finalize_Address;
+
------------
-- Detach --
------------
N.Next := null;
Unlock_Task.all;
- end if;
- -- Note: No need to unlock in case of an exception because the above
- -- code can never raise one.
+ -- Note: No need to unlock in case of an exception because the above
+ -- code can never raise one.
+ end if;
end Detach;
--------------
--------------
overriding procedure Finalize (Master : in out Finalization_Master) is
+ Cleanup : Finalize_Address_Ptr;
Curr_Ptr : FM_Node_Ptr;
Ex_Occur : Exception_Occurrence;
Obj_Addr : Address;
Detach (Curr_Ptr);
- if Master.Finalize_Address /= null then
+ -- Skip the list header in order to offer proper object layout for
+ -- finalization.
+
+ Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
+
+ -- Retrieve TSS primitive Finalize_Address depending on the master's
+ -- mode of operation.
+
+ if Master.Is_Homogeneous then
+ Cleanup := Master.Finalize_Address;
+ else
+ Cleanup := Get_Finalize_Address (Obj_Addr);
+ end if;
+
+ -- If Finalize_Address is not available, then this is most likely an
+ -- error in the expansion of the designated type or the allocator.
+
+ pragma Assert (Cleanup /= null);
- -- Skip the list header in order to offer proper object layout for
- -- finalization and call Finalize_Address.
+ begin
+ Cleanup (Obj_Addr);
- Obj_Addr := Curr_Ptr.all'Address + Header_Offset;
+ exception
+ when Fin_Occur : others =>
+ if not Raised then
+ Raised := True;
+ Save_Occurrence (Ex_Occur, Fin_Occur);
+ end if;
+ end;
- begin
- Master.Finalize_Address (Obj_Addr);
+ -- When the master is a heterogeneous collection, destroy the object
+ -- - Finalize_Address pair since it is no longer needed.
- exception
- when Fin_Occur : others =>
- if not Raised then
- Raised := True;
- Save_Occurrence (Ex_Occur, Fin_Occur);
- end if;
- end;
+ if not Master.Is_Homogeneous then
+ Delete_Finalize_Address (Obj_Addr);
end if;
end loop;
end if;
end Finalize;
+ --------------------------
+ -- Get_Finalize_Address --
+ --------------------------
+
+ function Get_Finalize_Address
+ (Obj : System.Address) return Finalize_Address_Ptr
+ is
+ Result : Finalize_Address_Ptr;
+
+ begin
+ Lock_Task.all;
+ Result := Finalize_Address_Table.Get (Obj);
+ Unlock_Task.all;
+
+ return Result;
+ end Get_Finalize_Address;
+
-----------------
-- Header_Size --
-----------------
return FM_Node'Size / Storage_Unit;
end Header_Size;
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (Key : System.Address) return Header_Num is
+ begin
+ return
+ Header_Num
+ (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length));
+ end Hash;
+
-------------------
-- Header_Offset --
-------------------
Master.Objects.Prev := Master.Objects'Unchecked_Access;
end Initialize;
- --------
- -- pm --
- --------
+ ------------------
+ -- Print_Master --
+ ------------------
- procedure pm (Master : Finalization_Master) is
+ procedure Print_Master (Master : Finalization_Master) is
Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access;
Head_Seen : Boolean := False;
N_Ptr : FM_Node_Ptr;
-- Output the basic contents of a master
-- Master : 0x123456789
+ -- Is_Hmgen : TURE <or> FALSE
-- Base_Pool: null <or> 0x123456789
-- Fin_Addr : null <or> 0x123456789
-- Fin_Start: TRUE <or> FALSE
Put ("Master : ");
Put_Line (Address_Image (Master'Address));
- Put ("Base_Pool: ");
+ Put ("Is_Hmgen : ");
+ Put_Line (Master.Is_Homogeneous'Img);
+ Put ("Base_Pool: ");
if Master.Base_Pool = null then
- Put_Line (" null");
+ Put_Line ("null");
else
Put_Line (Address_Image (Master.Base_Pool'Address));
end if;
Put ("Fin_Addr : ");
-
if Master.Finalize_Address = null then
Put_Line ("null");
else
-- Header - the address of the list header
-- Prev - the address of the list header which the current element
- -- - points back to
+ -- points back to
-- Next - the address of the list header which the current element
- -- - points to
+ -- points to
-- (dummy head) - present if dummy head
N_Ptr := Head;
- while N_Ptr /= null loop -- Should never be null; we being defensive
+ while N_Ptr /= null loop -- Should never be null
Put_Line ("V");
-- We see the head initially; we want to exit when we see the head a
- -- SECOND time.
+ -- second time.
if N_Ptr = Head then
exit when Head_Seen;
N_Ptr := N_Ptr.Next;
end loop;
- end pm;
+ end Print_Master;
-------------------
-- Set_Base_Pool --
Master.Finalize_Address := Fin_Addr_Ptr;
end Set_Finalize_Address;
+ --------------------------
+ -- Set_Finalize_Address --
+ --------------------------
+
+ procedure Set_Finalize_Address
+ (Obj : System.Address;
+ Fin_Addr_Ptr : Finalize_Address_Ptr)
+ is
+ begin
+ Lock_Task.all;
+ Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
+ Unlock_Task.all;
+ end Set_Finalize_Address;
+
end System.Finalization_Masters;
with Ada.Finalization;
with Ada.Unchecked_Conversion;
-
with System.Storage_Elements;
with System.Storage_Pools;
-- Finalization master type structure. A unique master is associated with
-- each access-to-controlled or access-to-class-wide type. Masters also act
- -- as components of subpools.
+ -- as components of subpools. By default, a master contains objects of the
+ -- same designated type but it may also accomodate heterogeneous objects.
- type Finalization_Master is
+ type Finalization_Master (Is_Homogeneous : Boolean := True) is
new Ada.Finalization.Limited_Controlled with
record
Base_Pool : Any_Storage_Pool_Ptr := null;
-- objects allocated in a [sub]pool.
Finalize_Address : Finalize_Address_Ptr := null;
- -- A reference to the routine reponsible for object finalization
+ -- A reference to the routine reponsible for object finalization. This
+ -- is used only when the master is in homogeneous mode.
Finalization_Started : Boolean := False;
pragma Atomic (Finalization_Started);
-- Return a reference to the underlying storage pool on which the master
-- operates.
+ procedure Delete_Finalize_Address (Obj : System.Address);
+ -- Destroy the relation pair object - Finalize_Address from the internal
+ -- hash table.
+
procedure Detach (N : not null FM_Node_Ptr);
-- Remove a node from an arbitrary finalization master
-- the list of allocated controlled objects, finalizing each one by calling
-- its specific Finalize_Address. In the end, deallocate the dummy head.
+ function Get_Finalize_Address
+ (Obj : System.Address) return Finalize_Address_Ptr;
+ -- Retrieve the Finalize_Address primitive associated with a particular
+ -- object.
+
function Header_Offset return System.Storage_Elements.Storage_Offset;
-- Return the size of type FM_Node as Storage_Offset
overriding procedure Initialize (Master : in out Finalization_Master);
-- Initialize the dummy head of a finalization master
- procedure pm (Master : Finalization_Master);
+ procedure Print_Master (Master : Finalization_Master);
-- Debug routine, outputs the contents of a master
procedure Set_Base_Pool
Fin_Addr_Ptr : Finalize_Address_Ptr);
-- Set the clean up routine of a finalization master
+ procedure Set_Finalize_Address
+ (Obj : System.Address;
+ Fin_Addr_Ptr : Finalize_Address_Ptr);
+ -- Add a relation pair object - Finalize_Address to the internal hash table
+
end System.Finalization_Masters;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Deallocation;
-
+with System.Address_Image;
with System.Finalization_Masters; use System.Finalization_Masters;
+with System.IO; use System.IO;
with System.Soft_Links; use System.Soft_Links;
with System.Storage_Elements; use System.Storage_Elements;
-- +- Header_And_Padding --+
N_Ptr := Address_To_FM_Node_Ptr
- (N_Addr + Header_And_Padding - Header_Offset);
+ (N_Addr + Header_And_Padding - Header_Offset);
-- Prepend the allocated object to the finalization master
Attach (N_Ptr, Master.Objects'Unchecked_Access);
- if Master.Finalize_Address = null then
- Master.Finalize_Address := Fin_Address;
- end if;
-
-- Move the address from the hidden list header to the start of the
-- object. This operation effectively hides the list header.
Addr := N_Addr + Header_And_Padding;
+ -- Subpool allocations use heterogeneous masters to manage various
+ -- controlled objects. Associate a Finalize_Address with the object.
+ -- This relation pair is deleted when the object is deallocated or
+ -- when the associated master is finalized.
+
+ if Is_Subpool_Allocation then
+ pragma Assert (not Master.Is_Homogeneous);
+
+ Set_Finalize_Address (Addr, Fin_Address);
+
+ -- Normal allocations chain objects on homogeneous collections
+
+ else
+ pragma Assert (Master.Is_Homogeneous);
+
+ if Master.Finalize_Address = null then
+ Master.Finalize_Address := Fin_Address;
+ end if;
+ end if;
+
+ -- Non-controlled allocation
+
else
Addr := N_Addr;
end if;
if Is_Controlled then
+ -- Destroy the relation pair object - Finalize_Address since it is no
+ -- longer needed. If the object was chained on a homogeneous master,
+ -- this call does nothing. This is unconditional destruction since we
+ -- do not want to drag in additional data to determine the master
+ -- kind.
+
+ Delete_Finalize_Address (Addr);
+
-- Account for possible padding space before the header due to a
-- larger alignment.
N.Prev.Next := N.Next;
N.Next.Prev := N.Prev;
+ N.Prev := null;
+ N.Next := null;
Unlock_Task.all;
procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is
Curr_Ptr : SP_Node_Ptr;
Ex_Occur : Exception_Occurrence;
- Next_Ptr : SP_Node_Ptr;
Raised : Boolean := False;
+ function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean;
+ -- Determine whether a list contains only one element, the dummy head
+
+ -------------------
+ -- Is_Empty_List --
+ -------------------
+
+ function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is
+ begin
+ return L.Next = L and then L.Prev = L;
+ end Is_Empty_List;
+
+ -- Start of processing for Finalize_Pool
+
begin
-- It is possible for multiple tasks to cause the finalization of a
-- common pool. Allow only one task to finalize the contents.
Pool.Finalization_Started := True;
- -- Skip the dummy head
-
- Curr_Ptr := Pool.Subpools.Next;
- while Curr_Ptr /= Pool.Subpools'Unchecked_Access loop
- Next_Ptr := Curr_Ptr.Next;
+ while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop
+ Curr_Ptr := Pool.Subpools.Next;
-- Perform the following actions:
Save_Occurrence (Ex_Occur, Fin_Occur);
end if;
end;
-
- Curr_Ptr := Next_Ptr;
end loop;
-- If the finalization of a particular master failed, reraise the
return Subpool.Owner;
end Pool_Of_Subpool;
+ ----------------
+ -- Print_Pool --
+ ----------------
+
+ procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is
+ Head : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access;
+ Head_Seen : Boolean := False;
+ SP_Ptr : SP_Node_Ptr;
+
+ begin
+ -- Output the contents of the pool
+
+ -- Pool : 0x123456789
+ -- Subpools : 0x123456789
+ -- Fin_Start : TRUE <or> FALSE
+ -- Controller: OK <or> NOK
+
+ Put ("Pool : ");
+ Put_Line (Address_Image (Pool'Address));
+
+ Put ("Subpools : ");
+ Put_Line (Address_Image (Pool.Subpools'Address));
+
+ Put ("Fin_Start : ");
+ Put_Line (Pool.Finalization_Started'Img);
+
+ Put ("Controlled: ");
+ if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then
+ Put_Line ("OK");
+ else
+ Put_Line ("NOK (ERROR)");
+ end if;
+
+ SP_Ptr := Head;
+ while SP_Ptr /= null loop -- Should never be null
+ Put_Line ("V");
+
+ -- We see the head initially; we want to exit when we see the head a
+ -- second time.
+
+ if SP_Ptr = Head then
+ exit when Head_Seen;
+
+ Head_Seen := True;
+ end if;
+
+ -- The current element is null. This should never happend since the
+ -- list is circular.
+
+ if SP_Ptr.Prev = null then
+ Put_Line ("null (ERROR)");
+
+ -- The current element points back to the correct element
+
+ elsif SP_Ptr.Prev.Next = SP_Ptr then
+ Put_Line ("^");
+
+ -- The current element points to an erroneous element
+
+ else
+ Put_Line ("? (ERROR)");
+ end if;
+
+ -- Output the contents of the node
+
+ Put ("|Header: ");
+ Put (Address_Image (SP_Ptr.all'Address));
+ if SP_Ptr = Head then
+ Put_Line (" (dummy head)");
+ else
+ Put_Line ("");
+ end if;
+
+ Put ("| Prev: ");
+
+ if SP_Ptr.Prev = null then
+ Put_Line ("null");
+ else
+ Put_Line (Address_Image (SP_Ptr.Prev.all'Address));
+ end if;
+
+ Put ("| Next: ");
+
+ if SP_Ptr.Next = null then
+ Put_Line ("null");
+ else
+ Put_Line (Address_Image (SP_Ptr.Next.all'Address));
+ end if;
+
+ Put ("| Subp: ");
+
+ if SP_Ptr.Subpool = null then
+ Put_Line ("null");
+ else
+ Put_Line (Address_Image (SP_Ptr.Subpool.all'Address));
+ end if;
+
+ SP_Ptr := SP_Ptr.Next;
+ end loop;
+ end Print_Pool;
+
+ -------------------
+ -- Print_Subpool --
+ -------------------
+
+ procedure Print_Subpool (Subpool : Subpool_Handle) is
+ begin
+ if Subpool = null then
+ Put_Line ("null");
+ return;
+ end if;
+
+ -- Output the contents of a subpool
+
+ -- Owner : 0x123456789
+ -- Master: 0x123456789
+ -- Node : 0x123456789
+
+ Put ("Owner : ");
+ if Subpool.Owner = null then
+ Put_Line ("null");
+ else
+ Put_Line (Address_Image (Subpool.Owner'Address));
+ end if;
+
+ Put ("Master: ");
+ Put_Line (Address_Image (Subpool.Master'Address));
+
+ Put ("Node : ");
+ if Subpool.Node = null then
+ Put ("null");
+
+ if Subpool.Owner = null then
+ Put_Line (" OK");
+ else
+ Put_Line (" (ERROR)");
+ end if;
+ else
+ Put_Line (Address_Image (Subpool.Node'Address));
+ end if;
+
+ Print_Master (Subpool.Master);
+ end Print_Subpool;
+
-------------------------
-- Set_Pool_Of_Subpool --
-------------------------
------------------------------------------------------------------------------
with Ada.Finalization;
-
with System.Finalization_Masters;
with System.Storage_Elements;
Owner : Any_Storage_Pool_With_Subpools_Ptr := null;
-- A reference to the master pool_with_subpools
- Master : aliased System.Finalization_Masters.Finalization_Master;
- -- A collection of controlled objects
+ Master : aliased System.Finalization_Masters.Finalization_Master (False);
+ -- A heterogeneous collection of controlled objects
Node : SP_Node_Ptr := null;
-- A link to the doubly linked list node which contains the subpool.
procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools);
-- Setup the doubly linked list of subpools
+ procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools);
+ -- Debug routine, output the contents of a pool_with_subpools
+
+ procedure Print_Subpool (Subpool : Subpool_Handle);
+ -- Debug routine, output the contents of a subpool
+
end System.Storage_Pools.Subpools;
Get_First_Interp (Expr, I, It);
while Present (It.Nam) loop
if not Check_Primitive_Function (It.Nam)
- or else Valid_Default_Iterator (It.Nam)
+ or else not Valid_Default_Iterator (It.Nam)
then
Remove_Interp (I);
A_Id = Aspect_Default_Iterator or else
A_Id = Aspect_Iterator_Element
then
+ -- Make type unfrozen before analysis, to prevent spurious
+ -- errors about late attributes.
+
+ Set_Is_Frozen (Ent, False);
Analyze (End_Decl_Expr);
Analyze (Aspect_Rep_Item (ASN));
+ Set_Is_Frozen (Ent, True);
-- If the end of declarations comes before any other freeze
-- point, the Freeze_Expr is not analyzed: no check needed.
Set_Has_Private_Declaration (Prev);
Set_Has_Private_Declaration (Id);
+ -- Preserve aspect and iterator flags, that may have been
+ -- set on the partial view.
+
+ Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id));
+ Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id));
+
-- If no error, propagate freeze_node from private to full view.
-- It may have been generated for an early operational item.
with Elists; use Elists;
with Errout; use Errout;
with Exp_Util; use Exp_Util;
+with Expander; use Expander;
with Fname; use Fname;
with Itypes; use Itypes;
with Lib; use Lib;
Check_Implicit_Dereference (N, CT);
end;
end if;
+
+ elsif Try_Container_Indexing (N, P, First (Exprs)) then
+ return;
+
end if;
Get_Next_Interp (I, It);
Iterator : Node_Id;
begin
+ Expander_Mode_Save_And_Set (False);
Check_SPARK_Restriction ("quantified expression is not allowed", N);
Set_Etype (Ent, Standard_Void_Type);
Analyze (Condition (N));
End_Scope;
-
Set_Etype (N, Standard_Boolean);
+ Expander_Mode_Restore;
end Analyze_Quantified_Expression;
-------------------
-- diagnosed in caller.
if No (Func_Name) then
- return False;
+
+ -- The prefix itself may be an indexing of a container
+ -- rewrite as such and re-analyze.
+
+ if Has_Implicit_Dereference (Etype (Prefix)) then
+ Build_Explicit_Dereference
+ (Prefix, First_Discriminant (Etype (Prefix)));
+ return Try_Container_Indexing (N, Prefix, Expr);
+
+ else
+ return False;
+ end if;
end if;
if Is_Var
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
Set_Parent (D_Copy, Parent (DS));
Pre_Analyze_Range (D_Copy);
+ -- Ada2012 : if the domain of iteration is a function call,
+ -- it is the new iterator form.
+
+ -- We have also implemented the shorter form : for X in S
+ -- for Alfa use. In this case the attributes Old and Result
+ -- must be treated as entity names over which iterators are
+ -- legal.
+
if Nkind (D_Copy) = N_Function_Call
or else
+ (ALFA_Mode
+ and then (Nkind (D_Copy) = N_Attribute_Reference
+ and then
+ (Attribute_Name (D_Copy) = Name_Result
+ or else Attribute_Name (D_Copy) = Name_Old)))
+
+ or else
(Is_Entity_Name (D_Copy)
and then not Is_Type (Entity (D_Copy)))
then
Set_Iterator_Specification (N, I_Spec);
Set_Loop_Parameter_Specification (N, Empty);
Analyze_Iterator_Specification (I_Spec);
+
+ -- In a generic context, analyze the original
+ -- domain of iteration, for name capture.
+
+ if not Expander_Active then
+ Analyze (DS);
+ end if;
+
return;
end;
Loc : constant Source_Ptr := Sloc (N);
Def_Id : constant Node_Id := Defining_Identifier (N);
Subt : constant Node_Id := Subtype_Indication (N);
- Container : constant Node_Id := Name (N);
+ Iter_Name : constant Node_Id := Name (N);
Ent : Entity_Id;
Typ : Entity_Id;
Analyze (Subt);
end if;
- -- If it is an expression, the container is pre-analyzed in the caller.
+ -- If it is an expression, the name is pre-analyzed in the caller.
-- If it it of a controlled type we need a block for the finalization
-- actions. As for loop bounds that need finalization, we create a
-- declaration and an assignment to trigger these actions.
- if Present (Etype (Container))
- and then Is_Controlled (Etype (Container))
- and then not Is_Entity_Name (Container)
+ if Present (Etype (Iter_Name))
+ and then Is_Controlled (Etype (Iter_Name))
+ and then not Is_Entity_Name (Iter_Name)
then
declare
- Id : constant Entity_Id := Make_Temporary (Loc, 'R', Container);
+ Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);
Decl : Node_Id;
- Assign : Node_Id;
begin
- Typ := Etype (Container);
+ Typ := Etype (Iter_Name);
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Id,
- Object_Definition => New_Occurrence_Of (Typ, Loc));
-
- Assign :=
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Id, Loc),
- Expression => Relocate_Node (Container));
-
- Insert_Actions (Parent (N), New_List (Decl, Assign));
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Relocate_Node (Iter_Name));
+
+ Insert_Actions
+ (Parent (Parent (N)), New_List (Decl));
+ Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
+ Set_Etype (Id, Typ);
+ Set_Etype (Name (N), Typ);
end;
else
- -- Container is an entity or an array with uncontrolled components
+ -- Container is an entity or an array with uncontrolled components,
+ -- or else it is a container iterator given by a function call,
+ -- typically called Iterate in the case of predefined containers,
+ -- even though Iterate is not a reserved name. What matter is that
+ -- the return type of the function is an iterator type.
+
+ Analyze (Iter_Name);
+ if Nkind (Iter_Name) = N_Function_Call then
+ declare
+ C : constant Node_Id := Name (Iter_Name);
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ if not Is_Overloaded (Iter_Name) then
+ Resolve (Iter_Name, Etype (C));
+
+ else
+ Get_First_Interp (C, I, It);
+ while It.Typ /= Empty loop
+ if Reverse_Present (N) then
+ if Is_Reversible_Iterator (It.Typ) then
+ Resolve (Iter_Name, It.Typ);
+ exit;
+ end if;
+
+ elsif Is_Iterator (It.Typ) then
+ Resolve (Iter_Name, It.Typ);
+ exit;
+ end if;
- Analyze_And_Resolve (Container);
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
+ end;
+
+ else
+
+ -- domain of iteration is not overloaded.
+
+ Resolve (Iter_Name, Etype (Iter_Name));
+ end if;
end if;
- Typ := Etype (Container);
+ Typ := Etype (Iter_Name);
if Is_Array_Type (Typ) then
if Of_Present (N) then
Set_Etype (Def_Id, Etype (First_Index (Typ)));
end if;
+ -- Check for type error in iterator.
+
+ elsif Typ = Any_Type then
+ return;
+
-- Iteration over a container
else
Set_Ekind (Def_Id, E_Loop_Parameter);
if Of_Present (N) then
+ -- If the container has already been rewritten as a
+ -- call to the default iterator, nothing to do. This
+ -- is the case with the expansion of a quantified
+ -- expression.
- -- Find the Element_Type in the package instance that defines the
- -- container type.
+ if Nkind (Name (N)) = N_Function_Call
+ and then not Comes_From_Source (Name (N))
+ then
+ null;
- Ent := First_Entity (Scope (Base_Type (Typ)));
- while Present (Ent) loop
- if Chars (Ent) = Name_Element_Type then
- Set_Etype (Def_Id, Ent);
- exit;
- end if;
+ elsif Expander_Active then
- Next_Entity (Ent);
- end loop;
+ -- Find the Iterator_Element and the default_iterator
+ -- of the container type.
+
+ Set_Etype (Def_Id,
+ Entity (
+ Find_Aspect (Typ, Aspect_Iterator_Element)));
+
+ declare
+ Default_Iter : constant Entity_Id :=
+ Find_Aspect (Typ, Aspect_Default_Iterator);
+ begin
+ Rewrite (Name (N),
+ Make_Function_Call (Loc,
+ Name => Default_Iter,
+ Parameter_Associations =>
+ New_List (Relocate_Node (Iter_Name))));
+ Analyze_And_Resolve (Name (N));
+ end;
+ end if;
else
- -- Find the Cursor type in similar fashion
+ -- result type of Iterate function is the classwide
+ -- type of the interface parent. We need the specific
+ -- Cursor type defined in the package.
- Ent := First_Entity (Scope (Base_Type (Typ)));
+ Ent := First_Entity (Scope (Typ));
while Present (Ent) loop
if Chars (Ent) = Name_Cursor then
- Set_Etype (Def_Id, Ent);
+ Set_Etype (Def_Id, Etype (Ent));
exit;
end if;
if AS_Needed then
if Nkind (N) = N_Accept_Statement then
- -- If expansion is active, The formal is replaced by a local
+ -- If expansion is active, the formal is replaced by a local
-- variable that renames the corresponding entry of the
-- parameter block, and it is this local variable that may
- -- require an actual subtype.
+ -- require an actual subtype. In ALFA mode, expansion of accept
+ -- statements is skipped.
- if Expander_Active then
+ if Expander_Active and not ALFA_Mode then
Decl := Build_Actual_Subtype (T, Renamed_Object (Formal));
else
Decl := Build_Actual_Subtype (T, Formal);
if Nkind (N) = N_Accept_Statement
and then Expander_Active
+ and then not ALFA_Mode
then
Set_Actual_Subtype (Renamed_Object (Formal),
Defining_Identifier (Decl));
function Unique_Defining_Entity (N : Node_Id) return Entity_Id is
begin
- case Nkind (N) is
- when N_Package_Body =>
- return Corresponding_Spec (N);
+ return Unique_Entity (Defining_Entity (N));
+ end Unique_Defining_Entity;
+
+ -------------------
+ -- Unique_Entity --
+ -------------------
+
+ function Unique_Entity (E : Entity_Id) return Entity_Id is
+ U : Entity_Id := E;
+ P : Node_Id;
+
+ begin
+ case Ekind (E) is
+ when Type_Kind =>
+ if Present (Full_View (E)) then
+ U := Full_View (E);
+ end if;
+
+ when E_Package_Body =>
+ P := Parent (E);
+
+ if Nkind (P) = N_Defining_Program_Unit_Name then
+ P := Parent (P);
+ end if;
+
+ U := Corresponding_Spec (P);
+
+ when E_Subprogram_Body =>
+ P := Parent (E);
- when N_Subprogram_Body =>
- if Acts_As_Spec (N) then
- return Defining_Entity (N);
+ if Nkind (P) = N_Defining_Program_Unit_Name then
+ P := Parent (P);
+ end if;
+
+ P := Parent (P);
+
+ if Nkind (P) = N_Subprogram_Body_Stub then
+ if Present (Library_Unit (P)) then
+ U := Get_Body_From_Stub (P);
+ end if;
else
- return Corresponding_Spec (N);
+ U := Corresponding_Spec (P);
end if;
when others =>
- return Defining_Entity (N);
+ null;
end case;
- end Unique_Defining_Entity;
+
+ return U;
+ end Unique_Entity;
-----------------
-- Unique_Name --
-- specified we check only for the given stream operation.
function Unique_Defining_Entity (N : Node_Id) return Entity_Id;
- -- Return the entity which represents declaration N, so that matching
- -- declaration and body have the same entity.
+ -- Return the entity which represents declaration N, so that different
+ -- views of the same entity have the same unique defining entity:
+ -- * package spec and body;
+ -- * subprogram declaration, subprogram stub and subprogram body;
+ -- * private view and full view of a type.
+ -- In other cases, return the defining entity for N.
+
+ function Unique_Entity (E : Entity_Id) return Entity_Id;
+ -- Return the unique entity for entity E, which would be returned by
+ -- Unique_Defining_Entity if applied to the enclosing declaration of E.
function Unique_Name (E : Entity_Id) return String;
-- Return a unique name for entity E, which could be used to identify E
Write_Str (" some ");
end if;
- Sprint_Node (Loop_Parameter_Specification (Node));
+ if Present (Iterator_Specification (Node)) then
+ Sprint_Node (Iterator_Specification (Node));
+ else
+ Sprint_Node (Loop_Parameter_Specification (Node));
+ end if;
+
Write_Str (" => ");
Sprint_Node (Condition (Node));
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
-- pn --
--------
- procedure pn (N : Node_Id) is
+ procedure pn (N : Union_Id) is
begin
- Print_Tree_Node (N);
+ case N is
+ when List_Low_Bound .. List_High_Bound - 1 =>
+ pl (Int (N));
+ when Node_Range =>
+ Print_Tree_Node (Node_Id (N));
+ when Elist_Range =>
+ Print_Tree_Elist (Elist_Id (N));
+ when Elmt_Range =>
+ raise Program_Error;
+ when Names_Range =>
+ Namet.wn (Name_Id (N));
+ when Strings_Range =>
+ Write_String_Table_Entry (String_Id (N));
+ when Uint_Range =>
+ Uintp.pid (From_Union (N));
+ when Ureal_Range =>
+ Urealp.pr (From_Union (N));
+ when others =>
+ Write_Str ("Invalid Union_Id: ");
+ Write_Int (Int (N));
+ end case;
end pn;
+ --------
+ -- pp --
+ --------
+
+ procedure pp (N : Union_Id) is
+ begin
+ pn (N);
+ end pp;
+
----------------
-- Print_Char --
----------------
Print_Node_Subtree (N);
end pt;
+ ---------
+ -- ppp --
+ ---------
+
+ procedure ppp (N : Node_Id) is
+ begin
+ pt (N);
+ end ppp;
+
-------------------
-- Serial_Number --
-------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
-- Prints the subtree consisting of the given element list and all its
-- referenced descendants.
+ -- The following debugging procedures are intended to be called from gdb
+
+ procedure pp (N : Union_Id);
+ pragma Export (Ada, pp);
+ -- Prints a node, node list, uint, or anything else that falls under
+ -- Union_Id.
+
+ procedure ppp (N : Node_Id);
+ pragma Export (Ada, ppp);
+ -- Same as Print_Node_Subtree
+
+ -- The following are no longer needed; you can use pp or ppp instead
+
procedure pe (E : Elist_Id);
pragma Export (Ada, pe);
- -- Debugging procedure (to be called within gdb), same as Print_Tree_Elist
+ -- Same as Print_Tree_Elist
procedure pl (L : Int);
pragma Export (Ada, pl);
- -- Debugging procedure (to be called within gdb), same as Print_Tree_List,
- -- except that you can use e.g. 66 instead of -99999966. In other words
- -- for the positive case we fill out to 8 digits on the left and add a
- -- minus sign. This just saves some typing in the debugger.
+ -- Same as Print_Tree_List, except that you can use e.g. 66 instead of
+ -- -99999966. In other words for the positive case we fill out to 8 digits
+ -- on the left and add a minus sign. This just saves some typing in the
+ -- debugger.
- procedure pn (N : Node_Id);
+ procedure pn (N : Union_Id);
pragma Export (Ada, pn);
- -- Debugging procedure (to be called within gdb)
- -- same as Print_Tree_Node with Label = ""
+ -- Same as pp
procedure pt (N : Node_Id);
pragma Export (Ada, pt);
- -- Debugging procedure (to be called within gdb)
- -- same as Print_Node_Subtree
+ -- Same as ppp
end Treepr;
OSDN Git Service
