program CheckpointTest; {$APPTYPE CONSOLE} {$R *.res} uses System.SysUtils; type ICheckpoint = interface ['{4348A5AB-621D-4A18-8368-1388A44481C6}'] end; CheckpointLog = class strict private type PCheckpointData = ^TCheckpointData; TCheckpointData = record Msg: string; Prev: PCheckpointData; end; strict private class var CurCheckpoint: PCheckpointData; public class function AddCheckpoint(const Msg: string): pointer; class procedure RemoveCheckpoint(const Handle: pointer); class procedure PrintLog(); end; CheckpointImpl = class(TInterfacedObject, ICheckpoint) strict private FHandle: pointer; public constructor Create(const Msg: string); destructor Destroy; override; end; function Checkpoint(const Msg: string): ICheckpoint; begin result := CheckpointImpl.Create(Msg); end; { CheckpointLog } class function CheckpointLog.AddCheckpoint(const Msg: string): pointer; var chk: PCheckpointData; begin New(chk); chk.Msg := Msg; chk.Prev := CurCheckpoint; CurCheckpoint := chk; result := chk; end; class procedure CheckpointLog.PrintLog; var chk: PCheckpointData; begin chk := CurCheckpoint; if (chk = nil) then exit; WriteLn('Checkpoints:'); while (chk <> nil) do begin WriteLn(' ', chk.Msg); chk := chk.Prev; end; end; class procedure CheckpointLog.RemoveCheckpoint(const Handle: pointer); var chk: PCheckpointData; begin if (Handle <> CurCheckpoint) then raise EArgumentException.Create('RemoveCheckpoint: Invalid checkpoint handle'); chk := CurCheckpoint; CurCheckpoint := chk.Prev; Dispose(chk); end; { CheckpointImpl } constructor CheckpointImpl.Create(const Msg: string); begin inherited Create; FHandle := CheckpointLog.AddCheckpoint(Msg); end; destructor CheckpointImpl.Destroy; begin CheckpointLog.RemoveCheckpoint(FHandle); inherited; end; procedure ReadSomeFile; begin raise EProgrammerNotFound.Create('Barf'); end; procedure ReadSome; begin Checkpoint('ReadSome'); try ReadSomeFile; except on E: Exception do begin Writeln(E.ClassName, ': ', E.Message); CheckpointLog.PrintLog(); end; end; end; procedure Proc1; begin Checkpoint('Proc1'); end; procedure Proc2; begin Checkpoint('Proc2'); ReadSome; end; procedure Test; begin Checkpoint('Start test'); Proc1; Proc2; end; begin try Test; except on E: Exception do begin Writeln(E.ClassName, ': ', E.Message); CheckpointLog.PrintLog(); end; end; WriteLn('done...'); ReadLn; end.