if Nkind (N) /= N_Attribute_Reference
and then (not Is_Entity_Name (N)
- or else Treat_As_Volatile (Entity (N)))
+ or else Treat_As_Volatile (Entity (N)))
then
Force_Evaluation (N, Mode => Strict);
end if;
-- d_f
-- d_g
-- d_h
- -- d_i
+ -- d_i Ignore activations and calls to instances for elaboration
-- d_j
-- d_k
-- d_l
-- error messages are target dependent and irrelevant.
-- dL The compiler ignores calls in instances and invoke subprograms
- -- which are external to the instance for the static elaboration
- -- model. This switch is orthogonal to d.G.
+ -- which are external to the instance for both the static and dynamic
+ -- elaboration models.
-- dM Assume all variables have been modified, and ignore current value
-- indications. This debug flag disconnects the tracking of constant
-- d.G Previously the compiler ignored calls via generic formal parameters
-- when doing the analysis for the static elaboration model. This is
-- now fixed, but we provide this debug flag to revert to the previous
- -- situation of ignoring such calls to aid in transition. This switch
- -- is orthogonal to dL.
+ -- situation of ignoring such calls to aid in transition.
-- d.H Sets ASIS_GNSA_Mode to True. This signals the front end to suppress
-- the call to gigi in ASIS_Mode.
-- control, conditional entry calls, timed entry calls, and requeue
-- statements in both the static and dynamic elaboration models.
+ -- d_i The compiler ignores calls and task activations when they target a
+ -- subprogram or task type defined in an external instance for both
+ -- the static and dynamic elaboration models.
+
-- d_p The compiler ignores calls to subprograms which verify the run-time
-- semantics of invariants and postconditions in both the static and
-- dynamic elaboration models.
variables in declare blocks) does not exceed the available stack space.
If the space is exceeded, then a ``Storage_Error`` exception is raised.
-For declared tasks, the stack size is controlled by the size
-given in an applicable ``Storage_Size`` pragma or by the value specified
-at bind time with ``-d`` (:ref:`Switches_for_gnatbind`) or is set to
-the default size as defined in the GNAT runtime otherwise.
-
-.. index:: GNAT_STACK_LIMIT
-
-For the environment task, the stack size depends on
-system defaults and is unknown to the compiler. Stack checking
-may still work correctly if a fixed
-size stack is allocated, but this cannot be guaranteed.
-To ensure that a clean exception is signalled for stack
-overflow, set the environment variable
-:envvar:`GNAT_STACK_LIMIT` to indicate the maximum
-stack area that can be used, as in:
-
- ::
-
- $ SET GNAT_STACK_LIMIT 1600
-
-The limit is given in kilobytes, so the above declaration would
-set the stack limit of the environment task to 1.6 megabytes.
-Note that the only purpose of this usage is to limit the amount
-of stack used by the environment task. If it is necessary to
-increase the amount of stack for the environment task, then this
-is an operating systems issue, and must be addressed with the
-appropriate operating systems commands.
+For declared tasks, the default stack size is defined by the GNAT runtime,
+whose size may be modified at bind time through the ``-d`` bind switch
+(:ref:`Switches_for_gnatbind`). Task specific stack sizes may be set using the
+``Storage_Size`` pragma.
+
+For the environment task, the stack size is determined by the operating system.
+Consequently, to modify the size of the environment task please refer to your
+operating system documentation.
.. _Static_Stack_Usage_Analysis:
Else_Statements => New_List (
Make_Raise_Program_Error (Loc,
- Reason => PE_All_Guards_Closed)));
+ Reason => PE_All_Guards_Closed)));
-- If a separate initialization assignment was created
-- earlier, append that following the assignment of the
----------------------------
procedure Expand_Cleanup_Actions (N : Node_Id) is
- pragma Assert
- (Nkind_In (N,
- N_Extended_Return_Statement,
- N_Block_Statement,
- N_Subprogram_Body,
- N_Task_Body,
- N_Entry_Body));
+ pragma Assert (Nkind_In (N, N_Block_Statement,
+ N_Entry_Body,
+ N_Extended_Return_Statement,
+ N_Subprogram_Body,
+ N_Task_Body));
Scop : constant Entity_Id := Current_Scope;
end if;
-- If an extended return statement contains something like
+ --
-- X := F (...);
+ --
-- where F is a build-in-place function call returning a controlled
- -- type, then a temporary object will be implicitly declared as part of
- -- the statement list, and this will need cleanup. In such cases, we
- -- transform:
+ -- type, then a temporary object will be implicitly declared as part
+ -- of the statement list, and this will need cleanup. In such cases,
+ -- we transform:
--
-- return Result : T := ... do
-- <statements> -- possibly with handlers
if Nkind (N) = N_Extended_Return_Statement then
declare
Block : constant Node_Id :=
- Make_Block_Statement (Sloc (N),
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Handled_Statement_Sequence (N));
+ Make_Block_Statement (Sloc (N),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Handled_Statement_Sequence (N));
begin
- Set_Handled_Statement_Sequence
- (N, Make_Handled_Sequence_Of_Statements (Sloc (N),
- Statements => New_List (Block)));
+ Set_Handled_Statement_Sequence (N,
+ Make_Handled_Sequence_Of_Statements (Sloc (N),
+ Statements => New_List (Block)));
+
Analyze (Block);
end;
return;
end if;
+ -- If the main unit is a package body then we need to examine the spec
+ -- to determine whether the main unit is generic (the scope stack is not
+ -- present when this is called on the main unit).
+
+ if Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body
+ and then Is_Generic_Unit (Spec_Entity (Cunit_Entity (Main_Unit)))
+ then
+ return;
+ end if;
+
-- At least for now, do not unnest anything but main source unit
if not In_Extended_Main_Source_Unit (Subp_Body) then
Ent := Entity (Name (N));
-- We are only interested in calls to subprograms nested
- -- within Subp. Calls to Subp itself or to subprograms that
- -- are outside the nested structure do not affect us.
+ -- within Subp. Calls to Subp itself or to subprograms
+ -- that are outside the nested structure do not affect us.
if Scope_Within (Ent, Subp) then
if Present (STT.ARECnF)
and then Nkind (CTJ.N) /= N_Attribute_Reference
then
-
-- CTJ.N is a call to a subprogram which may require a pointer
-- to an activation record. The subprogram containing the call
-- is CTJ.From and the subprogram being called is CTJ.To, so we
and then not Is_Empty_List (Then_Statements (N))
and then not Are_Wrapped (Then_Statements (N))
and then Requires_Cleanup_Actions
- (Then_Statements (N),
- Lib_Level => False,
+ (L => Then_Statements (N),
+ Lib_Level => False,
Nested_Constructs => False)
then
Block := Wrap_Statements_In_Block (Then_Statements (N));
and then not Is_Empty_List (Else_Statements (N))
and then not Are_Wrapped (Else_Statements (N))
and then Requires_Cleanup_Actions
- (Else_Statements (N),
- Lib_Level => False,
+ (L => Else_Statements (N),
+ Lib_Level => False,
Nested_Constructs => False)
then
Block := Wrap_Statements_In_Block (Else_Statements (N));
if not Is_Empty_List (Statements (N))
and then not Are_Wrapped (Statements (N))
and then Requires_Cleanup_Actions
- (Statements (N),
- Lib_Level => False,
+ (L => Statements (N),
+ Lib_Level => False,
Nested_Constructs => False)
then
if Nkind (N) = N_Loop_Statement
| N_Task_Body
=>
return
- Requires_Cleanup_Actions
- (Declarations (N), At_Lib_Level, Nested_Constructs => True)
- or else
- (Present (Handled_Statement_Sequence (N))
- and then
- Requires_Cleanup_Actions
- (Statements (Handled_Statement_Sequence (N)),
- At_Lib_Level, Nested_Constructs => True));
+ Requires_Cleanup_Actions
+ (L => Declarations (N),
+ Lib_Level => At_Lib_Level,
+ Nested_Constructs => True)
+ or else
+ (Present (Handled_Statement_Sequence (N))
+ and then
+ Requires_Cleanup_Actions
+ (L =>
+ Statements (Handled_Statement_Sequence (N)),
+ Lib_Level => At_Lib_Level,
+ Nested_Constructs => True));
-- Extended return statements are the same as the above, except that
-- there is no Declarations field. We do not want to clean up the
when N_Extended_Return_Statement =>
return
- Present (Handled_Statement_Sequence (N))
- and then Requires_Cleanup_Actions
- (Statements (Handled_Statement_Sequence (N)),
- At_Lib_Level, Nested_Constructs => True);
+ Present (Handled_Statement_Sequence (N))
+ and then Requires_Cleanup_Actions
+ (L =>
+ Statements (Handled_Statement_Sequence (N)),
+ Lib_Level => At_Lib_Level,
+ Nested_Constructs => True);
when N_Package_Specification =>
return
- Requires_Cleanup_Actions
- (Visible_Declarations (N), At_Lib_Level,
- Nested_Constructs => True)
- or else
- Requires_Cleanup_Actions
- (Private_Declarations (N), At_Lib_Level,
- Nested_Constructs => True);
+ Requires_Cleanup_Actions
+ (L => Visible_Declarations (N),
+ Lib_Level => At_Lib_Level,
+ Nested_Constructs => True)
+ or else
+ Requires_Cleanup_Actions
+ (L => Private_Declarations (N),
+ Lib_Level => At_Lib_Level,
+ Nested_Constructs => True);
when others =>
raise Program_Error;
@copying
@quotation
-GNAT User's Guide for Native Platforms , Dec 05, 2017
+GNAT User's Guide for Native Platforms , Dec 15, 2017
AdaCore
variables in declare blocks) does not exceed the available stack space.
If the space is exceeded, then a @code{Storage_Error} exception is raised.
-For declared tasks, the stack size is controlled by the size
-given in an applicable @code{Storage_Size} pragma or by the value specified
-at bind time with @code{-d} (@ref{11f,,Switches for gnatbind}) or is set to
-the default size as defined in the GNAT runtime otherwise.
+For declared tasks, the default stack size is defined by the GNAT runtime,
+whose size may be modified at bind time through the @code{-d} bind switch
+(@ref{11f,,Switches for gnatbind}). Task specific stack sizes may be set using the
+@code{Storage_Size} pragma.
-@geindex GNAT_STACK_LIMIT
-
-For the environment task, the stack size depends on
-system defaults and is unknown to the compiler. Stack checking
-may still work correctly if a fixed
-size stack is allocated, but this cannot be guaranteed.
-To ensure that a clean exception is signalled for stack
-overflow, set the environment variable
-@geindex GNAT_STACK_LIMIT
-@geindex environment variable; GNAT_STACK_LIMIT
-@code{GNAT_STACK_LIMIT} to indicate the maximum
-stack area that can be used, as in:
-
-@quotation
-
-@example
-$ SET GNAT_STACK_LIMIT 1600
-@end example
-@end quotation
-
-The limit is given in kilobytes, so the above declaration would
-set the stack limit of the environment task to 1.6 megabytes.
-Note that the only purpose of this usage is to limit the amount
-of stack used by the environment task. If it is necessary to
-increase the amount of stack for the environment task, then this
-is an operating systems issue, and must be addressed with the
-appropriate operating systems commands.
+For the environment task, the stack size is determined by the operating system.
+Consequently, to modify the size of the environment task please refer to your
+operating system documentation.
@node Static Stack Usage Analysis,Dynamic Stack Usage Analysis,Stack Overflow Checking,Stack Related Facilities
@anchor{gnat_ugn/gnat_and_program_execution id64}@anchor{1cb}@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{f5}
-- Inline_Package means that the call is considered for inlining and
-- its package compiled and scanned for more inlining opportunities.
+ function Is_Non_Loading_Expression_Function
+ (Id : Entity_Id) return Boolean;
+ -- Determine whether arbitrary entity Id denotes a subprogram which is
+ -- either
+ --
+ -- * An expression function
+ --
+ -- * A function completed by an expression function where both the
+ -- spec and body are in the same context.
+
function Must_Inline return Inline_Level_Type;
-- Inlining is only done if the call statement N is in the main unit,
-- or within the body of another inlined subprogram.
+ ----------------------------------------
+ -- Is_Non_Loading_Expression_Function --
+ ----------------------------------------
+
+ function Is_Non_Loading_Expression_Function
+ (Id : Entity_Id) return Boolean
+ is
+ Body_Decl : Node_Id;
+ Body_Id : Entity_Id;
+ Spec_Decl : Node_Id;
+
+ begin
+ -- A stand-alone expression function is transformed into a spec-body
+ -- pair in-place. Since both the spec and body are in the same list,
+ -- the inlining of such an expression function does not need to load
+ -- anything extra.
+
+ if Is_Expression_Function (Id) then
+ return True;
+
+ -- A function may be completed by an expression function
+
+ elsif Ekind (Id) = E_Function then
+ Spec_Decl := Unit_Declaration_Node (Id);
+
+ if Nkind (Spec_Decl) = N_Subprogram_Declaration then
+ Body_Id := Corresponding_Body (Spec_Decl);
+
+ if Present (Body_Id) then
+ Body_Decl := Unit_Declaration_Node (Body_Id);
+
+ -- The inlining of a completing expression function does
+ -- not need to load anything extra when both the spec and
+ -- body are in the same context.
+
+ return
+ Was_Expression_Function (Body_Decl)
+ and then Parent (Spec_Decl) = Parent (Body_Decl);
+ end if;
+ end if;
+ end if;
+
+ return False;
+ end Is_Non_Loading_Expression_Function;
+
-----------------
-- Must_Inline --
-----------------
Set_Needs_Debug_Info (E, False);
end if;
- -- If the subprogram is an expression function, then there is no need to
- -- load any package body since the body of the function is in the spec.
+ -- If the subprogram is an expression function, or is completed by one
+ -- where both the spec and body are in the same context, then there is
+ -- no need to load any package body since the body of the function is
+ -- in the spec.
- if Is_Expression_Function (E) then
+ if Is_Non_Loading_Expression_Function (E) then
Set_Is_Called (E);
return;
end if;
-- Get --
---------
- function Get (Addr : System.Address;
- Load_Addr : access System.Address)
- return String
+ function Get
+ (Addr : System.Address;
+ Load_Addr : access System.Address) return String
is
pragma Unreferenced (Addr);
pragma Unreferenced (Load_Addr);
RE_Null,
- RO_CA_Time, -- Ada.Calendar
RO_CA_Clock_Time, -- Ada.Calendar
+ RO_CA_Time, -- Ada.Calendar
RO_CA_Delay_For, -- Ada.Calendar.Delays
RO_CA_Delay_Until, -- Ada.Calendar.Delays
RE_Null => RTU_Null,
- RO_CA_Time => Ada_Calendar,
RO_CA_Clock_Time => Ada_Calendar,
+ RO_CA_Time => Ada_Calendar,
RO_CA_Delay_For => Ada_Calendar_Delays,
RO_CA_Delay_Until => Ada_Calendar_Delays,
---------------------
procedure Possible_Freeze (T : Entity_Id) is
+ Scop : constant Entity_Id := Scope (Designator);
begin
- if Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
+ -- If the subprogram appears within a package instance (which
+ -- may be the wrapper package of a subprogram instance) the
+ -- freeze node for that package will freeze the subprogram at
+ -- the proper place, so do not emit a freeze node for the
+ -- subprogram, given that it may appear in the wrong scope.
+
+ if Ekind (Scop) = E_Package
+ and then not Comes_From_Source (Scop)
+ and then Is_Generic_Instance (Scop)
+ then
+ null;
+
+ elsif Has_Delayed_Freeze (T) and then not Is_Frozen (T) then
Set_Has_Delayed_Freeze (Designator);
elsif Is_Access_Type (T)
-- actual subprograms through generic formal subprograms. As a
-- result, the calls are not recorded or processed.
--
- -- -gnatdL ignore activations and calls to instances for elaboration
+ -- -gnatd_i ignore activations and calls to instances for elaboration
--
-- The ABE mechanism ignores calls and task activations when they
-- target a subprogram or task type defined an external instance.
-- As a result, the calls and task activations are not processed.
--
+ -- -gnatdL ignore external calls from instances for elaboration
+ --
+ -- The ABE mechanism does not generate N_Call_Marker nodes for
+ -- calls which occur in expanded instances, do not invoke generic
+ -- actual subprograms through formal subprograms, and the target
+ -- is external to the instance. As a result, the calls are not
+ -- recorded or processed.
+ --
-- -gnatd.o conservative elaboration order for indirect calls
--
-- The ABE mechanism treats '[Unrestricted_]Access of an entry,
-- -gnatd_a
-- -gnatd_e
-- -gnatd.G
+ -- -gnatd_i
-- -gnatdL
-- -gnatd_p
-- -gnatd.U
-----------------------
procedure Build_Call_Marker (N : Node_Id) is
+ function In_External_Context
+ (Call : Node_Id;
+ Target_Attrs : Target_Attributes) return Boolean;
+ pragma Inline (In_External_Context);
+ -- Determine whether a target described by attributes Target_Attrs is
+ -- external to call Call which must reside within an instance.
+
function In_Premature_Context (Call : Node_Id) return Boolean;
-- Determine whether call Call appears within a premature context
-- Determine whether subprogram Subp_Id denotes a generic formal
-- subprogram which appears in the "prologue" of an instantiation.
+ -------------------------
+ -- In_External_Context --
+ -------------------------
+
+ function In_External_Context
+ (Call : Node_Id;
+ Target_Attrs : Target_Attributes) return Boolean
+ is
+ Inst : Node_Id;
+ Inst_Body : Node_Id;
+ Inst_Decl : Node_Id;
+
+ begin
+ -- Performance note: parent traversal
+
+ Inst := Find_Enclosing_Instance (Call);
+
+ -- The call appears within an instance
+
+ if Present (Inst) then
+
+ -- The call comes from the main unit and the target does not
+
+ if In_Extended_Main_Code_Unit (Call)
+ and then not In_Extended_Main_Code_Unit (Target_Attrs.Spec_Decl)
+ then
+ return True;
+
+ -- Otherwise the target declaration must not appear within the
+ -- instance spec or body.
+
+ else
+ Extract_Instance_Attributes
+ (Exp_Inst => Inst,
+ Inst_Decl => Inst_Decl,
+ Inst_Body => Inst_Body);
+
+ -- Performance note: parent traversal
+
+ return not In_Subtree
+ (N => Target_Attrs.Spec_Decl,
+ Root1 => Inst_Decl,
+ Root2 => Inst_Body);
+ end if;
+ end if;
+
+ return False;
+ end In_External_Context;
+
--------------------------
-- In_Premature_Context --
--------------------------
(Target_Id => Target_Id,
Attrs => Target_Attrs);
+ -- Nothing to do when the call appears within the expanded spec or
+ -- body of an instantiated generic, the call does not invoke a generic
+ -- formal subprogram, the target is external to the instance, and switch
+ -- -gnatdL (ignore external calls from instances for elaboration) is in
+ -- effect.
+
+ if Debug_Flag_LL
+ and then not Is_Generic_Formal_Subp (Entity (Call_Nam))
+
+ -- Performance note: parent traversal
+
+ and then In_External_Context
+ (Call => N,
+ Target_Attrs => Target_Attrs)
+ then
+ return;
+
-- Nothing to do when the call invokes an assertion pragma procedure
-- and switch -gnatd_p (ignore assertion pragmas for elaboration) is
-- in effect.
- if Debug_Flag_Underscore_P
+ elsif Debug_Flag_Underscore_P
and then Is_Assertion_Pragma_Target (Target_Id)
then
return;
end if;
-- Nothing to do when the call activates a task whose type is defined
- -- within an instance and switch -gnatdL (ignore activations and calls
+ -- within an instance and switch -gnatd_i (ignore activations and calls
-- to instances for elaboration) is in effect.
- if Debug_Flag_LL
+ if Debug_Flag_Underscore_I
and then In_External_Instance
(N => Call,
Target_Decl => Task_Attrs.Task_Decl)
end if;
-- Nothing to do when the call invokes a target defined within an
- -- instance and switch -gnatdL (ignore activations and calls to
+ -- instance and switch -gnatd_i (ignore activations and calls to
-- instances for elaboration) is in effect.
- if Debug_Flag_LL
+ if Debug_Flag_Underscore_I
and then In_External_Instance
(N => Call,
Target_Decl => Target_Attrs.Spec_Decl)
-- Common relaxations for both ABE mechanisms
--
- -- -gnatd.G (ignore calls through generic formal parameters for
- -- elaboration)
- -- -gnatd.U (ignore indirect calls for static elaboration)
- -- -gnatd.y (disable implicit pragma Elaborate_All on task
- -- bodies)
+ -- -gnatd.G (ignore calls through generic formal parameters
+ -- for elaboration)
+ -- -gnatd.U (ignore indirect calls for static elaboration)
+ -- -gnatd.y (disable implicit pragma Elaborate_All on task
+ -- bodies)
Debug_Flag_Dot_GG := True;
Debug_Flag_Dot_UU := True;
-- Relaxations to the default ABE mechanism
--
- -- -gnatd_a (stop elaboration checks on accept or select
- -- statement)
- -- -gnatd_e (ignore entry calls and requeue statements for
- -- elaboration)
- -- -gnatd_p (ignore assertion pragmas for elaboration)
- -- -gnatdL (ignore activations and calls to instances for
- -- elaboration)
+ -- -gnatd_a (stop elaboration checks on accept or select
+ -- statement)
+ -- -gnatd_e (ignore entry calls and requeue statements for
+ -- elaboration)
+ -- -gnatd_i (ignore activations and calls to instances for
+ -- elaboration)
+ -- -gnatd_p (ignore assertion pragmas for elaboration)
+ -- -gnatdL (ignore external calls from instances for
+ -- elaboration)
else
Debug_Flag_Underscore_A := True;
Debug_Flag_Underscore_E := True;
+ Debug_Flag_Underscore_I := True;
Debug_Flag_Underscore_P := True;
Debug_Flag_LL := True;
end if;
+2017-12-15 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * gnat.dg/expr_func_main.adb, gnat.dg/expr_func_pkg.ads,
+ gnat.dg/expr_func_pkg.adb: New testcase.
+
+2017-12-15 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * gnat.dg/abe_pkg.adb, gnat.dg/abe_pkg.ads: New testcase.
+
+2017-12-15 Ed Schonberg <schonberg@adacore.com>
+
+ * gnat.dg/subp_inst.adb, gnat.dg/subp_inst_pkg.adb,
+ gnat.dg/subp_inst_pkg.ads: New testcase.
+
2017-12-15 Julia Koval <julia.koval@intel.com>
* gcc.target/i386/avx512f-aesenclast-2.c: New test.
--- /dev/null
+-- { dg-do compile }
+-- { dg-options "-gnatJ" }
+package body ABE_Pkg is
+ package body Gen is
+ procedure Force_Body is begin null; end Force_Body;
+ begin
+ ABE;
+ end Gen;
+
+ package Inst is new Gen;
+
+ procedure ABE is begin null; end ABE;
+end ABE_Pkg;
--- /dev/null
+package ABE_Pkg is
+ procedure ABE;
+
+ generic
+ package Gen is
+ procedure Force_Body;
+ end Gen;
+end ABE_Pkg;
--- /dev/null
+-- { dg-do compile }
+
+with Expr_Func_Pkg; use Expr_Func_Pkg;
+
+procedure Expr_Func_Main is
+ Val : Boolean := Expr_Func (456);
+begin
+ null;
+end Expr_Func_Main;
--- /dev/null
+package body Expr_Func_Pkg is
+ function Func (Val : Integer) return Boolean is
+ begin
+ Error; -- { dg-error "\"Error\" is undefined" }
+ return Val = 123;
+ end Func;
+end Expr_Func_Pkg;
--- /dev/null
+package Expr_Func_Pkg is
+ function Func (Val : Integer) return Boolean with Inline;
+
+ function Expr_Func (Val : Integer) return Boolean;
+ function Expr_Func (Val : Integer) return Boolean is (True);
+end Expr_Func_Pkg;
--- /dev/null
+-- { dg-do compile }
+with Subp_Inst_Pkg;
+procedure Subp_Inst is
+ procedure Test_Access_Image is
+ package Nested is
+ type T is private;
+
+ type T_General_Access is access all T;
+ type T_Access is access T;
+ function Image1 is new Subp_Inst_Pkg.Image (T, T_Access);
+ function Image2 is new Subp_Inst_Pkg.Image (T, T_General_Access);
+ function Image3 is new Subp_Inst_Pkg.T_Image (T);
+ private
+ type T is null record;
+ end Nested;
+
+ A : aliased Nested.T;
+ AG : aliased constant Nested.T_General_Access := A'Access;
+ AA : aliased constant Nested.T_Access := new Nested.T;
+ begin
+ null;
+ end Test_Access_Image;
+
+begin
+ Test_Access_Image;
+end Subp_Inst;
--- /dev/null
+with Ada.Unchecked_Conversion;
+with System.Address_Image;
+package body Subp_Inst_Pkg is
+
+ function Image (Val : T_Access) return String is
+ function Convert is new Ada.Unchecked_Conversion
+ (T_Access, System.Address);
+ begin
+ return System.Address_Image (Convert (Val));
+ end Image;
+
+ function T_Image (Val : access T) return String is
+ type T_Access is access all T;
+ function Convert is new Ada.Unchecked_Conversion
+ (T_Access, System.Address);
+ begin
+ return System.Address_Image (Convert (Val));
+ end T_Image;
+
+end Subp_Inst_Pkg;
--- /dev/null
+package Subp_Inst_Pkg is
+ pragma Pure;
+
+ generic
+ type T;
+ type T_Access is access T;
+ function Image (Val : T_Access) return String;
+
+ generic
+ type T;
+ function T_Image (Val : access T) return String;
+
+end Subp_Inst_Pkg;
projects / gcc.git / commitdiff