Ada2012中Ada.Finalization.Limited_Controlled运行时错误排查

云上老周

2026-7-17

问题描述

运行时触发如下错误：

raised PROGRAM_ERROR : s-finroo.adb:42 explicit raise

在实现Observer设计模式时，观察者为limited类型，为避免使用通用访问类型，通过存储观察者地址，借助Ada.Address_To_Access_Conversions实现通知逻辑。具体观察者继承自Ada.Finalization.Limited_Controlled，因为业务需求需要初始化和终结操作。以下是最小复现代码：

代码文件

eventpublisher.ads

private with System;

package eventPublisher is

  type Observer_t is limited interface;
  procedure Event (this : in out Observer_t) is abstract;

  type EventPublisher_t is tagged limited private;
  procedure pSubscribeEvent (this : in out EventPublisher_t;
                             TrainId : Natural;
                             sub : Observer_t'Class);

  procedure pUnsubscribeEvent (this : in out EventPublisher_t;
                               TrainId : Natural;
                               sub : Observer_t'Class);

  procedure pNotifyEvent (this : in out EventPublisher_t);

  function fGetEventPublisher return not null access EventPublisher_t;

private

  type EventObserver_t is tagged
     record
       obs : System.Address := System.Null_Address;
     end record;

  type EventPublisher_t is tagged limited
     record
       eventManager : EventObserver_t;
     end record;

end eventPublisher;

eventpublisher.adb

with System.Address_To_Access_Conversions;
with Ada.Text_IO;

package body eventPublisher is

  function "=" (Left, Righ : System.Address) return Boolean renames System."=";

  eventPublisher : access EventPublisher_t := new EventPublisher_t;

  package Event_OPS is new System.Address_To_Access_Conversions (Observer_t'Class);

  function fGetEventPublisher return not null access EventPublisher_t is
  begin
    return eventPublisher;
  end fGetEventPublisher;

  -------------------
  -- pSubscribeEvent --
  -------------------

  procedure pSubscribeEvent
    (this : in out EventPublisher_t; TrainId : Natural;
     sub  :        Observer_t'Class)
  is
  begin
    Ada.Text_IO.Put_Line("Subscribing to Event");
    this.eventManager.obs := sub'Address;
  end pSubscribeEvent;

  procedure pUnsubscribeEvent (this : in out EventPublisher_t;
                               TrainId : Natural;
                               sub : Observer_t'Class) is
  begin
    Ada.Text_IO.Put_Line("Unsubscribing to Event");
    if this.eventManager.obs = sub'Address then
      this.eventManager.obs := System.Null_Address;
    else
      null;
    end if;

  end pUnsubscribeEvent;

  procedure pNotifyEvent (this : in out EventPublisher_t) is
  begin
    if this.eventManager.obs /= System.Null_Address then
      Ada.Text_IO.Put_Line("Notifying to observer");
      Event_OPS.To_Pointer(this.eventManager.obs).Event;
    end if;
  end pNotifyEvent;

components.ads

with eventPublisher;
private with Ada.Finalization;

package components is

  type Root_t (Id : Natural) is abstract tagged limited null record;

  type Child_t (Id : Natural) is limited new Root_t with private;

  procedure pSubscribe (this : in out Child_t);
  procedure pUnsubscribe (this : in out Child_t);

private

  type Component_t (Id : Natural) is limited new
    Ada.Finalization.Limited_Controlled and ---> 注释掉这行程序就正常运行
    eventPublisher.Observer_t with null record;

  overriding
  procedure Event (this : in out Component_t);

  type Child_t (Id : Natural) is limited new Root_t (Id => Id) with
     record
       component : Component_t(Id => Id);
     end record;

end components;

components.adb

with Ada.Text_IO;

package body components is
  -----------
  -- Event --
  -----------

  overriding procedure Event (this : in out Component_t) is
  begin
    Ada.Text_IO.Put_Line("Processing Event");
  end Event;
  ----------------
  -- pSubscribe --
  ----------------

  procedure pSubscribe (this : in out Child_t) is
  begin
    eventPublisher.fGetEventPublisher.pSubscribeEvent(TrainId => this.Id,
                                                    sub => this.component);
  end pSubscribe;

  procedure pUnsubscribe (this : in out Child_t) is
  begin
    eventPublisher.fGetEventPublisher.pUnsubscribeEvent(TrainId => this.Id,
                                                      sub => this.component);
  end pUnsubscribe;

end components;

main.adb

with Ada.Text_IO;
with components;
with eventPublisher;

procedure Main is

  c : components.Child_t(Id => 1);
  pub : constant access eventPublisher.EventPublisher_t := eventPublisher.fGetEventPublisher;

begin
  c.pSubscribe;
  pub.pNotifyEvent;
  c.pUnsubscribe;
end Main;

回溯信息

#0  <__gnat_debug_raise_exception> (e=0x45ab60 <program_error>, message=...) at s-excdeb.adb:41
#1  0x0000000000407265 in ada.exceptions.complete_occurrence (x=x@entry=0x467300) at a-except.adb:1019
#2  0x0000000000407275 in ada.exceptions.complete_and_propagate_occurrence (x=x@entry=0x467300) at a-except.adb:1030
#3  0x00000000004076ac in ada.exceptions.raise_with_location_and_msg (e=0x45ab60 <program_error>, f=(system.address) 0x4437d8, l=42, c=c@entry=0, m=m@entry=(system.address) 0x441150) at a-except.adb:1241
#4  0x0000000000407629 in <__gnat_raise_program_error_msg> (file=<optimized out>, line=<optimized out>, msg=msg@entry=0x441150 <ada.exceptions.rmsg_22>) at a-except.adb:1197
#5  0x00000000004078e0 in <__gnat_rcheck_PE_Explicit_Raise> (file=<optimized out>, line=<optimized out>) at a-except.adb:1435
#6  0x0000000000416ba5 in system.finalization_root.adjust ()
#7  0x0000000000404fea in eventpublisher.pnotifyevent ()
#8  0x00000000004041be in main ()

疑问

为什么会触发这个运行时错误？为什么通知过程中会调用Limited_Controlled类型的Adjust？

问题分析与解决

原因

类型转换的隐含风险：你针对Observer_t'Class实例化了System.Address_To_Access_Conversions包Event_OPS，但Observer_t'Class包含了Limited_Controlled的派生类型。当调用Event_OPS.To_Pointer(this.eventManager.obs)时，返回的是Observer_t'Class类型的访问值，而该地址实际指向的是Component_t（继承自Limited_Controlled）。
类范围类型的临时副本创建：在Ada中，通过类范围类型的访问值调用操作时，编译器会尝试创建对象的临时副本（因为类范围是不定类型，需要确定的具体实例才能执行操作）。对于Limited_Controlled类型，创建临时副本会触发Adjust过程，但Ada标准规定，Limited_Controlled的默认Adjust会显式抛出PROGRAM_ERROR，这就是s-finroo.adb:42错误的来源。

简单来说：地址转换得到的类范围访问值，在调用Event时触发了Component_t对象的复制操作，而Limited_Controlled不允许复制，因此抛出错误。

解决方法

方法1：使用接口访问类型替代地址存储

放弃直接存储地址，改用访问到接口的类型，Ada允许对limited接口使用访问类型，且不会触发复制操作。修改eventPublisher包：

修改后的eventpublisher.ads

package eventPublisher is

  type Observer_t is limited interface;
  procedure Event (this : in out Observer_t) is abstract;

  type Observer_Access is access all Observer_t'Class; -- 新增接口访问类型

  type EventPublisher_t is tagged limited private;
  procedure pSubscribeEvent (this : in out EventPublisher_t;
                             TrainId : Natural;
                             sub : not null Observer_Access); -- 参数改为访问类型

  procedure pUnsubscribeEvent (this : in out EventPublisher_t;
                               TrainId : Natural;
                               sub : not null Observer_Access);

  procedure pNotifyEvent (this : in out EventPublisher_t);

  function fGetEventPublisher return not null access EventPublisher_t;

private

  type EventObserver_t is tagged
     record
       obs : Observer_Access := null; -- 存储访问类型而非地址
     end record;

  type EventPublisher_t is tagged limited
     record
       eventManager : EventObserver_t;
     end record;

end eventPublisher;

修改后的eventpublisher.adb

with Ada.Text_IO;

package body eventPublisher is

  eventPublisher : access EventPublisher_t := new EventPublisher_t;

  function fGetEventPublisher return not null access EventPublisher_t is
  begin
    return eventPublisher;
  end fGetEventPublisher;

  -------------------
  -- pSubscribeEvent --
  -------------------

  procedure pSubscribeEvent
    (this : in out EventPublisher_t; TrainId : Natural;
     sub  :        not null Observer_Access)
  is
  begin
    Ada.Text_IO.Put_Line("Subscribing to Event");
    this.eventManager.obs := sub;
  end pSubscribeEvent;

  procedure pUnsubscribeEvent (this : in out EventPublisher_t;
                               TrainId : Natural;
                               sub : not null Observer_Access) is
  begin
    Ada.Text_IO.Put_Line("Unsubscribing to Event");
    if this.eventManager.obs = sub then
      this.eventManager.obs := null;
    else
      null;
    end if;

  end pUnsubscribeEvent;

  procedure pNotifyEvent (this : in out EventPublisher_t) is
  begin
    if this.eventManager.obs /= null then
      Ada.Text_IO.Put_Line("Notifying to observer");
      this.eventManager.obs.Event; -- 直接调用，无复制操作
    end if;
  end pNotifyEvent;
end eventPublisher;

修改components.adb中的订阅/取消订阅逻辑

procedure pSubscribe (this : in out Child_t) is
begin
  eventPublisher.fGetEventPublisher.pSubscribeEvent(TrainId => this.Id,
                                                  sub => this.component'Unchecked_Access);
end pSubscribe;

procedure pUnsubscribe (this : in out Child_t) is
begin
  eventPublisher.fGetEventPublisher.pUnsubscribeEvent(TrainId => this.Id,
                                                    sub => this.component'Unchecked_Access);
end pUnsubscribe;

修改后直接存储观察者的访问类型，调用Event时不会触发对象复制，也就不会调用Adjust，彻底避免错误。

方法2：调整Observer接口的limited属性

如果业务允许，可以将Observer_t改为非limited接口，这样编译器不会限制复制操作，但这可能不符合你的初始设计需求。

内容的提问来源于stack exchange，提问作者Albatros23

Ada2012中Ada.Finalization.Limited_Controlled运行时错误排查

代码文件 #

eventpublisher.ads #

eventpublisher.adb #

components.ads #

components.adb #

main.adb #

回溯信息 #

疑问 #

原因 #

解决方法 #

方法1：使用接口访问类型替代地址存储 #