From d32deedb4e7f2a6a23a887dba3197ae1ee058374 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Micha=C3=ABl=20Van=20Canneyt?= <michael@freepascal.org>
Date: Tue, 14 Nov 2023 17:36:33 +0100
Subject: [PATCH] * Add system.diagnostics for Delphi compatibility

---
 packages/vcl-compat/fpmake.pp                 |   1 +
 packages/vcl-compat/src/system.diagnostics.pp | 240 ++++++++++++++++++
 2 files changed, 241 insertions(+)
 create mode 100644 packages/vcl-compat/src/system.diagnostics.pp

diff --git a/packages/vcl-compat/fpmake.pp b/packages/vcl-compat/fpmake.pp
index af7a26541d..049f301234 100644
--- a/packages/vcl-compat/fpmake.pp
+++ b/packages/vcl-compat/fpmake.pp
@@ -47,6 +47,7 @@ begin
     T:=P.Targets.AddUnit('system.analytics.pp');
     T:=P.Targets.AddUnit('system.ansistrings.pp');
     T:=P.Targets.AddUnit('system.imagelist.pp');
+    T:=P.Targets.AddUnit('system.diagnostics.pp');
 
 
 {$ifndef ALLPACKAGES}
diff --git a/packages/vcl-compat/src/system.diagnostics.pp b/packages/vcl-compat/src/system.diagnostics.pp
new file mode 100644
index 0000000000..b02d24a139
--- /dev/null
+++ b/packages/vcl-compat/src/system.diagnostics.pp
@@ -0,0 +1,240 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2023 the Free Pascal development team.
+
+    Delphi compatibility unit to provide a stopwatch.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+// Todo: better resolution for non-windows, non-linux:
+// macos should have mach_absolute_time somewhere.
+// FreeBSD should have clock_gettime routines, but they seem not to be exposed in FPC units?
+unit system.diagnostics;
+
+{$mode objfpc}
+{$modeswitch advancedrecords}
+
+interface
+
+uses System.TimeSpan;
+
+const
+  StopWatchResolution = 10*1000*1000; // 0.1 microsecond
+  TicksPerMillisecond = 10*1000;
+  TicksPerSecond      = StopWatchResolution;
+
+type
+
+  { TStopwatch }
+
+  TStopwatch = record
+  private
+    class var _Frequency: Int64;
+    class var _IsHighResolution: Boolean;
+    class var _TickFrequency: Double;
+    Class procedure _Init; static;
+  private
+    FElapsed: Int64;
+    FRunning: Boolean;
+    FStartTimeStamp: Int64;
+    function GetElapsedTimespanTicks: Int64; inline;
+    function GetElapsed: TTimeSpan;
+    function GetElapsedMilliseconds: Int64;
+    function GetElapsedTicks: Int64;
+  public
+    class function Create: TStopwatch; static;
+    class function GetTimeStamp: Int64; static;
+    class function StartNew: TStopwatch; static;
+    class property Frequency: Int64 read _Frequency;
+    class property IsHighResolution: Boolean read _IsHighResolution;
+  public  
+    procedure Reset;
+    procedure Start;
+    procedure Stop;
+    property Elapsed: TTimeSpan read GetElapsed;
+    property ElapsedMilliseconds: Int64 read GetElapsedMilliseconds;
+    property ElapsedTicks: Int64 read GetElapsedTicks;
+    property IsRunning: Boolean read FRunning;
+  end;
+
+implementation
+
+uses
+{$IFDEF FPC_DOTTEDUNITS}
+  {$IFDEF WINDOWS}
+  Winapi.Windows,
+  {$ELSE}
+  {$IFDEF LINUX}
+  UnixApi.Types,
+  LinuxApi,
+  {$ENDIF LINUX}
+  {$ENDIF WINDOWS}
+  System.SysUtils;
+
+{$ELSE FPC_DOTTEDUNITS}
+
+  {$IFDEF WINDOWS}
+  Windows,
+  {$ELSE}
+  {$IFDEF LINUX}
+  UnixType,
+  Linux,
+  {$ENDIF LINUX}
+  {$ENDIF WINDOWS}
+  SysUtils;
+
+{$ENDIF FPC_DOTTEDUNITS}
+
+{ TStopwatch }
+
+function TStopwatch.GetElapsedTimespanTicks: Int64;
+
+begin
+  Result:=ElapsedTicks;
+  if _IsHighResolution then
+    Result:=Trunc(Result*_TickFrequency);
+end;
+
+
+function TStopwatch.GetElapsed: TTimeSpan;
+
+begin
+  Result:=TTimeSpan.Create(GetElapsedTimeSpanTicks);
+end;
+
+
+function TStopwatch.GetElapsedMilliseconds: Int64;
+
+begin
+  Result:=GetElapsedTimeSpanTicks div TicksPerMillisecond;
+end;
+
+
+function TStopwatch.GetElapsedTicks: Int64;
+
+begin
+  Result:=FElapsed;
+  if Not FRunning then
+    exit;
+  Result:=Result+GetTimeStamp-FStartTimeStamp;
+end;
+
+
+class function TStopwatch.Create: TStopwatch;
+
+begin
+  Result.Reset;
+end;
+
+
+class function TStopwatch.StartNew: TStopwatch;
+
+begin
+  Result.Reset;
+  Result.Start;
+end;
+
+
+procedure TStopwatch.Reset;
+
+begin
+  FElapsed:=0;
+  FRunning:=False;
+  FStartTimeStamp:=0;
+end;
+
+
+procedure TStopwatch.Start;
+
+begin
+  if FRunning then
+    exit;
+  FRunning:=True;
+  FStartTimeStamp:=GetTimeStamp;
+end;
+
+
+procedure TStopwatch.Stop;
+
+begin
+  if Not FRunning then
+    exit;
+  FRunning:=False;
+  Inc(FElapsed,(GetTimeStamp-FStartTimeStamp));
+end;
+
+
+{$IFDEF LINUX}
+class function TStopwatch.GetTimeStamp: Int64;
+
+var
+  res: timespec;
+
+begin
+  clock_gettime(CLOCK_MONOTONIC, @res);
+  Result:=((StopWatchResolution*res.tv_sec)+res.tv_nsec) div 100;
+end;
+
+
+class procedure TStopwatch._Init;
+
+begin
+  _IsHighResolution:=True;
+  _Frequency:=StopWatchResolution;
+  _TickFrequency:=1;
+end;
+
+{$ELSE UNIX}
+
+{$IFDEF WINDOWS}
+class function TStopwatch.GetTimeStamp: Int64;
+
+begin
+  if _IsHighResolution then
+    QueryPerformanceCounter(Result)
+  else
+    Result:=GetTickCount64*TicksPerMillisecond;
+end;
+
+
+class procedure TStopWatch._Init;
+
+begin
+  _IsHighResolution:=QueryPerformanceFrequency(_Frequency);
+  if _IsHighResolution then
+    TStopWatch._TickFrequency:=StopWatchResolution/_Frequency
+  else
+    begin
+    _TickFrequency:=1;
+    _Frequency:=TicksPerSecond;
+    end;
+end;
+
+{$ELSE WINDOWS}
+
+class procedure TStopWatch._Init;
+
+begin
+  _IsHighResolution:=False;
+  _TickFrequency:=1;
+  _Frequency:=TicksPerSecond;
+end;
+
+
+class function TStopwatch.GetTimeStamp: Int64;
+begin
+  Result:=GetTickCount*TicksPerMillisecond;
+end;
+
+{$ENDIF WINDOWS}
+{$ENDIF UNIX}
+
+initialization
+  TStopWatch._Init;
+end.