├── README.md ├── Samples ├── FMX │ ├── Unit1.fmx │ ├── Unit1.pas │ ├── fmxPerformance.dpr │ ├── fmxPerformance.dproj │ └── fmxPerformance.res ├── FPC │ ├── FPCPerformanceTest.ico │ ├── FPCPerformanceTest.lpr │ ├── FPCPerformanceTest.res │ ├── FPCperformanceTest.lpi │ ├── FPCperformanceTest.lps │ ├── unit1.lfm │ └── unit1.pas └── VCL │ ├── Unit1.dfm │ ├── Unit1.pas │ ├── VCLPerformanceTest.dpr │ ├── VCLPerformanceTest.dproj │ └── VCLPerformanceTest.res ├── Source ├── Cadencer.pas ├── CoreAtomic.inc ├── CoreCipher.pas ├── CoreClasses.pas ├── CoreCompress.pas ├── CoreComputeThread.inc ├── CoreEndian.inc ├── CoreThreadPost.inc ├── Core_AtomVar.inc ├── Core_DelphiParallelFor.inc ├── Core_FPCParallelFor.inc ├── Core_LineProcessor.inc ├── Core_MT19937.inc ├── Core_OrderData.inc ├── DataFrameEngine.pas ├── DoStatusIO.pas ├── FPCGenericStructlist.pas ├── Fast_MD5.pas ├── GHashList.pas ├── Geometry2DUnit.pas ├── Geometry3DUnit.pas ├── GeometryLib.pas ├── GeometryRotationUnit.pas ├── GeometrySplit.inc ├── GeometrySplitHeader.inc ├── LinearAction.pas ├── ListEngine.pas ├── MH.pas ├── MH_1.pas ├── MH_2.pas ├── MH_3.pas ├── MH_ZDB.pas ├── MH_delphi.inc ├── MH_fpc.inc ├── MemoryStream64.pas ├── NotifyObjectBase.pas ├── NumberBase.pas ├── OpCode.pas ├── PascalStrings.pas ├── TextDataEngine.pas ├── TextParsing.pas ├── TextTable.pas ├── UPascalStrings.pas ├── UnicodeMixedLib.pas ├── ZIOThread.pas ├── ZJson.pas ├── ZJson_delphi.inc ├── ZJson_fpc.inc ├── ZS_JsonDataObjects.pas ├── clear_with_dcu.bat ├── md5_32.asm ├── md5_32.obj ├── md5_64.asm ├── md5_64.obj ├── zDefine.inc └── zExpression.pas └── clear_with_dcu.bat /README.md: -------------------------------------------------------------------------------- 1 | # CoreCipher 2 | 3 | CoreCipher is a Delphi and FPC library for cryptography. It provides support for RC6,TwoFish,AES, DES, 3DES, Blowfish, MD5,SHA1,MixFunctions,LSC,LQC, all work in parallel and mobile platform! 4 | 5 | **supports parallel encryption/decryption** 6 | 7 | ### multi platform supported:，test with Delphi 10.2 upate 2 and FPC 3.0.4 8 | 9 | - Windows x86+x64 10 | - Android pad with armv8 aarch64 11 | - Android mobile with armv6 or last 12 | - IOS Device armv7(ip4)+armv8(ipad pro,iphone5s or last aarch64) 13 | - IOS Simulaor:n/a 14 | - OSX 15 | - Ubuntu16.04 x64 server 16 | - Ubuntu18.04 x86+x64 Desktop 17 | - Ubuntu18.04 x86+x64 Server 18 | - Ubuntu18.04 arm32+arm neon Server 19 | - Ubuntu18.04 arm32+arm neon desktop 20 | - Ubuntu16.04 Mate arm32 desktop 21 | - Raspberry Pi 3 Debian linux armv7 desktop,only fpc 3.0.4,test passed. 22 | - wince(arm eabi hard flaot),windows 10 IOT,only fpc 3.3.1,test passed. 23 | 24 | ### multi cpu architectures supported，test with Delphi 10.2 upate 2 and FPC 3.0.4 25 | 26 | - MIPS(fpc-little endian), soft float, test pass on QEMU 27 | - intel X86(fpc-x86), soft float 28 | - intel X86(delphi+fpc), hard float,ATHLON64,COREI,COREAVX,COREAVX2 29 | - intel X64(fpc-x86_64), soft float 30 | - intel X64(delphi+fpc), hard float,ATHLON64,COREI,COREAVX,COREAVX2 31 | - ARM(fpc-arm32-eabi, hard float):ARMV3,ARMV4,ARMV4T,ARMV5,ARMV5T,ARMV5TE,ARMV5TEJ,ARMV6,ARMV6K,ARMV6T2,ARMV6Z,ARMV6M,ARMV7,ARMV7A,ARMV7R,ARMV7M,ARMV7EM 32 | - ARM(fpc-arm64-eabi, hard float):ARMV8，aarch64 33 | 34 | 35 | 36 | enjoy.~ 37 | 38 | # update history 39 | 40 | ### 2018-9-29 41 | 42 | - fixed rc6 on freepascal for IOT 43 | - IOT power on FPC support 44 | 45 | ### 2018-7-6 46 | 47 | - update the name rules of the Library 48 | - Support for fpc/86/64 platform, all base libraries support for Linux. 49 | - power support for the FPC compiler 3.1.1 50 | - newed Big/Little Endian order support 51 | - fixing the problem of using 32 bit FPC compiler to for with Int64 52 | - fixed string the FPC compiler runs on Linux. 53 | 54 | ### 2018-5-21 55 | 56 | - fixed twofish on memory leak 57 | - update Parallel core(fpc required package:MultiThreadProcsLaz) 58 | - added UPascalStrings.pas(fpc on unicode) 59 | 60 | 61 | ### 2018-3-1 62 | 63 | newed Smith–Waterman algorithm 64 | 65 | The Smith–Waterman algorithm performs local sequence alignment; that is, for determining similar regions between two strings of nucleic acid sequences or protein sequences. Instead of looking at the entire sequence, the Smith–Waterman algorithm compares segments of all possible lengths and optimizes the similarity measure. 66 | 67 | The algorithm was first proposed by Temple F. Smith and Michael S. Waterman in 1981.[1] Like the Needleman–Wunsch algorithm, of which it is a variation, Smith–Waterman is a dynamic programming algorithm. As such, it has the desirable property that it is guaranteed to find the optimal local alignment with respect to the scoring system being used (which includes the substitution matrix and the gap-scoring scheme). The main difference to the Needleman–Wunsch algorithm is that negative scoring matrix cells are set to zero, which renders the (thus positively scoring) local alignments visible. Traceback procedure starts at the highest scoring matrix cell and proceeds until a cell with score zero is encountered, yielding the highest scoring local alignment. Because of its cubic computational complexity in time and quadratic complexity in space, it often cannot be practically applied to large-scale problems and is replaced in favor of less general but computationally more efficient alternatives such as (Gotoh, 1982),[2] (Altschul and Erickson, 1986),[3] and (Myers and Miller 1988). 68 | 69 | https://en.wikipedia.org/wiki/Smith%E2%80%93Waterman_algorithm 70 | 71 | 72 | create by QQ 600585@qq.com 73 | 74 | 2017-11-15 75 | -------------------------------------------------------------------------------- /Samples/FMX/Unit1.fmx: -------------------------------------------------------------------------------- 1 | object Form1: TForm1 2 | Left = 0 3 | Top = 0 4 | Caption = 'Form1' 5 | ClientHeight = 480 6 | ClientWidth = 640 7 | FormFactor.Width = 320 8 | FormFactor.Height = 480 9 | FormFactor.Devices = [Desktop] 10 | OnCreate = FormCreate 11 | OnDestroy = FormDestroy 12 | DesignerMasterStyle = 0 13 | object Memo1: TMemo 14 | Touch.InteractiveGestures = [Pan, LongTap, DoubleTap] 15 | Align = Client 16 | Size.Width = 640.000000000000000000 17 | Size.Height = 480.000000000000000000 18 | Size.PlatformDefault = False 19 | TabOrder = 0 20 | ReadOnly = True 21 | end 22 | object Button1: TButton 23 | Anchors = [akTop, akRight] 24 | Position.X = 528.000000000000000000 25 | Position.Y = 8.000000000000000000 26 | TabOrder = 1 27 | Text = 'test' 28 | OnClick = Button1Click 29 | end 30 | end 31 | -------------------------------------------------------------------------------- /Samples/FMX/Unit1.pas: -------------------------------------------------------------------------------- 1 | unit Unit1; 2 | 3 | interface 4 | 5 | uses 6 | System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, 7 | FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, CoreCipher, 8 | FMX.StdCtrls, FMX.Controls.Presentation, FMX.Memo, 9 | DoStatusIO, FMX.Layouts; 10 | 11 | type 12 | TForm1 = class(TForm) 13 | Memo1: TMemo; 14 | Button1: TButton; 15 | procedure Button1Click(Sender: TObject); 16 | procedure FormCreate(Sender: TObject); 17 | procedure FormDestroy(Sender: TObject); 18 | private 19 | { Private declarations } 20 | public 21 | { Public declarations } 22 | procedure DoStatusNear(AText: string; const ID: Integer = 0); 23 | end; 24 | 25 | var 26 | Form1: TForm1; 27 | 28 | implementation 29 | 30 | {$R *.fmx} 31 | 32 | 33 | procedure TForm1.Button1Click(Sender: TObject); 34 | begin 35 | Button1.Visible:=False; 36 | TestCoreCipher; 37 | Button1.Visible:=True; 38 | end; 39 | 40 | procedure TForm1.DoStatusNear(AText: string; const ID: Integer); 41 | begin 42 | Memo1.Lines.Add(AText); 43 | Memo1.GoToTextEnd; 44 | Application.ProcessMessages; 45 | end; 46 | 47 | procedure TForm1.FormCreate(Sender: TObject); 48 | begin 49 | AddDoStatusHook(Self, DoStatusNear); 50 | end; 51 | 52 | procedure TForm1.FormDestroy(Sender: TObject); 53 | begin 54 | DeleteDoStatusHook(Self); 55 | end; 56 | 57 | end. 58 | -------------------------------------------------------------------------------- /Samples/FMX/fmxPerformance.dpr: -------------------------------------------------------------------------------- 1 | program fmxPerformance; 2 | 3 | uses 4 | System.StartUpCopy, 5 | FMX.Forms, 6 | Unit1 in 'Unit1.pas' {Form1}, 7 | CoreCipher in '..\..\Source\CoreCipher.pas', 8 | CoreClasses in '..\..\Source\CoreClasses.pas', 9 | DoStatusIO in '..\..\Source\DoStatusIO.pas', 10 | Fast_MD5 in '..\..\Source\Fast_MD5.pas', 11 | ListEngine in '..\..\Source\ListEngine.pas', 12 | MemoryStream64 in '..\..\Source\MemoryStream64.pas', 13 | PascalStrings in '..\..\Source\PascalStrings.pas', 14 | UnicodeMixedLib in '..\..\Source\UnicodeMixedLib.pas', 15 | UPascalStrings in '..\..\Source\UPascalStrings.pas'; 16 | 17 | {$R *.res} 18 | 19 | begin 20 | Application.Initialize; 21 | Application.CreateForm(TForm1, Form1); 22 | Application.Run; 23 | end. 24 | -------------------------------------------------------------------------------- /Samples/FMX/fmxPerformance.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PassByYou888/CoreCipher/c3757295fe4e252b42187e1a28f21588b57b6728/Samples/FMX/fmxPerformance.res -------------------------------------------------------------------------------- /Samples/FPC/FPCPerformanceTest.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PassByYou888/CoreCipher/c3757295fe4e252b42187e1a28f21588b57b6728/Samples/FPC/FPCPerformanceTest.ico -------------------------------------------------------------------------------- /Samples/FPC/FPCPerformanceTest.lpr: -------------------------------------------------------------------------------- 1 | program FPCperformanceTest; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | uses 6 | {$IFDEF UNIX}{$IFDEF UseCThreads} 7 | cthreads, 8 | {$ENDIF}{$ENDIF} 9 | Interfaces, // this includes the LCL widgetset 10 | Forms, Unit1, CoreCipher, DoStatusIO 11 | { you can add units after this }; 12 | 13 | {$R *.res} 14 | 15 | begin 16 | RequireDerivedFormResource:=True; 17 | Application.Initialize; 18 | Application.CreateForm(TForm1, Form1); 19 | Application.Run; 20 | end. 21 | 22 | -------------------------------------------------------------------------------- /Samples/FPC/FPCPerformanceTest.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PassByYou888/CoreCipher/c3757295fe4e252b42187e1a28f21588b57b6728/Samples/FPC/FPCPerformanceTest.res -------------------------------------------------------------------------------- /Samples/FPC/FPCperformanceTest.lpi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | <ResourceType Value="res"/> 11 | <UseXPManifest Value="True"/> 12 | <Icon Value="0"/> 13 | </General> 14 | <i18n> 15 | <EnableI18N LFM="False"/> 16 | </i18n> 17 | <BuildModes Count="1"> 18 | <Item1 Name="Default" Default="True"/> 19 | </BuildModes> 20 | <PublishOptions> 21 | <Version Value="2"/> 22 | </PublishOptions> 23 | <RunParams> 24 | <local> 25 | <FormatVersion Value="1"/> 26 | </local> 27 | </RunParams> 28 | <RequiredPackages Count="2"> 29 | <Item1> 30 | <PackageName Value="multithreadprocslaz"/> 31 | </Item1> 32 | <Item2> 33 | <PackageName Value="LCL"/> 34 | </Item2> 35 | </RequiredPackages> 36 | <Units Count="4"> 37 | <Unit0> 38 | <Filename Value="FPCperformanceTest.lpr"/> 39 | <IsPartOfProject Value="True"/> 40 | </Unit0> 41 | <Unit1> 42 | <Filename Value="unit1.pas"/> 43 | <IsPartOfProject Value="True"/> 44 | <ComponentName Value="Form1"/> 45 | <HasResources Value="True"/> 46 | <ResourceBaseClass Value="Form"/> 47 | <UnitName Value="Unit1"/> 48 | </Unit1> 49 | <Unit2> 50 | <Filename Value="..\..\Source\DoStatusIO.pas"/> 51 | <IsPartOfProject Value="True"/> 52 | </Unit2> 53 | <Unit3> 54 | <Filename Value="..\..\Source\CoreCipher.pas"/> 55 | <IsPartOfProject Value="True"/> 56 | </Unit3> 57 | </Units> 58 | </ProjectOptions> 59 | <CompilerOptions> 60 | <Version Value="11"/> 61 | <PathDelim Value="\"/> 62 | <Target> 63 | <Filename Value="FPCperformanceTest"/> 64 | </Target> 65 | <SearchPaths> 66 | <IncludeFiles Value="$(ProjOutDir)"/> 67 | <OtherUnitFiles Value="..\..\Source"/> 68 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 69 | </SearchPaths> 70 | <Linking> 71 | <Options> 72 | <Win32> 73 | <GraphicApplication Value="True"/> 74 | </Win32> 75 | </Options> 76 | </Linking> 77 | </CompilerOptions> 78 | <Debugging> 79 | <Exceptions Count="3"> 80 | <Item1> 81 | <Name Value="EAbort"/> 82 | </Item1> 83 | <Item2> 84 | <Name Value="ECodetoolError"/> 85 | </Item2> 86 | <Item3> 87 | <Name Value="EFOpenError"/> 88 | </Item3> 89 | </Exceptions> 90 | </Debugging> 91 | </CONFIG> 92 | -------------------------------------------------------------------------------- /Samples/FPC/FPCperformanceTest.lps: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectSession> 4 | <PathDelim Value="\"/> 5 | <Version Value="11"/> 6 | <BuildModes Active="Default"/> 7 | <Units Count="10"> 8 | <Unit0> 9 | <Filename Value="FPCperformanceTest.lpr"/> 10 | <IsPartOfProject Value="True"/> 11 | <EditorIndex Value="-1"/> 12 | <CursorPos X="40" Y="10"/> 13 | <UsageCount Value="20"/> 14 | </Unit0> 15 | <Unit1> 16 | <Filename Value="unit1.pas"/> 17 | <IsPartOfProject Value="True"/> 18 | <ComponentName Value="Form1"/> 19 | <HasResources Value="True"/> 20 | <ResourceBaseClass Value="Form"/> 21 | <UnitName Value="Unit1"/> 22 | <CursorPos X="38" Y="17"/> 23 | <UsageCount Value="20"/> 24 | <Loaded Value="True"/> 25 | <LoadedDesigner Value="True"/> 26 | </Unit1> 27 | <Unit2> 28 | <Filename Value="..\..\Source\DoStatusIO.pas"/> 29 | <IsPartOfProject Value="True"/> 30 | <EditorIndex Value="-1"/> 31 | <UsageCount Value="20"/> 32 | </Unit2> 33 | <Unit3> 34 | <Filename Value="..\..\Source\CoreCipher.pas"/> 35 | <IsPartOfProject Value="True"/> 36 | <EditorIndex Value="-1"/> 37 | <TopLine Value="31"/> 38 | <CursorPos X="41" Y="42"/> 39 | <UsageCount Value="20"/> 40 | </Unit3> 41 | <Unit4> 42 | <Filename Value="..\..\Source\Fast_MD5.pas"/> 43 | <EditorIndex Value="-1"/> 44 | <UsageCount Value="10"/> 45 | </Unit4> 46 | <Unit5> 47 | <Filename Value="..\..\Source\CoreClasses.pas"/> 48 | <EditorIndex Value="-1"/> 49 | <TopLine Value="14"/> 50 | <CursorPos X="70" Y="39"/> 51 | <UsageCount Value="10"/> 52 | </Unit5> 53 | <Unit6> 54 | <Filename Value="..\..\Source\MemoryStream64.pas"/> 55 | <EditorIndex Value="-1"/> 56 | <TopLine Value="198"/> 57 | <CursorPos X="71" Y="218"/> 58 | <UsageCount Value="10"/> 59 | </Unit6> 60 | <Unit7> 61 | <Filename Value="..\..\Source\ListEngine.pas"/> 62 | <IsVisibleTab Value="True"/> 63 | <EditorIndex Value="1"/> 64 | <TopLine Value="1392"/> 65 | <CursorPos X="42" Y="1422"/> 66 | <UsageCount Value="10"/> 67 | <Loaded Value="True"/> 68 | </Unit7> 69 | <Unit8> 70 | <Filename Value="..\..\Source\OpCode.pas"/> 71 | <EditorIndex Value="-1"/> 72 | <TopLine Value="2"/> 73 | <CursorPos X="91" Y="37"/> 74 | <UsageCount Value="10"/> 75 | </Unit8> 76 | <Unit9> 77 | <Filename Value="..\..\Source\DataFrameEngine.pas"/> 78 | <EditorIndex Value="-1"/> 79 | <TopLine Value="10"/> 80 | <CursorPos X="89" Y="42"/> 81 | <UsageCount Value="10"/> 82 | </Unit9> 83 | </Units> 84 | <JumpHistory Count="5" HistoryIndex="4"> 85 | <Position1> 86 | <Filename Value="unit1.pas"/> 87 | <Caret Line="26" Column="39"/> 88 | </Position1> 89 | <Position2> 90 | <Filename Value="unit1.pas"/> 91 | <Caret Line="5"/> 92 | </Position2> 93 | <Position3> 94 | <Filename Value="unit1.pas"/> 95 | <Caret Line="27" Column="41"/> 96 | </Position3> 97 | <Position4> 98 | <Filename Value="unit1.pas"/> 99 | <Caret Line="21" Column="62"/> 100 | </Position4> 101 | <Position5> 102 | <Filename Value="unit1.pas"/> 103 | <Caret Line="17" Column="38"/> 104 | </Position5> 105 | </JumpHistory> 106 | <RunParams> 107 | <FormatVersion Value="2"/> 108 | <Modes Count="0" ActiveMode="default"/> 109 | </RunParams> 110 | </ProjectSession> 111 | </CONFIG> 112 | -------------------------------------------------------------------------------- /Samples/FPC/unit1.lfm: -------------------------------------------------------------------------------- 1 | object Form1: TForm1 2 | Left = 499 3 | Height = 502 4 | Top = 128 5 | Width = 715 6 | Caption = 'Form1' 7 | ClientHeight = 502 8 | ClientWidth = 715 9 | OnCreate = FormCreate 10 | OnDestroy = FormDestroy 11 | LCLVersion = '1.8.0.6' 12 | object Memo1: TMemo 13 | Left = 0 14 | Height = 502 15 | Top = 0 16 | Width = 715 17 | Align = alClient 18 | Lines.Strings = ( 19 | 'Memo1' 20 | ) 21 | ScrollBars = ssAutoBoth 22 | TabOrder = 0 23 | end 24 | object Button1: TButton 25 | Left = 608 26 | Height = 25 27 | Top = 16 28 | Width = 75 29 | Caption = 'test' 30 | OnClick = Button1Click 31 | TabOrder = 1 32 | end 33 | end 34 | -------------------------------------------------------------------------------- /Samples/FPC/unit1.pas: -------------------------------------------------------------------------------- 1 | unit Unit1; 2 | 3 | {$mode objfpc}{$H+} 4 | {$MODESWITCH AdvancedRecords} 5 | 6 | 7 | interface 8 | 9 | uses 10 | Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, 11 | CoreCipher, DoStatusIO, PascalStrings; 12 | 13 | type 14 | 15 | { TForm1 } 16 | 17 | TForm1 = class(TForm) 18 | Button1: TButton; 19 | Memo1: TMemo; 20 | procedure Button1Click(Sender: TObject); 21 | procedure FormCreate(Sender: TObject); 22 | procedure FormDestroy(Sender: TObject); 23 | private 24 | { private declarations } 25 | public 26 | { public declarations } 27 | procedure DoStatusNear(AText: Systemstring; const ID: Integer=0); 28 | end; 29 | 30 | var 31 | Form1: TForm1; 32 | 33 | implementation 34 | 35 | {$R *.lfm} 36 | 37 | { TForm1 } 38 | procedure TForm1.DoStatusNear(AText: Systemstring; const ID: Integer=0); 39 | begin 40 | Form1.Memo1.Lines.Add(AText); 41 | Application.ProcessMessages; 42 | end; 43 | 44 | 45 | procedure TForm1.FormCreate(Sender: TObject); 46 | begin 47 | AddDoStatusHook(Self, @DoStatusNear); 48 | end; 49 | 50 | procedure TForm1.Button1Click(Sender: TObject); 51 | begin 52 | Button1.Visible:=False; 53 | TestCoreCipher; 54 | Button1.Visible:=True; 55 | end; 56 | 57 | procedure TForm1.FormDestroy(Sender: TObject); 58 | begin 59 | DeleteDoStatusHook(Self); 60 | end; 61 | 62 | end. 63 | 64 | -------------------------------------------------------------------------------- /Samples/VCL/Unit1.dfm: -------------------------------------------------------------------------------- 1 | object Form1: TForm1 2 | Left = 0 3 | Top = 0 4 | Caption = 'Form1' 5 | ClientHeight = 412 6 | ClientWidth = 852 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | OnCreate = FormCreate 15 | OnDestroy = FormDestroy 16 | DesignSize = ( 17 | 852 18 | 412) 19 | PixelsPerInch = 96 20 | TextHeight = 13 21 | object Memo1: TMemo 22 | Left = 0 23 | Top = 0 24 | Width = 852 25 | Height = 412 26 | Align = alClient 27 | ScrollBars = ssBoth 28 | TabOrder = 0 29 | end 30 | object Button1: TButton 31 | Left = 744 32 | Top = 8 33 | Width = 75 34 | Height = 25 35 | Anchors = [akTop, akRight] 36 | Caption = 'test' 37 | TabOrder = 1 38 | OnClick = Button1Click 39 | end 40 | end 41 | -------------------------------------------------------------------------------- /Samples/VCL/Unit1.pas: -------------------------------------------------------------------------------- 1 | unit Unit1; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DoStatusIO, 8 | CoreCipher; 9 | 10 | type 11 | TForm1 = class(TForm) 12 | Memo1: TMemo; 13 | Button1: TButton; 14 | procedure Button1Click(Sender: TObject); 15 | procedure FormCreate(Sender: TObject); 16 | procedure FormDestroy(Sender: TObject); 17 | private 18 | { Private declarations } 19 | public 20 | { Public declarations } 21 | procedure DoStatusNear(AText: string; const ID: Integer = 0); 22 | end; 23 | 24 | var 25 | Form1: TForm1; 26 | 27 | implementation 28 | 29 | {$R *.dfm} 30 | 31 | procedure TForm1.Button1Click(Sender: TObject); 32 | begin 33 | Button1.Visible:=False; 34 | TestCoreCipher; 35 | Button1.Visible:=True; 36 | end; 37 | 38 | procedure TForm1.DoStatusNear(AText: string; const ID: Integer); 39 | begin 40 | Memo1.Lines.Add(AText); 41 | Application.ProcessMessages; 42 | end; 43 | 44 | procedure TForm1.FormCreate(Sender: TObject); 45 | begin 46 | AddDoStatusHook(Self, DoStatusNear); 47 | end; 48 | 49 | procedure TForm1.FormDestroy(Sender: TObject); 50 | begin 51 | DeleteDoStatusHook(Self); 52 | end; 53 | 54 | end. 55 | -------------------------------------------------------------------------------- /Samples/VCL/VCLPerformanceTest.dpr: -------------------------------------------------------------------------------- 1 | program VCLPerformanceTest; 2 | 3 | uses 4 | Vcl.Forms, 5 | Unit1 in 'Unit1.pas' {Form1}, 6 | CoreCipher in '..\..\Source\CoreCipher.pas', 7 | CoreClasses in '..\..\Source\CoreClasses.pas', 8 | DoStatusIO in '..\..\Source\DoStatusIO.pas', 9 | Fast_MD5 in '..\..\Source\Fast_MD5.pas', 10 | ListEngine in '..\..\Source\ListEngine.pas', 11 | MemoryStream64 in '..\..\Source\MemoryStream64.pas', 12 | PascalStrings in '..\..\Source\PascalStrings.pas', 13 | UnicodeMixedLib in '..\..\Source\UnicodeMixedLib.pas', 14 | UPascalStrings in '..\..\Source\UPascalStrings.pas'; 15 | 16 | {$R *.res} 17 | 18 | begin 19 | Application.Initialize; 20 | Application.MainFormOnTaskbar := True; 21 | Application.CreateForm(TForm1, Form1); 22 | Application.Run; 23 | end. 24 | -------------------------------------------------------------------------------- /Samples/VCL/VCLPerformanceTest.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PassByYou888/CoreCipher/c3757295fe4e252b42187e1a28f21588b57b6728/Samples/VCL/VCLPerformanceTest.res -------------------------------------------------------------------------------- /Source/Cadencer.pas: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { * cadencer imp library written by QQ 600585@qq.com * } 3 | { * https://zpascal.net * } 4 | { * https://github.com/PassByYou888/zAI * } 5 | { * https://github.com/PassByYou888/ZServer4D * } 6 | { * https://github.com/PassByYou888/PascalString * } 7 | { * https://github.com/PassByYou888/zRasterization * } 8 | { * https://github.com/PassByYou888/CoreCipher * } 9 | { * https://github.com/PassByYou888/zSound * } 10 | { * https://github.com/PassByYou888/zChinese * } 11 | { * https://github.com/PassByYou888/zExpression * } 12 | { * https://github.com/PassByYou888/zGameWare * } 13 | { * https://github.com/PassByYou888/zAnalysis * } 14 | { * https://github.com/PassByYou888/FFMPEG-Header * } 15 | { * https://github.com/PassByYou888/zTranslate * } 16 | { * https://github.com/PassByYou888/InfiniteIoT * } 17 | { * https://github.com/PassByYou888/FastMD5 * } 18 | { ****************************************************************************** } 19 | 20 | unit Cadencer; 21 | 22 | {$INCLUDE zDefine.inc} 23 | 24 | interface 25 | 26 | uses CoreClasses; 27 | 28 | type 29 | { 30 | Progression event for time-base animations/simulations. 31 | deltaTime is the time delta since last progress and newTime is the new 32 | time after the progress event is completed. 33 | } 34 | TCadencerProgressMethod = procedure(Sender: TObject; const deltaTime, newTime: Double) of object; 35 | TCadencerProgressCall = procedure(Sender: TObject; const deltaTime, newTime: Double); 36 | {$IFDEF FPC} 37 | TCadencerProgressProc = procedure(Sender: TObject; const deltaTime, newTime: Double) is nested; 38 | {$ELSE FPC} 39 | TCadencerProgressProc = reference to procedure(Sender: TObject; const deltaTime, newTime: Double); 40 | {$ENDIF FPC} 41 | 42 | ICadencerProgressInterface = interface 43 | procedure CadencerProgress(const deltaTime, newTime: Double); 44 | end; 45 | 46 | { 47 | This component allows auto-progression of animation. 48 | Basicly dropping this component and linking it to your app will send 49 | it real-time progression events (time will be measured in seconds) while 50 | keeping the CPU 100% busy if possible (ie. if things change in your app). 51 | The progression time (the one you'll see in you progression events) 52 | is calculated using (CurrentTime-OriginTime)*TimeMultiplier, 53 | CurrentTime being either manually or automatically updated using 54 | TimeReference (setting CurrentTime does NOT trigger progression). 55 | } 56 | TCadencer = class(TCoreClassObject) 57 | private 58 | { Private Declarations } 59 | FTimeMultiplier: Double; 60 | LastTime, DownTime, LastMultiplier: Double; 61 | FLastDeltaTime: Double; 62 | FEnabled: Boolean; 63 | FSleepLength: Integer; 64 | FCurrentTime: Double; 65 | FOriginTime: Double; 66 | FMaxDeltaTime, FMinDeltaTime, FFixedDeltaTime: Double; 67 | FOnProgress: TCadencerProgressMethod; 68 | FOnProgressCall: TCadencerProgressCall; 69 | FOnProgressProc: TCadencerProgressProc; 70 | FProgressing: Integer; 71 | FProgressIntf: ICadencerProgressInterface; 72 | protected 73 | function StoreTimeMultiplier: Boolean; 74 | procedure SetEnabled(const val_: Boolean); 75 | procedure SetTimeMultiplier(const val_: Double); 76 | procedure SetCurrentTime(const Value: Double); 77 | { Returns raw ref time (no multiplier, no offset) } 78 | function GetRawReferenceTime: Double; 79 | public 80 | constructor Create; 81 | destructor Destroy; override; 82 | 83 | { Allows to manually trigger a progression. Time stuff is handled automatically. If cadencer is disabled, this functions does nothing. } 84 | procedure Progress; 85 | 86 | { Adjusts CurrentTime if necessary, then returns its value. } 87 | function UpdateCurrentTime: Double; 88 | 89 | { Returns True if a "Progress" is underway. } 90 | function IsBusy: Boolean; 91 | 92 | { Reset the time parameters and returns to zero. } 93 | procedure Reset; 94 | 95 | { Value soustracted to current time to obtain progression time. } 96 | property OriginTime: Double read FOriginTime write FOriginTime; 97 | { Current time (manually or automatically set, see TimeReference). } 98 | property CurrentTime: Double read FCurrentTime write SetCurrentTime; 99 | 100 | { Enables/Disables cadencing. 101 | Disabling won't cause a jump when restarting, it is working like a play/pause (ie. may modify OriginTime to keep things smooth). } 102 | property Enabled: Boolean read FEnabled write SetEnabled default True; 103 | 104 | { Multiplier applied to the time reference. } 105 | property TimeMultiplier: Double read FTimeMultiplier write SetTimeMultiplier stored StoreTimeMultiplier; 106 | 107 | { Maximum value for deltaTime in progression events. 108 | If null or negative, no max deltaTime is defined, otherwise, whenever an event whose actual deltaTime would be superior to MaxDeltaTime occurs, 109 | deltaTime is clamped to this max, and the extra time is hidden by the cadencer (it isn't visible in CurrentTime either). 110 | This option allows to limit progression rate in simulations where high values would result in errors/random behaviour. } 111 | property MaxDeltaTime: Double read FMaxDeltaTime write FMaxDeltaTime; 112 | 113 | { Minimum value for deltaTime in progression events. 114 | If superior to zero, this value specifies the minimum time step between two progression events. 115 | This option allows to limit progression rate in simulations where low values would result in errors/random behaviour. } 116 | property MinDeltaTime: Double read FMinDeltaTime write FMinDeltaTime; 117 | 118 | { Fixed time-step value for progression events. 119 | If superior to zero, progression steps will happen with that fixed delta time. 120 | The progression remains time based, 121 | so zero to N events may be fired depending on the actual deltaTime (if deltaTime is inferior to FixedDeltaTime, no event will be fired, 122 | if it is superior to two times FixedDeltaTime, two events will be fired, etc.). 123 | This option allows to use fixed time steps in simulations (while the animation and rendering itself may happen at a lower or higher framerate). } 124 | property FixedDeltaTime: Double read FFixedDeltaTime write FFixedDeltaTime; 125 | 126 | { Allows relinquishing time to other threads/processes. 127 | A "sleep" is issued BEFORE each progress if SleepLength>=0 (see help for the "sleep" procedure in delphi for details). } 128 | property SleepLength: Integer read FSleepLength write FSleepLength default -1; 129 | 130 | { LastDeltaTime from progress. } 131 | property LastDeltaTime: Double read FLastDeltaTime; 132 | 133 | { backcall } 134 | property OnProgress: TCadencerProgressMethod read FOnProgress write FOnProgress; 135 | property OnProgressCall: TCadencerProgressCall read FOnProgressCall write FOnProgressCall; 136 | property OnProgressProc: TCadencerProgressProc read FOnProgressProc write FOnProgressProc; 137 | { interface } 138 | property ProgressInterface: ICadencerProgressInterface read FProgressIntf write FProgressIntf; 139 | property OnProgressInterface: ICadencerProgressInterface read FProgressIntf write FProgressIntf; 140 | end; 141 | 142 | implementation 143 | 144 | function TCadencer.StoreTimeMultiplier: Boolean; 145 | begin 146 | Result := (FTimeMultiplier <> 1); 147 | end; 148 | 149 | procedure TCadencer.SetEnabled(const val_: Boolean); 150 | begin 151 | if FEnabled <> val_ then 152 | begin 153 | FEnabled := val_; 154 | if Enabled then 155 | FOriginTime := FOriginTime + GetRawReferenceTime - DownTime 156 | else 157 | DownTime := GetRawReferenceTime; 158 | end; 159 | end; 160 | 161 | procedure TCadencer.SetTimeMultiplier(const val_: Double); 162 | var 163 | rawRef: Double; 164 | begin 165 | if val_ <> FTimeMultiplier then 166 | begin 167 | if val_ = 0 then 168 | begin 169 | LastMultiplier := FTimeMultiplier; 170 | Enabled := False; 171 | end 172 | else 173 | begin 174 | rawRef := GetRawReferenceTime; 175 | if FTimeMultiplier = 0 then 176 | begin 177 | Enabled := True; 178 | FOriginTime := rawRef - (rawRef - FOriginTime) * LastMultiplier / val_; 179 | end 180 | else 181 | FOriginTime := rawRef - (rawRef - FOriginTime) * FTimeMultiplier / val_; 182 | end; 183 | FTimeMultiplier := val_; 184 | end; 185 | end; 186 | 187 | procedure TCadencer.SetCurrentTime(const Value: Double); 188 | begin 189 | LastTime := Value - (FCurrentTime - LastTime); 190 | FOriginTime := FOriginTime + (FCurrentTime - Value); 191 | FCurrentTime := Value; 192 | end; 193 | 194 | function TCadencer.GetRawReferenceTime: Double; 195 | begin 196 | Result := GetTimeTick * 0.001; 197 | end; 198 | 199 | constructor TCadencer.Create; 200 | begin 201 | inherited Create; 202 | DownTime := GetRawReferenceTime; 203 | FOriginTime := DownTime; 204 | FTimeMultiplier := 1; 205 | LastTime := 0; 206 | LastMultiplier := 0; 207 | FLastDeltaTime := 0; 208 | FSleepLength := -1; 209 | Enabled := True; 210 | FOnProgress := nil; 211 | FOnProgressCall := nil; 212 | FOnProgressProc := nil; 213 | FProgressIntf := nil; 214 | end; 215 | 216 | destructor TCadencer.Destroy; 217 | begin 218 | while FProgressing > 0 do 219 | TCompute.Sleep(1); 220 | inherited Destroy; 221 | end; 222 | 223 | procedure TCadencer.Progress; 224 | var 225 | deltaTime, newTime, totalDelta: Double; 226 | begin 227 | { basic protection against infinite loops, } 228 | { shall never happen, unless there is a bug in user code } 229 | if FProgressing < 0 then 230 | Exit; 231 | if Enabled then 232 | begin 233 | { avoid stalling everything else... } 234 | if SleepLength >= 0 then 235 | TCoreClassThread.Sleep(SleepLength); 236 | end; 237 | AtomInc(FProgressing); 238 | try 239 | if Enabled then 240 | begin 241 | { One of the processed messages might have disabled us } 242 | if Enabled then 243 | begin 244 | { ...and progress ! } 245 | newTime := UpdateCurrentTime; 246 | deltaTime := newTime - LastTime; 247 | if (deltaTime >= MinDeltaTime) and (deltaTime >= FixedDeltaTime) then 248 | begin 249 | if FMaxDeltaTime > 0 then 250 | begin 251 | if deltaTime > FMaxDeltaTime then 252 | begin 253 | FOriginTime := FOriginTime + (deltaTime - FMaxDeltaTime) / FTimeMultiplier; 254 | deltaTime := FMaxDeltaTime; 255 | newTime := LastTime + deltaTime; 256 | end; 257 | end; 258 | totalDelta := deltaTime; 259 | if FixedDeltaTime > 0 then 260 | deltaTime := FixedDeltaTime; 261 | while totalDelta >= deltaTime do 262 | begin 263 | LastTime := LastTime + deltaTime; 264 | FLastDeltaTime := deltaTime; 265 | try 266 | if Assigned(FOnProgress) then 267 | FOnProgress(Self, deltaTime, newTime); 268 | if Assigned(FOnProgressCall) then 269 | FOnProgressCall(Self, deltaTime, newTime); 270 | if Assigned(FOnProgressProc) then 271 | FOnProgressProc(Self, deltaTime, newTime); 272 | if Assigned(FProgressIntf) then 273 | FProgressIntf.CadencerProgress(deltaTime, newTime); 274 | except 275 | end; 276 | 277 | if deltaTime <= 0 then 278 | Break; 279 | totalDelta := totalDelta - deltaTime; 280 | end; 281 | end; 282 | end; 283 | end; 284 | finally 285 | AtomDec(FProgressing); 286 | end; 287 | end; 288 | 289 | function TCadencer.UpdateCurrentTime: Double; 290 | begin 291 | Result := (GetRawReferenceTime - FOriginTime) * FTimeMultiplier; 292 | FCurrentTime := Result; 293 | end; 294 | 295 | function TCadencer.IsBusy: Boolean; 296 | begin 297 | Result := (FProgressing > 0); 298 | end; 299 | 300 | procedure TCadencer.Reset; 301 | begin 302 | LastTime := 0; 303 | DownTime := GetRawReferenceTime; 304 | FOriginTime := DownTime; 305 | end; 306 | 307 | initialization 308 | 309 | finalization 310 | 311 | end. 312 | -------------------------------------------------------------------------------- /Source/CoreAtomic.inc: -------------------------------------------------------------------------------- 1 | // used Critical Simulate Atomic with TMonitor.Enter(obj) and TMonitor.Exit(obj) 2 | // CriticalSimulateAtomic defined so performance to be reduced 3 | 4 | // used soft Simulate Critical(ring) 5 | // SoftCritical defined so performance to be reduced 6 | 7 | { * object lock create by qq600585 * } 8 | { ****************************************************************************** } 9 | { * https://zpascal.net * } 10 | { * https://github.com/PassByYou888/zAI * } 11 | { * https://github.com/PassByYou888/ZServer4D * } 12 | { * https://github.com/PassByYou888/PascalString * } 13 | { * https://github.com/PassByYou888/zRasterization * } 14 | { * https://github.com/PassByYou888/CoreCipher * } 15 | { * https://github.com/PassByYou888/zSound * } 16 | { * https://github.com/PassByYou888/zChinese * } 17 | { * https://github.com/PassByYou888/zExpression * } 18 | { * https://github.com/PassByYou888/zGameWare * } 19 | { * https://github.com/PassByYou888/zAnalysis * } 20 | { * https://github.com/PassByYou888/FFMPEG-Header * } 21 | { * https://github.com/PassByYou888/zTranslate * } 22 | { * https://github.com/PassByYou888/InfiniteIoT * } 23 | { * https://github.com/PassByYou888/FastMD5 * } 24 | { ****************************************************************************** } 25 | 26 | constructor TSoftCritical.Create; 27 | begin 28 | inherited Create; 29 | L := False; 30 | end; 31 | 32 | procedure TSoftCritical.Acquire; 33 | {$IFDEF ANTI_DEAD_ATOMIC_LOCK} 34 | var 35 | d: TTimeTick; 36 | {$ENDIF ANTI_DEAD_ATOMIC_LOCK} 37 | begin 38 | {$IFDEF ANTI_DEAD_ATOMIC_LOCK} 39 | d := GetTimeTick; 40 | while L do 41 | if GetTimeTick - d >= 5000 then 42 | RaiseInfo('dead lock'); 43 | {$ELSE ANTI_DEAD_ATOMIC_LOCK} 44 | while L do 45 | NOP; 46 | {$ENDIF ANTI_DEAD_ATOMIC_LOCK} 47 | L := True; 48 | end; 49 | 50 | procedure TSoftCritical.Release; 51 | begin 52 | L := False; 53 | end; 54 | 55 | procedure TSoftCritical.Enter; 56 | begin 57 | Acquire; 58 | end; 59 | 60 | procedure TSoftCritical.Leave; 61 | begin 62 | Release; 63 | end; 64 | 65 | constructor TCritical.Create; 66 | begin 67 | inherited Create; 68 | LNum := 0; 69 | end; 70 | 71 | destructor TCritical.Destroy; 72 | begin 73 | inherited Destroy; 74 | end; 75 | 76 | procedure TCritical.Acquire; 77 | begin 78 | inherited Acquire; 79 | Inc(LNum); 80 | end; 81 | 82 | procedure TCritical.Release; 83 | begin 84 | Dec(LNum); 85 | inherited Release; 86 | end; 87 | 88 | procedure TCritical.Enter; 89 | begin 90 | Acquire(); 91 | end; 92 | 93 | procedure TCritical.Leave; 94 | begin 95 | Release(); 96 | end; 97 | 98 | procedure TCritical.Lock; 99 | begin 100 | Acquire(); 101 | end; 102 | 103 | procedure TCritical.UnLock; 104 | begin 105 | Release(); 106 | end; 107 | 108 | function TCritical.IsBusy: Boolean; 109 | begin 110 | Result := LNum > 0; 111 | end; 112 | 113 | procedure TCritical.Inc_(var x: Int64); 114 | begin 115 | Lock; 116 | Inc(x); 117 | UnLock; 118 | end; 119 | 120 | procedure TCritical.Inc_(var x: Int64; const v: Int64); 121 | begin 122 | Lock; 123 | Inc(x, v); 124 | UnLock; 125 | end; 126 | 127 | procedure TCritical.Dec_(var x: Int64); 128 | begin 129 | Lock; 130 | Dec(x); 131 | UnLock; 132 | end; 133 | 134 | procedure TCritical.Dec_(var x: Int64; const v: Int64); 135 | begin 136 | Lock; 137 | Dec(x, v); 138 | UnLock; 139 | end; 140 | 141 | procedure TCritical.Inc_(var x: UInt64); 142 | begin 143 | Lock; 144 | Inc(x); 145 | UnLock; 146 | end; 147 | 148 | procedure TCritical.Inc_(var x: UInt64; const v: UInt64); 149 | begin 150 | Lock; 151 | Inc(x, v); 152 | UnLock; 153 | end; 154 | 155 | procedure TCritical.Dec_(var x: UInt64); 156 | begin 157 | Lock; 158 | Dec(x); 159 | UnLock; 160 | end; 161 | 162 | procedure TCritical.Dec_(var x: UInt64; const v: UInt64); 163 | begin 164 | Lock; 165 | Dec(x, v); 166 | UnLock; 167 | end; 168 | 169 | procedure TCritical.Inc_(var x: Integer); 170 | begin 171 | Lock; 172 | Inc(x); 173 | UnLock; 174 | end; 175 | 176 | procedure TCritical.Inc_(var x: Integer; const v: Integer); 177 | begin 178 | Lock; 179 | Inc(x, v); 180 | UnLock; 181 | end; 182 | 183 | procedure TCritical.Dec_(var x: Integer); 184 | begin 185 | Lock; 186 | Dec(x); 187 | UnLock; 188 | end; 189 | 190 | procedure TCritical.Dec_(var x: Integer; const v: Integer); 191 | begin 192 | Lock; 193 | Dec(x, v); 194 | UnLock; 195 | end; 196 | 197 | procedure TCritical.Inc_(var x: Cardinal); 198 | begin 199 | Lock; 200 | Inc(x); 201 | UnLock; 202 | end; 203 | 204 | procedure TCritical.Inc_(var x: Cardinal; const v: Cardinal); 205 | begin 206 | Lock; 207 | Inc(x, v); 208 | UnLock; 209 | end; 210 | 211 | procedure TCritical.Dec_(var x: Cardinal); 212 | begin 213 | Lock; 214 | Dec(x); 215 | UnLock; 216 | end; 217 | 218 | procedure TCritical.Dec_(var x: Cardinal; const v: Cardinal); 219 | begin 220 | Lock; 221 | Dec(x, v); 222 | UnLock; 223 | end; 224 | 225 | type 226 | PCritical_Struct = ^TCritical_Struct; 227 | 228 | TCritical_Struct = record 229 | Obj: TObject; 230 | LEnter: Integer; 231 | LockTick: TTimeTick; 232 | Critical: TCritical; 233 | end; 234 | 235 | TGetCriticalLockState = (lsSame, lsNew, lsIdle); 236 | 237 | var 238 | CoreLockCritical: TCriticalSection; 239 | CoreComputeCritical: TCriticalSection; 240 | CoreTimeTickCritical: TCriticalSection; 241 | CriticalList: TCoreClassList; 242 | 243 | procedure InitCriticalLock; 244 | begin 245 | CoreLockCritical := TCriticalSection.Create; 246 | CoreComputeCritical := TCriticalSection.Create; 247 | CoreTimeTickCritical := TCriticalSection.Create; 248 | CriticalList := TCoreClassList.Create; 249 | end; 250 | 251 | procedure FreeCriticalLock; 252 | var 253 | i: Integer; 254 | p: PCritical_Struct; 255 | begin 256 | for i := 0 to CriticalList.Count - 1 do 257 | begin 258 | p := PCritical_Struct(CriticalList[i]); 259 | p^.Critical.Free; 260 | Dispose(p); 261 | end; 262 | CriticalList.Free; 263 | CriticalList := nil; 264 | 265 | CoreLockCritical.Free; 266 | CoreLockCritical := nil; 267 | 268 | CoreComputeCritical.Free; 269 | CoreComputeCritical := nil; 270 | 271 | CoreTimeTickCritical.Free; 272 | CoreTimeTickCritical := nil; 273 | end; 274 | 275 | procedure GetCriticalLock(const Obj: TObject; var output: PCritical_Struct; var state: TGetCriticalLockState); 276 | var 277 | i, pIndex: Integer; 278 | p1, p2: PCritical_Struct; 279 | begin 280 | output := nil; 281 | pIndex := -1; 282 | p1 := nil; 283 | i := 0; 284 | while i < CriticalList.Count do 285 | begin 286 | p2 := PCritical_Struct(CriticalList[i]); 287 | if p2^.Obj = Obj then 288 | begin 289 | output := p2; 290 | state := TGetCriticalLockState.lsSame; 291 | exit; 292 | end 293 | else if (p2^.Obj = nil) and (p2^.LEnter = 0) then 294 | begin 295 | p1 := p2; 296 | pIndex := i; 297 | end; 298 | Inc(i); 299 | end; 300 | 301 | if p1 <> nil then 302 | begin 303 | p1^.Obj := Obj; 304 | output := p1; 305 | if pIndex > 0 then 306 | CriticalList.Move(pIndex, 0); 307 | state := TGetCriticalLockState.lsIdle; 308 | end 309 | else 310 | begin 311 | new(p1); 312 | p1^.Obj := Obj; 313 | p1^.LEnter := 0; 314 | p1^.LockTick := GetTimeTick(); 315 | p1^.Critical := TCritical.Create; 316 | CriticalList.Insert(0, p1); 317 | output := p1; 318 | state := TGetCriticalLockState.lsNew; 319 | end; 320 | end; 321 | 322 | procedure _LockCriticalObj(Obj: TObject); 323 | var 324 | p: PCritical_Struct; 325 | ls: TGetCriticalLockState; 326 | begin 327 | CoreLockCritical.Acquire; 328 | GetCriticalLock(Obj, p, ls); 329 | CoreLockCritical.Release; 330 | p^.Critical.Acquire; 331 | p^.LockTick := GetTimeTick(); 332 | AtomInc(p^.LEnter); 333 | end; 334 | 335 | procedure _UnLockCriticalObj(Obj: TObject); 336 | var 337 | p: PCritical_Struct; 338 | ls: TGetCriticalLockState; 339 | begin 340 | CoreLockCritical.Acquire; 341 | GetCriticalLock(Obj, p, ls); 342 | CoreLockCritical.Release; 343 | 344 | AtomDec(p^.LEnter); 345 | if p^.LEnter < 0 then 346 | RaiseInfo('error: unlock failed: illegal unlock'); 347 | p^.LockTick := GetTimeTick(); 348 | p^.Critical.Release; 349 | end; 350 | 351 | procedure _RecycleLocker(const Obj: TObject); 352 | var 353 | p: PCritical_Struct; 354 | i: Integer; 355 | begin 356 | if (CoreLockCritical = nil) or (CriticalList = nil) or (CriticalList.Count = 0) then 357 | exit; 358 | 359 | CoreLockCritical.Acquire; 360 | i := 0; 361 | while i < CriticalList.Count do 362 | begin 363 | p := PCritical_Struct(CriticalList[i]); 364 | if p^.Obj = Obj then 365 | begin 366 | CriticalList.Delete(i); 367 | p^.Critical.Free; 368 | Dispose(p); 369 | break; 370 | end 371 | else 372 | Inc(i); 373 | end; 374 | CoreLockCritical.Release; 375 | end; 376 | 377 | function DeltaStep(const value_, Delta_: NativeInt): NativeInt; 378 | begin 379 | if Delta_ > 0 then 380 | Result := (value_ + (Delta_ - 1)) and (not(Delta_ - 1)) 381 | else 382 | Result := value_; 383 | end; 384 | 385 | procedure AtomInc(var x: Int64); 386 | begin 387 | {$IFDEF FPC} 388 | CoreComputeCritical.Acquire; 389 | Inc(x); 390 | CoreComputeCritical.Release; 391 | {$ELSE FPC} 392 | System.AtomicIncrement(x); 393 | {$ENDIF FPC} 394 | end; 395 | 396 | procedure AtomInc(var x: Int64; const v: Int64); 397 | begin 398 | {$IFDEF FPC} 399 | CoreComputeCritical.Acquire; 400 | Inc(x, v); 401 | CoreComputeCritical.Release; 402 | {$ELSE FPC} 403 | System.AtomicIncrement(x, v); 404 | {$ENDIF FPC} 405 | end; 406 | 407 | procedure AtomDec(var x: Int64); 408 | begin 409 | {$IFDEF FPC} 410 | CoreComputeCritical.Acquire; 411 | Dec(x); 412 | CoreComputeCritical.Release; 413 | {$ELSE FPC} 414 | System.AtomicDecrement(x); 415 | {$ENDIF FPC} 416 | end; 417 | 418 | procedure AtomDec(var x: Int64; const v: Int64); 419 | begin 420 | {$IFDEF FPC} 421 | CoreComputeCritical.Acquire; 422 | Dec(x, v); 423 | CoreComputeCritical.Release; 424 | {$ELSE FPC} 425 | System.AtomicDecrement(x, v); 426 | {$ENDIF FPC} 427 | end; 428 | 429 | procedure AtomInc(var x: UInt64); 430 | begin 431 | {$IFDEF FPC} 432 | CoreComputeCritical.Acquire; 433 | Inc(x); 434 | CoreComputeCritical.Release; 435 | {$ELSE FPC} 436 | System.AtomicIncrement(x); 437 | {$ENDIF FPC} 438 | end; 439 | 440 | procedure AtomInc(var x: UInt64; const v: UInt64); 441 | begin 442 | {$IFDEF FPC} 443 | CoreComputeCritical.Acquire; 444 | Inc(x, v); 445 | CoreComputeCritical.Release; 446 | {$ELSE FPC} 447 | System.AtomicIncrement(x, v); 448 | {$ENDIF FPC} 449 | end; 450 | 451 | procedure AtomDec(var x: UInt64); 452 | begin 453 | {$IFDEF FPC} 454 | CoreComputeCritical.Acquire; 455 | Dec(x); 456 | CoreComputeCritical.Release; 457 | {$ELSE FPC} 458 | System.AtomicDecrement(x); 459 | {$ENDIF FPC} 460 | end; 461 | 462 | procedure AtomDec(var x: UInt64; const v: UInt64); 463 | begin 464 | {$IFDEF FPC} 465 | CoreComputeCritical.Acquire; 466 | Dec(x, v); 467 | CoreComputeCritical.Release; 468 | {$ELSE FPC} 469 | System.AtomicDecrement(x, v); 470 | {$ENDIF FPC} 471 | end; 472 | 473 | procedure AtomInc(var x: Integer); 474 | begin 475 | {$IFDEF FPC} 476 | CoreComputeCritical.Acquire; 477 | Inc(x); 478 | CoreComputeCritical.Release; 479 | {$ELSE FPC} 480 | System.AtomicIncrement(x); 481 | {$ENDIF FPC} 482 | end; 483 | 484 | procedure AtomInc(var x: Integer; const v: Integer); 485 | begin 486 | {$IFDEF FPC} 487 | CoreComputeCritical.Acquire; 488 | Inc(x, v); 489 | CoreComputeCritical.Release; 490 | {$ELSE FPC} 491 | System.AtomicIncrement(x, v); 492 | {$ENDIF FPC} 493 | end; 494 | 495 | procedure AtomDec(var x: Integer); 496 | begin 497 | {$IFDEF FPC} 498 | CoreComputeCritical.Acquire; 499 | Dec(x); 500 | CoreComputeCritical.Release; 501 | {$ELSE FPC} 502 | System.AtomicDecrement(x); 503 | {$ENDIF FPC} 504 | end; 505 | 506 | procedure AtomDec(var x: Integer; const v: Integer); 507 | begin 508 | {$IFDEF FPC} 509 | CoreComputeCritical.Acquire; 510 | Dec(x, v); 511 | CoreComputeCritical.Release; 512 | {$ELSE FPC} 513 | System.AtomicDecrement(x, v); 514 | {$ENDIF FPC} 515 | end; 516 | 517 | procedure AtomInc(var x: Cardinal); 518 | begin 519 | {$IFDEF FPC} 520 | CoreComputeCritical.Acquire; 521 | Inc(x); 522 | CoreComputeCritical.Release; 523 | {$ELSE FPC} 524 | System.AtomicIncrement(x); 525 | {$ENDIF FPC} 526 | end; 527 | 528 | procedure AtomInc(var x: Cardinal; const v: Cardinal); 529 | begin 530 | {$IFDEF FPC} 531 | CoreComputeCritical.Acquire; 532 | Inc(x, v); 533 | CoreComputeCritical.Release; 534 | {$ELSE FPC} 535 | System.AtomicIncrement(x, v); 536 | {$ENDIF FPC} 537 | end; 538 | 539 | procedure AtomDec(var x: Cardinal); 540 | begin 541 | {$IFDEF FPC} 542 | CoreComputeCritical.Acquire; 543 | Dec(x); 544 | CoreComputeCritical.Release; 545 | {$ELSE FPC} 546 | System.AtomicDecrement(x); 547 | {$ENDIF FPC} 548 | end; 549 | 550 | procedure AtomDec(var x: Cardinal; const v: Cardinal); 551 | begin 552 | {$IFDEF FPC} 553 | CoreComputeCritical.Acquire; 554 | Dec(x, v); 555 | CoreComputeCritical.Release; 556 | {$ELSE FPC} 557 | System.AtomicDecrement(x, v); 558 | {$ENDIF FPC} 559 | end; 560 | -------------------------------------------------------------------------------- /Source/CoreEndian.inc: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { * https://zpascal.net * } 3 | { * https://github.com/PassByYou888/zAI * } 4 | { * https://github.com/PassByYou888/ZServer4D * } 5 | { * https://github.com/PassByYou888/PascalString * } 6 | { * https://github.com/PassByYou888/zRasterization * } 7 | { * https://github.com/PassByYou888/CoreCipher * } 8 | { * https://github.com/PassByYou888/zSound * } 9 | { * https://github.com/PassByYou888/zChinese * } 10 | { * https://github.com/PassByYou888/zExpression * } 11 | { * https://github.com/PassByYou888/zGameWare * } 12 | { * https://github.com/PassByYou888/zAnalysis * } 13 | { * https://github.com/PassByYou888/FFMPEG-Header * } 14 | { * https://github.com/PassByYou888/zTranslate * } 15 | { * https://github.com/PassByYou888/InfiniteIoT * } 16 | { * https://github.com/PassByYou888/FastMD5 * } 17 | { ****************************************************************************** } 18 | {$IFDEF OverflowCheck}{$Q-}{$ENDIF} 19 | {$IFDEF RangeCheck}{$R-}{$ENDIF} 20 | 21 | 22 | function ROL8(const Value: Byte; Shift: Byte): Byte; 23 | begin 24 | Shift := Shift and $07; 25 | Result := Byte((Value shl Shift) or (Value shr (8 - Shift))); 26 | end; 27 | 28 | function ROL16(const Value: Word; Shift: Byte): Word; 29 | begin 30 | Shift := Shift and $0F; 31 | Result := Word((Value shl Shift) or (Value shr (16 - Shift))); 32 | end; 33 | 34 | function ROL32(const Value: Cardinal; Shift: Byte): Cardinal; 35 | begin 36 | Shift := Shift and $1F; 37 | Result := Cardinal((Value shl Shift) or (Value shr (32 - Shift))); 38 | end; 39 | 40 | function ROL64(const Value: UInt64; Shift: Byte): UInt64; 41 | begin 42 | Shift := Shift and $3F; 43 | Result := UInt64((Value shl Shift) or (Value shr (64 - Shift))); 44 | end; 45 | 46 | function ROR8(const Value: Byte; Shift: Byte): Byte; 47 | begin 48 | Shift := Shift and $07; 49 | Result := UInt8((Value shr Shift) or (Value shl (8 - Shift))); 50 | end; 51 | 52 | function ROR16(const Value: Word; Shift: Byte): Word; 53 | begin 54 | Shift := Shift and $0F; 55 | Result := Word((Value shr Shift) or (Value shl (16 - Shift))); 56 | end; 57 | 58 | function ROR32(const Value: Cardinal; Shift: Byte): Cardinal; 59 | begin 60 | Shift := Shift and $1F; 61 | Result := Cardinal((Value shr Shift) or (Value shl (32 - Shift))); 62 | end; 63 | 64 | function ROR64(const Value: UInt64; Shift: Byte): UInt64; 65 | begin 66 | Shift := Shift and $3F; 67 | Result := UInt64((Value shr Shift) or (Value shl (64 - Shift))); 68 | end; 69 | 70 | function Endian(const AValue: SmallInt): SmallInt; 71 | begin 72 | { the extra Word type cast is necessary because the "AValue shr 8" } 73 | { is turned into "Integer(AValue) shr 8", so if AValue < 0 then } 74 | { the sign bits from the upper 16 bits are shifted in rather than } 75 | { zeroes. } 76 | Result := SmallInt((Word(AValue) shr 8) or (Word(AValue) shl 8)); 77 | end; 78 | 79 | function Endian(const AValue: Word): Word; 80 | begin 81 | Result := Word((AValue shr 8) or (AValue shl 8)); 82 | end; 83 | 84 | function Endian(const AValue: Integer): Integer; 85 | begin 86 | Result := ((Cardinal(AValue) shl 8) and $FF00FF00) or ((Cardinal(AValue) shr 8) and $00FF00FF); 87 | Result := (Cardinal(Result) shl 16) or (Cardinal(Result) shr 16); 88 | end; 89 | 90 | function Endian(const AValue: Cardinal): Cardinal; 91 | begin 92 | Result := ((AValue shl 8) and $FF00FF00) or ((AValue shr 8) and $00FF00FF); 93 | Result := (Result shl 16) or (Result shr 16); 94 | end; 95 | 96 | function Endian(const AValue: Int64): Int64; 97 | begin 98 | Result := ((UInt64(AValue) shl 8) and $FF00FF00FF00FF00) or ((UInt64(AValue) shr 8) and $00FF00FF00FF00FF); 99 | Result := ((UInt64(Result) shl 16) and $FFFF0000FFFF0000) or ((UInt64(Result) shr 16) and $0000FFFF0000FFFF); 100 | Result := (UInt64(Result) shl 32) or ((UInt64(Result) shr 32)); 101 | end; 102 | 103 | function Endian(const AValue: UInt64): UInt64; 104 | begin 105 | Result := ((AValue shl 8) and $FF00FF00FF00FF00) or ((AValue shr 8) and $00FF00FF00FF00FF); 106 | Result := ((Result shl 16) and $FFFF0000FFFF0000) or ((Result shr 16) and $0000FFFF0000FFFF); 107 | Result := (Result shl 32) or ((Result shr 32)); 108 | end; 109 | 110 | function BE2N(const AValue: SmallInt): SmallInt; 111 | begin 112 | {$IFDEF BIG_ENDIAN} 113 | Result := AValue; 114 | {$ELSE} 115 | Result := Endian(AValue); 116 | {$ENDIF} 117 | end; 118 | 119 | function BE2N(const AValue: Word): Word; 120 | begin 121 | {$IFDEF BIG_ENDIAN} 122 | Result := AValue; 123 | {$ELSE} 124 | Result := Endian(AValue); 125 | {$ENDIF} 126 | end; 127 | 128 | function BE2N(const AValue: Integer): Integer; 129 | begin 130 | {$IFDEF BIG_ENDIAN} 131 | Result := AValue; 132 | {$ELSE} 133 | Result := Endian(AValue); 134 | {$ENDIF} 135 | end; 136 | 137 | function BE2N(const AValue: Cardinal): Cardinal; 138 | begin 139 | {$IFDEF BIG_ENDIAN} 140 | Result := AValue; 141 | {$ELSE} 142 | Result := Endian(AValue); 143 | {$ENDIF} 144 | end; 145 | 146 | function BE2N(const AValue: Int64): Int64; 147 | begin 148 | {$IFDEF BIG_ENDIAN} 149 | Result := AValue; 150 | {$ELSE} 151 | Result := Endian(AValue); 152 | {$ENDIF} 153 | end; 154 | 155 | function BE2N(const AValue: UInt64): UInt64; 156 | begin 157 | {$IFDEF BIG_ENDIAN} 158 | Result := AValue; 159 | {$ELSE} 160 | Result := Endian(AValue); 161 | {$ENDIF} 162 | end; 163 | 164 | function LE2N(const AValue: SmallInt): SmallInt; 165 | begin 166 | {$IFDEF LITTLE_ENDIAN} 167 | Result := AValue; 168 | {$ELSE} 169 | Result := Endian(AValue); 170 | {$ENDIF} 171 | end; 172 | 173 | function LE2N(const AValue: Word): Word; 174 | begin 175 | {$IFDEF LITTLE_ENDIAN} 176 | Result := AValue; 177 | {$ELSE} 178 | Result := Endian(AValue); 179 | {$ENDIF} 180 | end; 181 | 182 | function LE2N(const AValue: Integer): Integer; 183 | begin 184 | {$IFDEF LITTLE_ENDIAN} 185 | Result := AValue; 186 | {$ELSE} 187 | Result := Endian(AValue); 188 | {$ENDIF} 189 | end; 190 | 191 | function LE2N(const AValue: Cardinal): Cardinal; 192 | begin 193 | {$IFDEF LITTLE_ENDIAN} 194 | Result := AValue; 195 | {$ELSE} 196 | Result := Endian(AValue); 197 | {$ENDIF} 198 | end; 199 | 200 | function LE2N(const AValue: Int64): Int64; 201 | begin 202 | {$IFDEF LITTLE_ENDIAN} 203 | Result := AValue; 204 | {$ELSE} 205 | Result := Endian(AValue); 206 | {$ENDIF} 207 | end; 208 | 209 | function LE2N(const AValue: UInt64): UInt64; 210 | begin 211 | {$IFDEF LITTLE_ENDIAN} 212 | Result := AValue; 213 | {$ELSE} 214 | Result := Endian(AValue); 215 | {$ENDIF} 216 | end; 217 | 218 | function N2BE(const AValue: SmallInt): SmallInt; 219 | begin 220 | {$IFDEF BIG_ENDIAN} 221 | Result := AValue; 222 | {$ELSE} 223 | Result := Endian(AValue); 224 | {$ENDIF} 225 | end; 226 | 227 | function N2BE(const AValue: Word): Word; 228 | begin 229 | {$IFDEF BIG_ENDIAN} 230 | Result := AValue; 231 | {$ELSE} 232 | Result := Endian(AValue); 233 | {$ENDIF} 234 | end; 235 | 236 | function N2BE(const AValue: Integer): Integer; 237 | begin 238 | {$IFDEF BIG_ENDIAN} 239 | Result := AValue; 240 | {$ELSE} 241 | Result := Endian(AValue); 242 | {$ENDIF} 243 | end; 244 | 245 | function N2BE(const AValue: Cardinal): Cardinal; 246 | begin 247 | {$IFDEF BIG_ENDIAN} 248 | Result := AValue; 249 | {$ELSE} 250 | Result := Endian(AValue); 251 | {$ENDIF} 252 | end; 253 | 254 | function N2BE(const AValue: Int64): Int64; 255 | begin 256 | {$IFDEF BIG_ENDIAN} 257 | Result := AValue; 258 | {$ELSE} 259 | Result := Endian(AValue); 260 | {$ENDIF} 261 | end; 262 | 263 | function N2BE(const AValue: UInt64): UInt64; 264 | begin 265 | {$IFDEF BIG_ENDIAN} 266 | Result := AValue; 267 | {$ELSE} 268 | Result := Endian(AValue); 269 | {$ENDIF} 270 | end; 271 | 272 | function N2LE(const AValue: SmallInt): SmallInt; 273 | begin 274 | {$IFDEF LITTLE_ENDIAN} 275 | Result := AValue; 276 | {$ELSE} 277 | Result := Endian(AValue); 278 | {$ENDIF} 279 | end; 280 | 281 | function N2LE(const AValue: Word): Word; 282 | begin 283 | {$IFDEF LITTLE_ENDIAN} 284 | Result := AValue; 285 | {$ELSE} 286 | Result := Endian(AValue); 287 | {$ENDIF} 288 | end; 289 | 290 | function N2LE(const AValue: Integer): Integer; 291 | begin 292 | {$IFDEF LITTLE_ENDIAN} 293 | Result := AValue; 294 | {$ELSE} 295 | Result := Endian(AValue); 296 | {$ENDIF} 297 | end; 298 | 299 | function N2LE(const AValue: Cardinal): Cardinal; 300 | begin 301 | {$IFDEF LITTLE_ENDIAN} 302 | Result := AValue; 303 | {$ELSE} 304 | Result := Endian(AValue); 305 | {$ENDIF} 306 | end; 307 | 308 | function N2LE(const AValue: Int64): Int64; 309 | begin 310 | {$IFDEF LITTLE_ENDIAN} 311 | Result := AValue; 312 | {$ELSE} 313 | Result := Endian(AValue); 314 | {$ENDIF} 315 | end; 316 | 317 | function N2LE(const AValue: UInt64): UInt64; 318 | begin 319 | {$IFDEF LITTLE_ENDIAN} 320 | Result := AValue; 321 | {$ELSE} 322 | Result := Endian(AValue); 323 | {$ENDIF} 324 | end; 325 | 326 | procedure Swap(var v1, v2: Byte); 327 | var 328 | v: Byte; 329 | begin 330 | v := v1; 331 | v1 := v2; 332 | v2 := v; 333 | end; 334 | 335 | procedure Swap(var v1, v2: Word); 336 | var 337 | v: Word; 338 | begin 339 | v := v1; 340 | v1 := v2; 341 | v2 := v; 342 | end; 343 | 344 | procedure Swap(var v1, v2: Integer); 345 | var 346 | v: Integer; 347 | begin 348 | v := v1; 349 | v1 := v2; 350 | v2 := v; 351 | end; 352 | 353 | procedure Swap(var v1, v2: Cardinal); 354 | var 355 | v: Cardinal; 356 | begin 357 | v := v1; 358 | v1 := v2; 359 | v2 := v; 360 | end; 361 | 362 | procedure Swap(var v1, v2: Int64); 363 | var 364 | v: Int64; 365 | begin 366 | v := v1; 367 | v1 := v2; 368 | v2 := v; 369 | end; 370 | 371 | procedure Swap(var v1, v2: UInt64); 372 | var 373 | v: UInt64; 374 | begin 375 | v := v1; 376 | v1 := v2; 377 | v2 := v; 378 | end; 379 | 380 | {$IFDEF OVERLOAD_NATIVEINT} 381 | 382 | 383 | procedure Swap(var v1, v2: NativeInt); 384 | var 385 | v: NativeInt; 386 | begin 387 | v := v1; 388 | v1 := v2; 389 | v2 := v; 390 | end; 391 | 392 | procedure Swap(var v1, v2: NativeUInt); 393 | var 394 | v: NativeUInt; 395 | begin 396 | v := v1; 397 | v1 := v2; 398 | v2 := v; 399 | end; 400 | {$ENDIF OVERLOAD_NATIVEINT} 401 | 402 | 403 | procedure Swap(var v1, v2: string); 404 | var 405 | v: string; 406 | begin 407 | v := v1; 408 | v1 := v2; 409 | v2 := v; 410 | end; 411 | 412 | procedure Swap(var v1, v2: Single); 413 | var 414 | v: Single; 415 | begin 416 | v := v1; 417 | v1 := v2; 418 | v2 := v; 419 | end; 420 | 421 | procedure Swap(var v1, v2: Double); 422 | var 423 | v: Double; 424 | begin 425 | v := v1; 426 | v1 := v2; 427 | v2 := v; 428 | end; 429 | 430 | procedure Swap(var v1, v2: Pointer); 431 | var 432 | v: Pointer; 433 | begin 434 | v := v1; 435 | v1 := v2; 436 | v2 := v; 437 | end; 438 | 439 | procedure SwapVariant(var v1, v2: Variant); 440 | var 441 | v: Variant; 442 | begin 443 | v := v1; 444 | v1 := v2; 445 | v2 := v; 446 | end; 447 | 448 | function Swap(const v: Word): Word; 449 | begin 450 | Result := Endian(v); 451 | end; 452 | 453 | function Swap(const v: Cardinal): Cardinal; 454 | begin 455 | Result := Endian(v); 456 | end; 457 | 458 | function Swap(const v: UInt64): UInt64; 459 | begin 460 | Result := Endian(v); 461 | end; 462 | 463 | function SAR16(const AValue: SmallInt; const Shift: Byte): SmallInt; 464 | begin 465 | Result := SmallInt( 466 | Word(Word(Word(AValue) shr (Shift and 15)) or 467 | (Word(SmallInt(Word(0 - Word(Word(AValue) shr 15)) and Word(SmallInt(0 - (Ord((Shift and 15) <> 0) { and 1 } ))))) shl (16 - (Shift and 15))))); 468 | end; 469 | 470 | function SAR32(const AValue: Integer; Shift: Byte): Integer; 471 | begin 472 | Result := Integer( 473 | Cardinal(Cardinal(Cardinal(AValue) shr (Shift and 31)) or 474 | (Cardinal(Integer(Cardinal(0 - Cardinal(Cardinal(AValue) shr 31)) and Cardinal(Integer(0 - (Ord((Shift and 31) <> 0) { and 1 } ))))) shl (32 - (Shift and 31))))); 475 | end; 476 | 477 | function SAR64(const AValue: Int64; Shift: Byte): Int64; 478 | begin 479 | Result := Int64( 480 | UInt64(UInt64(UInt64(AValue) shr (Shift and 63)) or 481 | (UInt64(Int64(UInt64(0 - UInt64(UInt64(AValue) shr 63)) and UInt64(Int64(0 - (Ord((Shift and 63) <> 0) { and 1 } ))))) shl (64 - (Shift and 63))))); 482 | end; 483 | 484 | function MemoryAlign(addr: Pointer; alignment_: NativeUInt): Pointer; 485 | var 486 | tmp: NativeUInt; 487 | begin 488 | tmp := NativeUInt(addr) + (alignment_ - 1); 489 | Result := Pointer(tmp - (tmp mod alignment_)); 490 | end; 491 | 492 | {$IFDEF OverflowCheck}{$Q+}{$ENDIF} 493 | {$IFDEF RangeCheck}{$R+}{$ENDIF} 494 | 495 | 496 | function if_(const bool_: Boolean; const True_, False_: Boolean): Boolean; 497 | begin 498 | if bool_ then 499 | Result := True_ 500 | else 501 | Result := False_; 502 | end; 503 | 504 | function if_(const bool_: Boolean; const True_, False_: ShortInt): ShortInt; 505 | begin 506 | if bool_ then 507 | Result := True_ 508 | else 509 | Result := False_; 510 | end; 511 | 512 | function if_(const bool_: Boolean; const True_, False_: SmallInt): SmallInt; 513 | begin 514 | if bool_ then 515 | Result := True_ 516 | else 517 | Result := False_; 518 | end; 519 | 520 | function if_(const bool_: Boolean; const True_, False_: Integer): Integer; 521 | begin 522 | if bool_ then 523 | Result := True_ 524 | else 525 | Result := False_; 526 | end; 527 | 528 | function if_(const bool_: Boolean; const True_, False_: Int64): Int64; 529 | begin 530 | if bool_ then 531 | Result := True_ 532 | else 533 | Result := False_; 534 | end; 535 | 536 | function if_(const bool_: Boolean; const True_, False_: Byte): Byte; 537 | begin 538 | if bool_ then 539 | Result := True_ 540 | else 541 | Result := False_; 542 | end; 543 | 544 | function if_(const bool_: Boolean; const True_, False_: Word): Word; 545 | begin 546 | if bool_ then 547 | Result := True_ 548 | else 549 | Result := False_; 550 | end; 551 | 552 | function if_(const bool_: Boolean; const True_, False_: Cardinal): Cardinal; 553 | begin 554 | if bool_ then 555 | Result := True_ 556 | else 557 | Result := False_; 558 | end; 559 | 560 | function if_(const bool_: Boolean; const True_, False_: UInt64): UInt64; 561 | begin 562 | if bool_ then 563 | Result := True_ 564 | else 565 | Result := False_; 566 | end; 567 | 568 | function if_(const bool_: Boolean; const True_, False_: Single): Single; 569 | begin 570 | if bool_ then 571 | Result := True_ 572 | else 573 | Result := False_; 574 | end; 575 | 576 | function if_(const bool_: Boolean; const True_, False_: Double): Double; 577 | begin 578 | if bool_ then 579 | Result := True_ 580 | else 581 | Result := False_; 582 | end; 583 | 584 | function if_(const bool_: Boolean; const True_, False_: string): string; 585 | begin 586 | if bool_ then 587 | Result := True_ 588 | else 589 | Result := False_; 590 | end; 591 | 592 | function ifv_(const bool_: Boolean; const True_, False_: Variant): Variant; 593 | begin 594 | if bool_ then 595 | Result := True_ 596 | else 597 | Result := False_; 598 | end; 599 | 600 | function GetOffset(p_: Pointer; offset_: NativeInt): Pointer; 601 | begin 602 | Result := Pointer(NativeUInt(p_) + offset_); 603 | end; 604 | 605 | function GetPtr(p_: Pointer; offset_: NativeInt): Pointer; 606 | begin 607 | Result := Pointer(NativeUInt(p_) + offset_); 608 | end; 609 | -------------------------------------------------------------------------------- /Source/CoreThreadPost.inc: -------------------------------------------------------------------------------- 1 | procedure TThreadPostData.Init; 2 | begin 3 | OnCall1 := nil; 4 | OnCall2 := nil; 5 | OnCall3 := nil; 6 | OnCall4 := nil; 7 | OnMethod1 := nil; 8 | OnMethod2 := nil; 9 | OnMethod3 := nil; 10 | OnMethod4 := nil; 11 | OnProc1 := nil; 12 | OnProc2 := nil; 13 | OnProc3 := nil; 14 | OnProc4 := nil; 15 | Data1 := nil; 16 | Data2 := nil; 17 | Data3 := NULL; 18 | end; 19 | 20 | procedure TThreadPost.FreeThreadProgressPostData(p: TThreadPostDataOrder.PT_); 21 | begin 22 | Dispose(p); 23 | end; 24 | 25 | constructor TThreadPost.Create(ThreadID_: TThreadID); 26 | begin 27 | inherited Create; 28 | FCritical := TCritical.Create; 29 | FThreadID := ThreadID_; 30 | FSyncPool := TThreadPostDataOrder.Create; 31 | FSyncPool.OnFreeOrderStruct := {$IFDEF FPC}@{$ENDIF FPC}FreeThreadProgressPostData; 32 | FProgressing := TAtomBool.Create(False); 33 | FOneStep := True; 34 | FResetRandomSeed := False; 35 | end; 36 | 37 | destructor TThreadPost.Destroy; 38 | begin 39 | FCritical.Acquire; 40 | FSyncPool.Clear; 41 | FSyncPool.Clear; 42 | FCritical.Release; 43 | DisposeObject(FSyncPool); 44 | FCritical.Free; 45 | FProgressing.Free; 46 | inherited Destroy; 47 | end; 48 | 49 | function TThreadPost.Count: Integer; 50 | begin 51 | FCritical.Acquire; 52 | Result := FSyncPool.Num; 53 | FCritical.Release; 54 | end; 55 | 56 | function TThreadPost.Busy: Boolean; 57 | begin 58 | Result := (Count > 0) or (FProgressing.V); 59 | end; 60 | 61 | function TThreadPost.Progress(ThreadID_: TThreadID): Integer; 62 | var 63 | i: Integer; 64 | temp: TThreadPostDataOrder; 65 | t_: TThreadPostData; 66 | begin 67 | Result := 0; 68 | if ThreadID_ <> FThreadID then 69 | exit; 70 | 71 | if FOneStep then 72 | begin 73 | if FSyncPool.Current <> nil then 74 | begin 75 | FProgressing.V := True; 76 | FCritical.Acquire; 77 | t_ := FSyncPool.Current^.Data^; 78 | FSyncPool.Next; 79 | FCritical.Release; 80 | 81 | if FResetRandomSeed then 82 | SetMT19937Seed(0); 83 | try 84 | if Assigned(t_.OnCall1) then 85 | t_.OnCall1(); 86 | if Assigned(t_.OnCall2) then 87 | t_.OnCall2(t_.Data1); 88 | if Assigned(t_.OnCall3) then 89 | t_.OnCall3(t_.Data1, t_.Data2, t_.Data3); 90 | if Assigned(t_.OnCall4) then 91 | t_.OnCall4(t_.Data1, t_.Data2); 92 | 93 | if Assigned(t_.OnMethod1) then 94 | t_.OnMethod1(); 95 | if Assigned(t_.OnMethod2) then 96 | t_.OnMethod2(t_.Data1); 97 | if Assigned(t_.OnMethod3) then 98 | t_.OnMethod3(t_.Data1, t_.Data2, t_.Data3); 99 | if Assigned(t_.OnMethod4) then 100 | t_.OnMethod4(t_.Data1, t_.Data2); 101 | 102 | if Assigned(t_.OnProc1) then 103 | t_.OnProc1(); 104 | if Assigned(t_.OnProc2) then 105 | t_.OnProc2(t_.Data1); 106 | if Assigned(t_.OnProc3) then 107 | t_.OnProc3(t_.Data1, t_.Data2, t_.Data3); 108 | if Assigned(t_.OnProc4) then 109 | t_.OnProc4(t_.Data1, t_.Data2); 110 | except 111 | end; 112 | 113 | FProgressing.V := False; 114 | Result := 1; 115 | end; 116 | end 117 | else 118 | while (not FProgressing.V) and (Count > 0) do 119 | begin 120 | FProgressing.V := True; 121 | FCritical.Acquire; 122 | temp := FSyncPool; 123 | FSyncPool := TThreadPostDataOrder.Create; 124 | FCritical.Release; 125 | Result := temp.Num; 126 | while temp.Current <> nil do 127 | begin 128 | if FResetRandomSeed then 129 | SetMT19937Seed(0); 130 | try 131 | if Assigned(temp.Current^.Data^.OnCall1) then 132 | temp.Current^.Data^.OnCall1(); 133 | if Assigned(temp.Current^.Data^.OnCall2) then 134 | temp.Current^.Data^.OnCall2(temp.Current^.Data^.Data1); 135 | if Assigned(temp.Current^.Data^.OnCall3) then 136 | temp.Current^.Data^.OnCall3(temp.Current^.Data^.Data1, temp.Current^.Data^.Data2, temp.Current^.Data^.Data3); 137 | if Assigned(temp.Current^.Data^.OnCall4) then 138 | temp.Current^.Data^.OnCall4(temp.Current^.Data^.Data1, temp.Current^.Data^.Data2); 139 | 140 | if Assigned(temp.Current^.Data^.OnMethod1) then 141 | temp.Current^.Data^.OnMethod1(); 142 | if Assigned(temp.Current^.Data^.OnMethod2) then 143 | temp.Current^.Data^.OnMethod2(temp.Current^.Data^.Data1); 144 | if Assigned(temp.Current^.Data^.OnMethod3) then 145 | temp.Current^.Data^.OnMethod3(temp.Current^.Data^.Data1, temp.Current^.Data^.Data2, temp.Current^.Data^.Data3); 146 | if Assigned(temp.Current^.Data^.OnMethod4) then 147 | temp.Current^.Data^.OnMethod4(temp.Current^.Data^.Data1, temp.Current^.Data^.Data2); 148 | 149 | if Assigned(temp.Current^.Data^.OnProc1) then 150 | temp.Current^.Data^.OnProc1(); 151 | if Assigned(temp.Current^.Data^.OnProc2) then 152 | temp.Current^.Data^.OnProc2(temp.Current^.Data^.Data1); 153 | if Assigned(temp.Current^.Data^.OnProc3) then 154 | temp.Current^.Data^.OnProc3(temp.Current^.Data^.Data1, temp.Current^.Data^.Data2, temp.Current^.Data^.Data3); 155 | if Assigned(temp.Current^.Data^.OnProc4) then 156 | temp.Current^.Data^.OnProc4(temp.Current^.Data^.Data1, temp.Current^.Data^.Data2); 157 | except 158 | end; 159 | temp.Next; 160 | end; 161 | DisposeObject(temp); 162 | FProgressing.V := False; 163 | end; 164 | end; 165 | 166 | function TThreadPost.Progress(Thread_: TThread): Integer; 167 | begin 168 | Result := Progress(Thread_.ThreadID); 169 | end; 170 | 171 | function TThreadPost.Progress(): Integer; 172 | begin 173 | Result := Progress(TThread.CurrentThread); 174 | end; 175 | 176 | procedure TThreadPost.PostC1(OnSync: TThreadPostCall1); 177 | var 178 | t_: TThreadPostData; 179 | begin 180 | t_.Init(); 181 | t_.OnCall1 := OnSync; 182 | FCritical.Acquire; 183 | FSyncPool.Push(t_); 184 | FCritical.Release; 185 | end; 186 | 187 | procedure TThreadPost.PostC2(Data1: Pointer; OnSync: TThreadPostCall2); 188 | var 189 | t_: TThreadPostData; 190 | begin 191 | t_.Init(); 192 | t_.Data1 := Data1; 193 | t_.OnCall2 := OnSync; 194 | FCritical.Acquire; 195 | FSyncPool.Push(t_); 196 | FCritical.Release; 197 | end; 198 | 199 | procedure TThreadPost.PostC3(Data1: Pointer; Data2: TCoreClassObject; Data3: Variant; OnSync: TThreadPostCall3); 200 | var 201 | t_: TThreadPostData; 202 | begin 203 | t_.Init(); 204 | t_.Data1 := Data1; 205 | t_.Data2 := Data2; 206 | t_.Data3 := Data3; 207 | t_.OnCall3 := OnSync; 208 | FCritical.Acquire; 209 | FSyncPool.Push(t_); 210 | FCritical.Release; 211 | end; 212 | 213 | procedure TThreadPost.PostC4(Data1: Pointer; Data2: TCoreClassObject; OnSync: TThreadPostCall4); 214 | var 215 | t_: TThreadPostData; 216 | begin 217 | t_.Init(); 218 | t_.Data1 := Data1; 219 | t_.Data2 := Data2; 220 | t_.OnCall4 := OnSync; 221 | FCritical.Acquire; 222 | FSyncPool.Push(t_); 223 | FCritical.Release; 224 | end; 225 | 226 | procedure TThreadPost.PostM1(OnSync: TThreadPostMethod1); 227 | var 228 | t_: TThreadPostData; 229 | begin 230 | t_.Init(); 231 | t_.OnMethod1 := OnSync; 232 | FCritical.Acquire; 233 | FSyncPool.Push(t_); 234 | FCritical.Release; 235 | end; 236 | 237 | procedure TThreadPost.PostM2(Data1: Pointer; OnSync: TThreadPostMethod2); 238 | var 239 | t_: TThreadPostData; 240 | begin 241 | t_.Init(); 242 | t_.Data1 := Data1; 243 | t_.OnMethod2 := OnSync; 244 | FCritical.Acquire; 245 | FSyncPool.Push(t_); 246 | FCritical.Release; 247 | end; 248 | 249 | procedure TThreadPost.PostM3(Data1: Pointer; Data2: TCoreClassObject; Data3: Variant; OnSync: TThreadPostMethod3); 250 | var 251 | t_: TThreadPostData; 252 | begin 253 | t_.Init(); 254 | t_.Data1 := Data1; 255 | t_.Data2 := Data2; 256 | t_.Data3 := Data3; 257 | t_.OnMethod3 := OnSync; 258 | FCritical.Acquire; 259 | FSyncPool.Push(t_); 260 | FCritical.Release; 261 | end; 262 | 263 | procedure TThreadPost.PostM4(Data1: Pointer; Data2: TCoreClassObject; OnSync: TThreadPostMethod4); 264 | var 265 | t_: TThreadPostData; 266 | begin 267 | t_.Init(); 268 | t_.Data1 := Data1; 269 | t_.Data2 := Data2; 270 | t_.OnMethod4 := OnSync; 271 | FCritical.Acquire; 272 | FSyncPool.Push(t_); 273 | FCritical.Release; 274 | end; 275 | 276 | procedure TThreadPost.PostP1(OnSync: TThreadPostProc1); 277 | var 278 | t_: TThreadPostData; 279 | begin 280 | t_.Init(); 281 | t_.OnProc1 := OnSync; 282 | FCritical.Acquire; 283 | FSyncPool.Push(t_); 284 | FCritical.Release; 285 | end; 286 | 287 | procedure TThreadPost.PostP2(Data1: Pointer; OnSync: TThreadPostProc2); 288 | var 289 | t_: TThreadPostData; 290 | begin 291 | t_.Init(); 292 | t_.Data1 := Data1; 293 | t_.OnProc2 := OnSync; 294 | FCritical.Acquire; 295 | FSyncPool.Push(t_); 296 | FCritical.Release; 297 | end; 298 | 299 | procedure TThreadPost.PostP3(Data1: Pointer; Data2: TCoreClassObject; Data3: Variant; OnSync: TThreadPostProc3); 300 | var 301 | t_: TThreadPostData; 302 | begin 303 | t_.Init(); 304 | t_.Data1 := Data1; 305 | t_.Data2 := Data2; 306 | t_.Data3 := Data3; 307 | t_.OnProc3 := OnSync; 308 | FCritical.Acquire; 309 | FSyncPool.Push(t_); 310 | FCritical.Release; 311 | end; 312 | 313 | procedure TThreadPost.PostP4(Data1: Pointer; Data2: TCoreClassObject; OnSync: TThreadPostProc4); 314 | var 315 | t_: TThreadPostData; 316 | begin 317 | t_.Init(); 318 | t_.Data1 := Data1; 319 | t_.Data2 := Data2; 320 | t_.OnProc4 := OnSync; 321 | FCritical.Acquire; 322 | FSyncPool.Push(t_); 323 | FCritical.Release; 324 | end; 325 | -------------------------------------------------------------------------------- /Source/Core_AtomVar.inc: -------------------------------------------------------------------------------- 1 | function TAtomVar{$IFNDEF FPC}<T_>{$ENDIF FPC}.GetValue: T_; 2 | begin 3 | Critical.Acquire; 4 | Result := FValue__; 5 | Critical.Release; 6 | end; 7 | 8 | procedure TAtomVar{$IFNDEF FPC}<T_>{$ENDIF FPC}.SetValue(const Value_: T_); 9 | begin 10 | Critical.Acquire; 11 | FValue__ := Value_; 12 | Critical.Release; 13 | end; 14 | 15 | function TAtomVar{$IFNDEF FPC}<T_>{$ENDIF FPC}.GetValueP: PT_; 16 | begin 17 | Result := @FValue__; 18 | end; 19 | 20 | constructor TAtomVar{$IFNDEF FPC}<T_>{$ENDIF FPC}.Create(Value_: T_); 21 | begin 22 | inherited Create; 23 | FValue__ := Value_; 24 | Critical := TCritical_.Create; 25 | end; 26 | 27 | destructor TAtomVar{$IFNDEF FPC}<T_>{$ENDIF FPC}.Destroy; 28 | begin 29 | Critical.Free; 30 | inherited Destroy; 31 | end; 32 | 33 | function TAtomVar{$IFNDEF FPC}<T_>{$ENDIF FPC}.Lock: T_; 34 | begin 35 | Critical.Acquire; 36 | Result := FValue__; 37 | end; 38 | 39 | function TAtomVar{$IFNDEF FPC}<T_>{$ENDIF FPC}.LockP: PT_; 40 | begin 41 | Critical.Acquire; 42 | Result := @FValue__; 43 | end; 44 | 45 | procedure TAtomVar{$IFNDEF FPC}<T_>{$ENDIF FPC}.UnLock(const Value_: T_); 46 | begin 47 | FValue__ := Value_; 48 | Critical.Release; 49 | end; 50 | 51 | procedure TAtomVar{$IFNDEF FPC}<T_>{$ENDIF FPC}.UnLock(const Value_: PT_); 52 | begin 53 | FValue__ := Value_^; 54 | Critical.Release; 55 | end; 56 | 57 | procedure TAtomVar{$IFNDEF FPC}<T_>{$ENDIF FPC}.UnLock(); 58 | begin 59 | Critical.Release; 60 | end; 61 | -------------------------------------------------------------------------------- /Source/Core_DelphiParallelFor.inc: -------------------------------------------------------------------------------- 1 | {$IFDEF SystemParallel} 2 | 3 | 4 | procedure DelphiParallelFor(parallel: Boolean; b, e: Integer; OnFor: TDelphiParallelForProcedure32); 5 | var 6 | i: Integer; 7 | begin 8 | if b > e then 9 | exit; 10 | if (not parallel) or (not WorkInParallelCore.V) or ParallelOverflow.Busy() then 11 | begin 12 | i := b; 13 | while i <= e do 14 | begin 15 | try 16 | OnFor(i); 17 | except 18 | end; 19 | inc(i); 20 | end; 21 | exit; 22 | end; 23 | ParallelOverflow.Acquire; 24 | try 25 | TParallel.&For(b, e, OnFor); 26 | finally 27 | ParallelOverflow.Release; 28 | end; 29 | end; 30 | 31 | procedure DelphiParallelFor(parallel: Boolean; b, e: Int64; OnFor: TDelphiParallelForProcedure64); 32 | var 33 | i: Int64; 34 | begin 35 | if b > e then 36 | exit; 37 | if (not parallel) or (not WorkInParallelCore.V) or ParallelOverflow.Busy() then 38 | begin 39 | i := b; 40 | while i <= e do 41 | begin 42 | try 43 | OnFor(i); 44 | except 45 | end; 46 | inc(i); 47 | end; 48 | exit; 49 | end; 50 | ParallelOverflow.Acquire; 51 | try 52 | TParallel.&For(b, e, OnFor); 53 | finally 54 | ParallelOverflow.Release; 55 | end; 56 | end; 57 | {$ELSE SystemParallel} 58 | 59 | 60 | type 61 | TDelphiParallelThData32_Block = record 62 | b, e: Integer; 63 | Completed: ^Integer; 64 | OnFor: TDelphiParallelForProcedure32; 65 | Critical: TCritical; 66 | end; 67 | 68 | PDelphiParallelThData32_Block = ^TDelphiParallelThData32_Block; 69 | 70 | procedure DelphiParallelTh32_Block(ThSender: TCompute); 71 | var 72 | p: PDelphiParallelThData32_Block; 73 | Pass: Integer; 74 | begin 75 | p := ThSender.UserData; 76 | Pass := p^.b; 77 | while Pass <= p^.e do 78 | begin 79 | try 80 | p^.OnFor(Pass); 81 | except 82 | end; 83 | inc(Pass); 84 | end; 85 | 86 | p^.Critical.Acquire; 87 | AtomInc(p^.Completed^, p^.e - p^.b + 1); 88 | p^.Critical.Release; 89 | dispose(p); 90 | end; 91 | 92 | procedure DelphiParallelFor_Block(parallel: Boolean; b, e: Integer; OnFor: TDelphiParallelForProcedure32); 93 | var 94 | Total, Depth, Completed, StepTotal, stepW, Pass, w: Integer; 95 | p: PDelphiParallelThData32_Block; 96 | i: Integer; 97 | Critical: TCritical; 98 | begin 99 | if b > e then 100 | exit; 101 | if (not parallel) or (not WorkInParallelCore.V) or ParallelOverflow.Busy() then 102 | begin 103 | i := b; 104 | while i <= e do 105 | begin 106 | try 107 | OnFor(i); 108 | except 109 | end; 110 | inc(i); 111 | end; 112 | exit; 113 | end; 114 | ParallelOverflow.Acquire; 115 | try 116 | Depth := ParallelGranularity; 117 | Total := e - b + 1; 118 | Critical := TCritical.Create; 119 | 120 | Completed := 0; 121 | 122 | if (Total < Depth) then 123 | begin 124 | Pass := b; 125 | while Pass <= e do 126 | begin 127 | new(p); 128 | p^.b := Pass; 129 | p^.e := Pass; 130 | p^.Completed := @Completed; 131 | p^.OnFor := OnFor; 132 | p^.Critical := Critical; 133 | TCompute.RunC(p, nil, DelphiParallelTh32_Block); 134 | inc(Pass); 135 | end; 136 | end 137 | else 138 | begin 139 | stepW := Total div Depth; 140 | StepTotal := Total div stepW; 141 | if Total mod stepW > 0 then 142 | inc(StepTotal); 143 | 144 | Pass := 0; 145 | while Pass < StepTotal do 146 | begin 147 | w := stepW * Pass; 148 | new(p); 149 | if w + stepW <= Total then 150 | begin 151 | p^.b := w + b; 152 | p^.e := w + stepW + b - 1; 153 | end 154 | else 155 | begin 156 | p^.b := w + b; 157 | p^.e := Total + b - 1; 158 | end; 159 | p^.Completed := @Completed; 160 | p^.OnFor := OnFor; 161 | p^.Critical := Critical; 162 | TCompute.RunC(p, nil, DelphiParallelTh32_Block); 163 | inc(Pass); 164 | end; 165 | end; 166 | 167 | repeat 168 | TThread.Sleep(1); 169 | Critical.Acquire; 170 | w := Completed; 171 | Critical.Release; 172 | until w >= Total; 173 | 174 | Critical.Free; 175 | finally 176 | ParallelOverflow.Release; 177 | end; 178 | end; 179 | 180 | type 181 | TDelphiParallelThData64_Block = record 182 | b, e: Int64; 183 | Completed: ^Int64; 184 | OnFor: TDelphiParallelForProcedure64; 185 | Critical: TCritical; 186 | end; 187 | 188 | PDelphiParallelThData64_Block = ^TDelphiParallelThData64_Block; 189 | 190 | procedure DelphiParallelTh64_Block(ThSender: TCompute); 191 | var 192 | p: PDelphiParallelThData64_Block; 193 | Pass: Int64; 194 | begin 195 | p := ThSender.UserData; 196 | Pass := p^.b; 197 | while Pass <= p^.e do 198 | begin 199 | try 200 | p^.OnFor(Pass); 201 | except 202 | end; 203 | inc(Pass); 204 | end; 205 | 206 | p^.Critical.Acquire; 207 | AtomInc(p^.Completed^, p^.e - p^.b + 1); 208 | p^.Critical.Release; 209 | dispose(p); 210 | end; 211 | 212 | procedure DelphiParallelFor_Block(parallel: Boolean; b, e: Int64; OnFor: TDelphiParallelForProcedure64); 213 | var 214 | Total, Depth, Completed, StepTotal, stepW, Pass, w: Int64; 215 | p: PDelphiParallelThData64_Block; 216 | i: Int64; 217 | Critical: TCritical; 218 | begin 219 | if b > e then 220 | exit; 221 | if (not parallel) or (not WorkInParallelCore.V) or ParallelOverflow.Busy() then 222 | begin 223 | i := b; 224 | while i <= e do 225 | begin 226 | try 227 | OnFor(i); 228 | except 229 | end; 230 | inc(i); 231 | end; 232 | exit; 233 | end; 234 | ParallelOverflow.Acquire; 235 | try 236 | Depth := ParallelGranularity; 237 | Total := e - b + 1; 238 | Critical := TCritical.Create; 239 | 240 | Completed := 0; 241 | 242 | if (Total < Depth) then 243 | begin 244 | Pass := b; 245 | while Pass <= e do 246 | begin 247 | new(p); 248 | p^.b := Pass; 249 | p^.e := Pass; 250 | p^.Completed := @Completed; 251 | p^.OnFor := OnFor; 252 | p^.Critical := Critical; 253 | TCompute.RunC(p, nil, DelphiParallelTh64_Block); 254 | inc(Pass); 255 | end; 256 | end 257 | else 258 | begin 259 | stepW := Total div Depth; 260 | StepTotal := Total div stepW; 261 | if Total mod stepW > 0 then 262 | inc(StepTotal); 263 | 264 | Pass := 0; 265 | while Pass < StepTotal do 266 | begin 267 | w := stepW * Pass; 268 | new(p); 269 | if w + stepW <= Total then 270 | begin 271 | p^.b := w + b; 272 | p^.e := w + stepW + b - 1; 273 | end 274 | else 275 | begin 276 | p^.b := w + b; 277 | p^.e := Total + b - 1; 278 | end; 279 | p^.Completed := @Completed; 280 | p^.OnFor := OnFor; 281 | p^.Critical := Critical; 282 | TCompute.RunC(p, nil, DelphiParallelTh64_Block); 283 | inc(Pass); 284 | end; 285 | end; 286 | 287 | repeat 288 | TThread.Sleep(1); 289 | Critical.Acquire; 290 | w := Completed; 291 | Critical.Release; 292 | until w >= Total; 293 | 294 | Critical.Free; 295 | finally 296 | ParallelOverflow.Release; 297 | end; 298 | end; 299 | 300 | type 301 | TDelphiParallelThData32_Fold = record 302 | Pass: Int64; 303 | Total, Granularity: Integer; 304 | Completed: Boolean; 305 | OnFor: TDelphiParallelForProcedure32; 306 | Critical: TCritical; 307 | end; 308 | 309 | PDelphiParallelThData32_Fold = ^TDelphiParallelThData32_Fold; 310 | 311 | procedure DelphiParallelTh32_Fold(ThSender: TCompute); 312 | var 313 | p: PDelphiParallelThData32_Fold; 314 | begin 315 | p := ThSender.UserData; 316 | with p^ do 317 | while Pass <= Total do 318 | begin 319 | try 320 | OnFor(Pass); 321 | except 322 | end; 323 | inc(Pass, Granularity); 324 | end; 325 | 326 | p^.Critical.Acquire; 327 | p^.Completed := True; 328 | p^.Critical.Release; 329 | end; 330 | 331 | procedure DelphiParallelFor_Fold(parallel: Boolean; b, e: Integer; OnFor: TDelphiParallelForProcedure32); 332 | var 333 | p: PDelphiParallelThData32_Fold; 334 | i, Depth: Integer; 335 | Critical: TCritical; 336 | states: array of TDelphiParallelThData32_Fold; 337 | Completed: Boolean; 338 | begin 339 | if b > e then 340 | exit; 341 | if (not parallel) or (not WorkInParallelCore.V) or ParallelOverflow.Busy() then 342 | begin 343 | i := b; 344 | while i <= e do 345 | begin 346 | try 347 | OnFor(i); 348 | except 349 | end; 350 | inc(i); 351 | end; 352 | exit; 353 | end; 354 | ParallelOverflow.Acquire; 355 | try 356 | Critical := TCritical.Create; 357 | Depth := Min(ParallelGranularity, e - b + 1); 358 | SetLength(states, Depth); 359 | 360 | i := 0; 361 | while i < Depth do 362 | begin 363 | p := @states[i]; 364 | p^.Pass := b + i; 365 | p^.Total := e; 366 | p^.Granularity := ParallelGranularity; 367 | p^.Completed := False; 368 | p^.OnFor := OnFor; 369 | p^.Critical := Critical; 370 | TCompute.RunC(p, nil, DelphiParallelTh32_Fold); 371 | inc(i); 372 | end; 373 | 374 | repeat 375 | TThread.Sleep(1); 376 | Critical.Acquire; 377 | Completed := True; 378 | i := 0; 379 | while i < Length(states) do 380 | begin 381 | Completed := Completed and states[i].Completed; 382 | inc(i); 383 | end; 384 | Critical.Release; 385 | until Completed; 386 | 387 | Critical.Free; 388 | finally 389 | ParallelOverflow.Release; 390 | end; 391 | end; 392 | 393 | type 394 | TDelphiParallelThData64_Fold = record 395 | Pass: Int64; 396 | Total, Granularity: Int64; 397 | Completed: Boolean; 398 | OnFor: TDelphiParallelForProcedure64; 399 | Critical: TCritical; 400 | end; 401 | 402 | PDelphiParallelThData64_Fold = ^TDelphiParallelThData64_Fold; 403 | 404 | procedure DelphiParallelTh64_Fold(ThSender: TCompute); 405 | var 406 | p: PDelphiParallelThData64_Fold; 407 | begin 408 | p := ThSender.UserData; 409 | with p^ do 410 | while Pass <= Total do 411 | begin 412 | try 413 | OnFor(Pass); 414 | except 415 | end; 416 | inc(Pass, Granularity); 417 | end; 418 | 419 | p^.Critical.Acquire; 420 | p^.Completed := True; 421 | p^.Critical.Release; 422 | end; 423 | 424 | procedure DelphiParallelFor_Fold(parallel: Boolean; b, e: Int64; OnFor: TDelphiParallelForProcedure64); 425 | var 426 | p: PDelphiParallelThData64_Fold; 427 | i, Depth: Int64; 428 | Critical: TCritical; 429 | states: array of TDelphiParallelThData64_Fold; 430 | Completed: Boolean; 431 | begin 432 | if b > e then 433 | exit; 434 | if (not parallel) or (not WorkInParallelCore.V) or ParallelOverflow.Busy() then 435 | begin 436 | i := b; 437 | while i <= e do 438 | begin 439 | try 440 | OnFor(i); 441 | except 442 | end; 443 | inc(i); 444 | end; 445 | exit; 446 | end; 447 | ParallelOverflow.Acquire; 448 | try 449 | Critical := TCritical.Create; 450 | Depth := Min(ParallelGranularity, e - b + 1); 451 | SetLength(states, Depth); 452 | 453 | i := 0; 454 | while i < Depth do 455 | begin 456 | p := @states[i]; 457 | p^.Pass := b + i; 458 | p^.Total := e; 459 | p^.Granularity := ParallelGranularity; 460 | p^.Completed := False; 461 | p^.OnFor := OnFor; 462 | p^.Critical := Critical; 463 | TCompute.RunC(p, nil, DelphiParallelTh64_Fold); 464 | inc(i); 465 | end; 466 | 467 | repeat 468 | TThread.Sleep(1); 469 | Critical.Acquire; 470 | Completed := True; 471 | i := 0; 472 | while i < Length(states) do 473 | begin 474 | Completed := Completed and states[i].Completed; 475 | inc(i); 476 | end; 477 | Critical.Release; 478 | until Completed; 479 | 480 | Critical.Free; 481 | finally 482 | ParallelOverflow.Release; 483 | end; 484 | end; 485 | 486 | procedure DelphiParallelFor(parallel: Boolean; b, e: Integer; OnFor: TDelphiParallelForProcedure32); 487 | begin 488 | {$IFDEF FoldParallel} 489 | DelphiParallelFor_Fold(parallel, b, e, OnFor); 490 | {$ELSE FoldParallel} 491 | DelphiParallelFor_Block(parallel, b, e, OnFor); 492 | {$ENDIF FoldParallel} 493 | end; 494 | 495 | procedure DelphiParallelFor(parallel: Boolean; b, e: Int64; OnFor: TDelphiParallelForProcedure64); 496 | begin 497 | {$IFDEF FoldParallel} 498 | DelphiParallelFor_Fold(parallel, b, e, OnFor); 499 | {$ELSE FoldParallel} 500 | DelphiParallelFor_Block(parallel, b, e, OnFor); 501 | {$ENDIF FoldParallel} 502 | end; 503 | 504 | {$ENDIF SystemParallel} 505 | 506 | 507 | procedure DelphiParallelFor(b, e: Integer; OnFor: TDelphiParallelForProcedure32); 508 | begin 509 | DelphiParallelFor(True, b, e, OnFor); 510 | end; 511 | 512 | procedure DelphiParallelFor(b, e: Int64; OnFor: TDelphiParallelForProcedure64); 513 | begin 514 | DelphiParallelFor(True, b, e, OnFor); 515 | end; 516 | 517 | procedure DelphiParallelFor(OnFor: TDelphiParallelForProcedure32; b, e: Integer); 518 | begin 519 | DelphiParallelFor(b, e, OnFor); 520 | end; 521 | 522 | procedure DelphiParallelFor(OnFor: TDelphiParallelForProcedure64; b, e: Int64); 523 | begin 524 | DelphiParallelFor(b, e, OnFor); 525 | end; 526 | 527 | procedure DelphiParallelFor(parallel: Boolean; OnFor: TDelphiParallelForProcedure32; b, e: Integer); 528 | begin 529 | DelphiParallelFor(parallel, b, e, OnFor); 530 | end; 531 | 532 | procedure DelphiParallelFor(parallel: Boolean; OnFor: TDelphiParallelForProcedure64; b, e: Int64); 533 | begin 534 | DelphiParallelFor(parallel, b, e, OnFor); 535 | end; 536 | 537 | procedure ParallelFor(parallel: Boolean; b, e: Integer; OnFor: TDelphiParallelForProcedure32); 538 | begin 539 | DelphiParallelFor(parallel, b, e, OnFor); 540 | end; 541 | 542 | procedure ParallelFor(parallel: Boolean; b, e: Int64; OnFor: TDelphiParallelForProcedure64); 543 | begin 544 | DelphiParallelFor(parallel, b, e, OnFor); 545 | end; 546 | 547 | procedure ParallelFor(b, e: Integer; OnFor: TDelphiParallelForProcedure32); 548 | begin 549 | DelphiParallelFor(True, b, e, OnFor); 550 | end; 551 | 552 | procedure ParallelFor(b, e: Int64; OnFor: TDelphiParallelForProcedure64); 553 | begin 554 | DelphiParallelFor(True, b, e, OnFor); 555 | end; 556 | 557 | procedure ParallelFor(OnFor: TDelphiParallelForProcedure32; b, e: Integer); 558 | begin 559 | DelphiParallelFor(b, e, OnFor); 560 | end; 561 | 562 | procedure ParallelFor(OnFor: TDelphiParallelForProcedure64; b, e: Int64); 563 | begin 564 | DelphiParallelFor(b, e, OnFor); 565 | end; 566 | 567 | procedure ParallelFor(parallel: Boolean; OnFor: TDelphiParallelForProcedure32; b, e: Integer); 568 | begin 569 | DelphiParallelFor(parallel, b, e, OnFor); 570 | end; 571 | 572 | procedure ParallelFor(parallel: Boolean; OnFor: TDelphiParallelForProcedure64; b, e: Int64); 573 | begin 574 | DelphiParallelFor(parallel, b, e, OnFor); 575 | end; 576 | -------------------------------------------------------------------------------- /Source/Core_FPCParallelFor.inc: -------------------------------------------------------------------------------- 1 | type 2 | TFPCParallelThData32_Block = record 3 | b, e: Integer; 4 | Completed: ^Integer; 5 | OnFor: TFPCParallelForProcedure32; 6 | Critical: TCritical; 7 | end; 8 | 9 | PFPCParallelThData32_Block = ^TFPCParallelThData32_Block; 10 | 11 | procedure FPCParallelTh32_Block(ThSender: TCompute); 12 | var 13 | p: PFPCParallelThData32_Block; 14 | Pass: Integer; 15 | begin 16 | p := ThSender.UserData; 17 | Pass := p^.b; 18 | while Pass <= p^.e do 19 | begin 20 | try 21 | p^.OnFor(Pass); 22 | except 23 | end; 24 | inc(Pass); 25 | end; 26 | 27 | p^.Critical.Acquire; 28 | AtomInc(p^.Completed^, p^.e - p^.b + 1); 29 | p^.Critical.Release; 30 | dispose(p); 31 | end; 32 | 33 | procedure FPCParallelFor_Block(parallel: Boolean; b, e: Integer; OnFor: TFPCParallelForProcedure32); 34 | var 35 | Total, Depth, Completed, StepTotal, stepW, Pass, w: Integer; 36 | p: PFPCParallelThData32_Block; 37 | i: Integer; 38 | Critical: TCritical; 39 | begin 40 | if b > e then 41 | exit; 42 | if (not parallel) or (not WorkInParallelCore.V) or ParallelOverflow.Busy() then 43 | begin 44 | i := b; 45 | while i <= e do 46 | begin 47 | try 48 | OnFor(i); 49 | except 50 | end; 51 | inc(i); 52 | end; 53 | exit; 54 | end; 55 | ParallelOverflow.Acquire; 56 | try 57 | Depth := ParallelGranularity; 58 | Total := e - b + 1; 59 | Critical := TCritical.Create; 60 | 61 | Completed := 0; 62 | 63 | if (Total < Depth) then 64 | begin 65 | Pass := b; 66 | while Pass <= e do 67 | begin 68 | new(p); 69 | p^.b := Pass; 70 | p^.e := Pass; 71 | p^.Completed := @Completed; 72 | p^.OnFor := OnFor; 73 | p^.Critical := Critical; 74 | TCompute.RunC(p, nil, @FPCParallelTh32_Block); 75 | inc(Pass); 76 | end; 77 | end 78 | else 79 | begin 80 | stepW := Total div Depth; 81 | StepTotal := Total div stepW; 82 | if Total mod stepW > 0 then 83 | inc(StepTotal); 84 | 85 | Pass := 0; 86 | while Pass < StepTotal do 87 | begin 88 | w := stepW * Pass; 89 | new(p); 90 | if w + stepW <= Total then 91 | begin 92 | p^.b := w + b; 93 | p^.e := w + stepW + b - 1; 94 | end 95 | else 96 | begin 97 | p^.b := w + b; 98 | p^.e := Total + b - 1; 99 | end; 100 | p^.Completed := @Completed; 101 | p^.OnFor := OnFor; 102 | p^.Critical := Critical; 103 | TCompute.RunC(p, nil, @FPCParallelTh32_Block); 104 | inc(Pass); 105 | end; 106 | end; 107 | 108 | repeat 109 | TThread.Sleep(1); 110 | Critical.Acquire; 111 | w := Completed; 112 | Critical.Release; 113 | until w >= Total; 114 | 115 | Critical.Free; 116 | finally 117 | ParallelOverflow.Release; 118 | end; 119 | end; 120 | 121 | type 122 | TFPCParallelThData64_Block = record 123 | b, e: Int64; 124 | Completed: ^Int64; 125 | OnFor: TFPCParallelForProcedure64; 126 | Critical: TCritical; 127 | end; 128 | 129 | PFPCParallelThData64_Block = ^TFPCParallelThData64_Block; 130 | 131 | procedure FPCParallelTh64_Block(ThSender: TCompute); 132 | var 133 | p: PFPCParallelThData64_Block; 134 | Pass: Int64; 135 | begin 136 | p := ThSender.UserData; 137 | Pass := p^.b; 138 | while Pass <= p^.e do 139 | begin 140 | try 141 | p^.OnFor(Pass); 142 | except 143 | end; 144 | inc(Pass); 145 | end; 146 | 147 | p^.Critical.Acquire; 148 | AtomInc(p^.Completed^, p^.e - p^.b + 1); 149 | p^.Critical.Release; 150 | dispose(p); 151 | end; 152 | 153 | procedure FPCParallelFor_Block(parallel: Boolean; b, e: Int64; OnFor: TFPCParallelForProcedure64); 154 | var 155 | Total, Depth, Completed, StepTotal, stepW, Pass, w: Int64; 156 | p: PFPCParallelThData64_Block; 157 | i: Int64; 158 | Critical: TCritical; 159 | begin 160 | if b > e then 161 | exit; 162 | if (not parallel) or (not WorkInParallelCore.V) or ParallelOverflow.Busy() then 163 | begin 164 | i := b; 165 | while i <= e do 166 | begin 167 | try 168 | OnFor(i); 169 | except 170 | end; 171 | inc(i); 172 | end; 173 | exit; 174 | end; 175 | ParallelOverflow.Acquire; 176 | try 177 | Depth := ParallelGranularity; 178 | Total := e - b + 1; 179 | Critical := TCritical.Create; 180 | 181 | Completed := 0; 182 | 183 | if (Total < Depth) then 184 | begin 185 | Pass := b; 186 | while Pass <= e do 187 | begin 188 | new(p); 189 | p^.b := Pass; 190 | p^.e := Pass; 191 | p^.Completed := @Completed; 192 | p^.OnFor := OnFor; 193 | p^.Critical := Critical; 194 | TCompute.RunC(p, nil, @FPCParallelTh64_Block); 195 | inc(Pass); 196 | end; 197 | end 198 | else 199 | begin 200 | stepW := Total div Depth; 201 | StepTotal := Total div stepW; 202 | if Total mod stepW > 0 then 203 | inc(StepTotal); 204 | 205 | Pass := 0; 206 | while Pass < StepTotal do 207 | begin 208 | w := stepW * Pass; 209 | new(p); 210 | if w + stepW <= Total then 211 | begin 212 | p^.b := w + b; 213 | p^.e := w + stepW + b - 1; 214 | end 215 | else 216 | begin 217 | p^.b := w + b; 218 | p^.e := Total + b - 1; 219 | end; 220 | p^.Completed := @Completed; 221 | p^.OnFor := OnFor; 222 | p^.Critical := Critical; 223 | TCompute.RunC(p, nil, @FPCParallelTh64_Block); 224 | inc(Pass); 225 | end; 226 | end; 227 | 228 | repeat 229 | TThread.Sleep(1); 230 | Critical.Acquire; 231 | w := Completed; 232 | Critical.Release; 233 | until w >= Total; 234 | 235 | Critical.Free; 236 | finally 237 | ParallelOverflow.Release; 238 | end; 239 | end; 240 | 241 | type 242 | TFPCParallelThData32_Fold = record 243 | Pass: Int64; 244 | Total, Granularity: Integer; 245 | Completed: Boolean; 246 | OnFor: TFPCParallelForProcedure32; 247 | Critical: TCritical; 248 | end; 249 | 250 | PFPCParallelThData32_Fold = ^TFPCParallelThData32_Fold; 251 | 252 | procedure FPCParallelTh32_Fold(ThSender: TCompute); 253 | var 254 | p: PFPCParallelThData32_Fold; 255 | begin 256 | p := ThSender.UserData; 257 | with p^ do 258 | while Pass <= Total do 259 | begin 260 | try 261 | OnFor(Pass); 262 | except 263 | end; 264 | inc(Pass, Granularity); 265 | end; 266 | 267 | p^.Critical.Acquire; 268 | p^.Completed := True; 269 | p^.Critical.Release; 270 | end; 271 | 272 | procedure FPCParallelFor_Fold(parallel: Boolean; b, e: Integer; OnFor: TFPCParallelForProcedure32); 273 | var 274 | p: PFPCParallelThData32_Fold; 275 | i, Depth: Integer; 276 | Critical: TCritical; 277 | states: array of TFPCParallelThData32_Fold; 278 | Completed: Boolean; 279 | begin 280 | if b > e then 281 | exit; 282 | if (not parallel) or (not WorkInParallelCore.V) or ParallelOverflow.Busy() then 283 | begin 284 | i := b; 285 | while i <= e do 286 | begin 287 | try 288 | OnFor(i); 289 | except 290 | end; 291 | inc(i); 292 | end; 293 | exit; 294 | end; 295 | ParallelOverflow.Acquire; 296 | try 297 | Critical := TCritical.Create; 298 | Depth := Min(ParallelGranularity, e - b + 1); 299 | SetLength(states, Depth); 300 | 301 | i := 0; 302 | while i < Depth do 303 | begin 304 | p := @states[i]; 305 | p^.Pass := b + i; 306 | p^.Total := e; 307 | p^.Granularity := ParallelGranularity; 308 | p^.Completed := False; 309 | p^.OnFor := OnFor; 310 | p^.Critical := Critical; 311 | TCompute.RunC(p, nil, @FPCParallelTh32_Fold); 312 | inc(i); 313 | end; 314 | 315 | repeat 316 | TThread.Sleep(1); 317 | Critical.Acquire; 318 | Completed := True; 319 | i := 0; 320 | while i < Length(states) do 321 | begin 322 | Completed := Completed and states[i].Completed; 323 | inc(i); 324 | end; 325 | Critical.Release; 326 | until Completed; 327 | 328 | Critical.Free; 329 | finally 330 | ParallelOverflow.Release; 331 | end; 332 | end; 333 | 334 | type 335 | TFPCParallelThData64_Fold = record 336 | Pass: Int64; 337 | Total, Granularity: Int64; 338 | Completed: Boolean; 339 | OnFor: TFPCParallelForProcedure64; 340 | Critical: TCritical; 341 | end; 342 | 343 | PFPCParallelThData64_Fold = ^TFPCParallelThData64_Fold; 344 | 345 | procedure FPCParallelTh64_Fold(ThSender: TCompute); 346 | var 347 | p: PFPCParallelThData64_Fold; 348 | begin 349 | p := ThSender.UserData; 350 | with p^ do 351 | while Pass <= Total do 352 | begin 353 | try 354 | OnFor(Pass); 355 | except 356 | end; 357 | inc(Pass, Granularity); 358 | end; 359 | 360 | p^.Critical.Acquire; 361 | p^.Completed := True; 362 | p^.Critical.Release; 363 | end; 364 | 365 | procedure FPCParallelFor_Fold(parallel: Boolean; b, e: Int64; OnFor: TFPCParallelForProcedure64); 366 | var 367 | p: PFPCParallelThData64_Fold; 368 | i, Depth: Int64; 369 | Critical: TCritical; 370 | states: array of TFPCParallelThData64_Fold; 371 | Completed: Boolean; 372 | begin 373 | if b > e then 374 | exit; 375 | if (not parallel) or (not WorkInParallelCore.V) or ParallelOverflow.Busy() then 376 | begin 377 | i := b; 378 | while i <= e do 379 | begin 380 | try 381 | OnFor(i); 382 | except 383 | end; 384 | inc(i); 385 | end; 386 | exit; 387 | end; 388 | ParallelOverflow.Acquire; 389 | try 390 | Critical := TCritical.Create; 391 | Depth := Min(ParallelGranularity, e - b + 1); 392 | SetLength(states, Depth); 393 | i := 0; 394 | while i < Depth do 395 | begin 396 | p := @states[i]; 397 | p^.Pass := b + i; 398 | p^.Total := e; 399 | p^.Granularity := ParallelGranularity; 400 | p^.Completed := False; 401 | p^.OnFor := OnFor; 402 | p^.Critical := Critical; 403 | TCompute.RunC(p, nil, @FPCParallelTh64_Fold); 404 | inc(i); 405 | end; 406 | 407 | repeat 408 | TThread.Sleep(1); 409 | Critical.Acquire; 410 | Completed := True; 411 | i := 0; 412 | while i < Length(states) do 413 | begin 414 | Completed := Completed and states[i].Completed; 415 | inc(i); 416 | end; 417 | Critical.Release; 418 | until Completed; 419 | 420 | Critical.Free; 421 | finally 422 | ParallelOverflow.Release; 423 | end; 424 | end; 425 | 426 | procedure FPCParallelFor(parallel: Boolean; b, e: Integer; OnFor: TFPCParallelForProcedure32); 427 | begin 428 | {$IFDEF FoldParallel} 429 | FPCParallelFor_Fold(parallel, b, e, OnFor); 430 | {$ELSE FoldParallel} 431 | FPCParallelFor_Block(parallel, b, e, OnFor); 432 | {$ENDIF FoldParallel} 433 | end; 434 | 435 | procedure FPCParallelFor(parallel: Boolean; b, e: Int64; OnFor: TFPCParallelForProcedure64); 436 | begin 437 | {$IFDEF FoldParallel} 438 | FPCParallelFor_Fold(parallel, b, e, OnFor); 439 | {$ELSE FoldParallel} 440 | FPCParallelFor_Block(parallel, b, e, OnFor); 441 | {$ENDIF FoldParallel} 442 | end; 443 | 444 | procedure FPCParallelFor(b, e: Integer; OnFor: TFPCParallelForProcedure32); 445 | begin 446 | FPCParallelFor(True, b, e, OnFor); 447 | end; 448 | 449 | procedure FPCParallelFor(b, e: Int64; OnFor: TFPCParallelForProcedure64); 450 | begin 451 | FPCParallelFor(True, b, e, OnFor); 452 | end; 453 | 454 | procedure FPCParallelFor(OnFor: TFPCParallelForProcedure32; b, e: Integer); 455 | begin 456 | FPCParallelFor(b, e, OnFor); 457 | end; 458 | 459 | procedure FPCParallelFor(OnFor: TFPCParallelForProcedure64; b, e: Int64); 460 | begin 461 | FPCParallelFor(b, e, OnFor); 462 | end; 463 | 464 | procedure FPCParallelFor(parallel: Boolean; OnFor: TFPCParallelForProcedure32; b, e: Integer); 465 | begin 466 | FPCParallelFor(parallel, b, e, OnFor); 467 | end; 468 | 469 | procedure FPCParallelFor(parallel: Boolean; OnFor: TFPCParallelForProcedure64; b, e: Int64); 470 | begin 471 | FPCParallelFor(parallel, b, e, OnFor); 472 | end; 473 | 474 | procedure ParallelFor(parallel: Boolean; b, e: Integer; OnFor: TFPCParallelForProcedure32); 475 | begin 476 | FPCParallelFor(parallel, b, e, OnFor); 477 | end; 478 | 479 | procedure ParallelFor(parallel: Boolean; b, e: Int64; OnFor: TFPCParallelForProcedure64); 480 | begin 481 | FPCParallelFor(parallel, b, e, OnFor); 482 | end; 483 | 484 | procedure ParallelFor(b, e: Integer; OnFor: TFPCParallelForProcedure32); 485 | begin 486 | FPCParallelFor(True, b, e, OnFor); 487 | end; 488 | 489 | procedure ParallelFor(b, e: Int64; OnFor: TFPCParallelForProcedure64); 490 | begin 491 | FPCParallelFor(True, b, e, OnFor); 492 | end; 493 | 494 | procedure ParallelFor(OnFor: TFPCParallelForProcedure32; b, e: Integer); 495 | begin 496 | FPCParallelFor(b, e, OnFor); 497 | end; 498 | 499 | procedure ParallelFor(OnFor: TFPCParallelForProcedure64; b, e: Int64); 500 | begin 501 | FPCParallelFor(b, e, OnFor); 502 | end; 503 | 504 | procedure ParallelFor(parallel: Boolean; OnFor: TFPCParallelForProcedure32; b, e: Integer); 505 | begin 506 | FPCParallelFor(parallel, b, e, OnFor); 507 | end; 508 | 509 | procedure ParallelFor(parallel: Boolean; OnFor: TFPCParallelForProcedure64; b, e: Int64); 510 | begin 511 | FPCParallelFor(parallel, b, e, OnFor); 512 | end; 513 | -------------------------------------------------------------------------------- /Source/Core_LineProcessor.inc: -------------------------------------------------------------------------------- 1 | {$IFDEF RangeCheck}{$R-}{$ENDIF} 2 | {$IFDEF OverflowCheck}{$Q-}{$ENDIF} 3 | 4 | 5 | procedure TLineProcessor{$IFNDEF FPC}<T_>{$ENDIF FPC}.CreateDone; 6 | begin 7 | end; 8 | 9 | constructor TLineProcessor{$IFNDEF FPC}<T_>{$ENDIF FPC}.Create(const data_: Pointer; const width_, height_: NativeInt; const Value_: T_; const LineTail_: Boolean); 10 | begin 11 | inherited Create; 12 | FData := PTArry_(data_); 13 | FWidth := width_; 14 | FHeight := height_; 15 | FValue := Value_; 16 | FLineTail := LineTail_; 17 | CreateDone(); 18 | end; 19 | 20 | destructor TLineProcessor{$IFNDEF FPC}<T_>{$ENDIF FPC}.Destroy; 21 | begin 22 | inherited Destroy; 23 | end; 24 | 25 | procedure TLineProcessor{$IFNDEF FPC}<T_>{$ENDIF FPC}.VertLine(X, y1, y2: NativeInt); 26 | var 27 | i: NativeInt; 28 | p: PT_; 29 | begin 30 | if (X < 0) or (X >= FWidth) then 31 | Exit; 32 | 33 | if y1 < 0 then 34 | y1 := 0; 35 | if y1 >= FHeight then 36 | y1 := FHeight - 1; 37 | 38 | if y2 < 0 then 39 | y2 := 0; 40 | if y2 >= FHeight then 41 | y2 := FHeight - 1; 42 | 43 | if y2 < y1 then 44 | Swap(y1, y2); 45 | 46 | p := @FData^[X + y1 * FWidth]; 47 | for i := y1 to y2 do 48 | begin 49 | Process(p, FValue); 50 | inc(p, FWidth); 51 | end; 52 | end; 53 | 54 | procedure TLineProcessor{$IFNDEF FPC}<T_>{$ENDIF FPC}.HorzLine(x1, Y, x2: NativeInt); 55 | var 56 | i: NativeInt; 57 | p: PT_; 58 | begin 59 | if (Y < 0) or (Y >= FHeight) then 60 | Exit; 61 | 62 | if x1 < 0 then 63 | x1 := 0; 64 | if x1 >= FWidth then 65 | x1 := FWidth - 1; 66 | 67 | if x2 < 0 then 68 | x2 := 0; 69 | if x2 >= FWidth then 70 | x2 := FWidth - 1; 71 | 72 | if x1 > x2 then 73 | Swap(x1, x2); 74 | 75 | p := @FData^[x1 + Y * FWidth]; 76 | 77 | for i := x1 to x2 do 78 | begin 79 | Process(p, FValue); 80 | inc(p); 81 | end; 82 | end; 83 | 84 | procedure TLineProcessor{$IFNDEF FPC}<T_>{$ENDIF FPC}.Line(x1, y1, x2, y2: NativeInt); 85 | var 86 | dy, dx, SY, SX, i, Delta: NativeInt; 87 | pi, pl: NativeInt; 88 | begin 89 | if (x1 = x2) and (y1 = y2) then 90 | begin 91 | Process(@FData^[x1 + y1 * FWidth], FValue); 92 | Exit; 93 | end; 94 | 95 | dx := x2 - x1; 96 | dy := y2 - y1; 97 | 98 | if dx > 0 then 99 | SX := 1 100 | else if dx < 0 then 101 | begin 102 | dx := -dx; 103 | SX := -1; 104 | end 105 | else // Dx = 0 106 | begin 107 | if dy > 0 then 108 | VertLine(x1, y1, y2 - 1) 109 | else if dy < 0 then 110 | VertLine(x1, y2 + 1, y1); 111 | if FLineTail then 112 | Process(@FData^[x2 + y2 * FWidth], FValue); 113 | Exit; 114 | end; 115 | 116 | if dy > 0 then 117 | SY := 1 118 | else if dy < 0 then 119 | begin 120 | dy := -dy; 121 | SY := -1; 122 | end 123 | else // Dy = 0 124 | begin 125 | if x2 > x1 then 126 | HorzLine(x1, y1, x2 - 1) 127 | else 128 | HorzLine(x2 + 1, y1, x1); 129 | if FLineTail then 130 | Process(@FData^[x2 + y2 * FWidth], FValue); 131 | Exit; 132 | end; 133 | 134 | pi := x1 + y1 * FWidth; 135 | SY := SY * FWidth; 136 | pl := FWidth * FHeight; 137 | 138 | if dx > dy then 139 | begin 140 | Delta := dx shr 1; 141 | for i := 0 to dx - 1 do 142 | begin 143 | if (pi >= 0) and (pi < pl) then 144 | Process(@FData^[pi], FValue); 145 | 146 | inc(pi, SX); 147 | inc(Delta, dy); 148 | if Delta >= dx then 149 | begin 150 | inc(pi, SY); 151 | dec(Delta, dx); 152 | end; 153 | end; 154 | end 155 | else // Dx < Dy 156 | begin 157 | Delta := dy shr 1; 158 | for i := 0 to dy - 1 do 159 | begin 160 | if (pi >= 0) and (pi < pl) then 161 | Process(@FData^[pi], FValue); 162 | 163 | inc(pi, SY); 164 | inc(Delta, dx); 165 | if Delta >= dy then 166 | begin 167 | inc(pi, SX); 168 | dec(Delta, dy); 169 | end; 170 | end; 171 | end; 172 | if (FLineTail) and (pi >= 0) and (pi < pl) then 173 | Process(@FData^[pi], FValue); 174 | end; 175 | 176 | procedure TLineProcessor{$IFNDEF FPC}<T_>{$ENDIF FPC}.FillBox(x1, y1, x2, y2: NativeInt); 177 | var 178 | i: Integer; 179 | begin 180 | if y1 > y2 then 181 | Swap(y1, y2); 182 | for i := y1 to y2 do 183 | HorzLine(x1, i, x2); 184 | end; 185 | 186 | procedure TLineProcessor{$IFNDEF FPC}<T_>{$ENDIF FPC}.Process(const vp: PT_; const v: T_); 187 | begin 188 | vp^ := v; 189 | end; 190 | {$IFDEF RangeCheck}{$R+}{$ENDIF} 191 | {$IFDEF OverflowCheck}{$Q+}{$ENDIF} 192 | -------------------------------------------------------------------------------- /Source/Core_OrderData.inc: -------------------------------------------------------------------------------- 1 | procedure TOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.DoInternalFree(p: POrderStruct_); 2 | begin 3 | try 4 | DoFree(p^.Data); 5 | Dispose(p); 6 | except 7 | end; 8 | end; 9 | 10 | constructor TOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Create; 11 | begin 12 | inherited Create; 13 | FFirst := nil; 14 | FLast := nil; 15 | FNum := 0; 16 | FOnFreeOrderStruct := nil; 17 | end; 18 | 19 | destructor TOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Destroy; 20 | begin 21 | Clear; 22 | inherited Destroy; 23 | end; 24 | 25 | procedure TOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.DoFree(var Data: T_); 26 | begin 27 | if Assigned(FOnFreeOrderStruct) then 28 | FOnFreeOrderStruct(Data); 29 | end; 30 | 31 | procedure TOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Clear; 32 | var 33 | p, tmp: POrderStruct_; 34 | begin 35 | p := FFirst; 36 | while p <> nil do 37 | begin 38 | tmp := p^.Next; 39 | DoInternalFree(p); 40 | p := tmp; 41 | end; 42 | FFirst := nil; 43 | FLast := nil; 44 | FNum := 0; 45 | end; 46 | 47 | procedure TOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Next; 48 | var 49 | tmp: POrderStruct_; 50 | begin 51 | if FFirst <> nil then 52 | begin 53 | tmp := FFirst^.Next; 54 | DoInternalFree(FFirst); 55 | FFirst := tmp; 56 | if FFirst = nil then 57 | FLast := nil; 58 | Dec(FNum); 59 | end; 60 | end; 61 | 62 | procedure TOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Push(Data: T_); 63 | var 64 | p: POrderStruct_; 65 | begin 66 | new(p); 67 | p^.Data := Data; 68 | p^.Next := nil; 69 | 70 | Inc(FNum); 71 | if (FFirst = nil) and (FLast = nil) then 72 | begin 73 | FFirst := p; 74 | FLast := p; 75 | end 76 | else if FLast <> nil then 77 | begin 78 | FLast^.Next := p; 79 | FLast := p; 80 | end; 81 | end; 82 | 83 | procedure TOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.DoInternalFree(p: POrderPtrStruct_); 84 | begin 85 | try 86 | DoFree(p^.Data); 87 | Dispose(p); 88 | except 89 | end; 90 | end; 91 | 92 | constructor TOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Create; 93 | begin 94 | inherited Create; 95 | FFirst := nil; 96 | FLast := nil; 97 | FNum := 0; 98 | FOnFreeOrderStruct := nil; 99 | end; 100 | 101 | destructor TOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Destroy; 102 | begin 103 | Clear; 104 | inherited Destroy; 105 | end; 106 | 107 | procedure TOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.DoFree(Data: PT_); 108 | begin 109 | if Assigned(FOnFreeOrderStruct) then 110 | FOnFreeOrderStruct(Data) 111 | else 112 | Dispose(Data); 113 | end; 114 | 115 | procedure TOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Clear; 116 | var 117 | p, tmp: POrderPtrStruct_; 118 | begin 119 | p := FFirst; 120 | while p <> nil do 121 | begin 122 | tmp := p^.Next; 123 | DoInternalFree(p); 124 | p := tmp; 125 | end; 126 | FFirst := nil; 127 | FLast := nil; 128 | FNum := 0; 129 | end; 130 | 131 | procedure TOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Next; 132 | var 133 | tmp: POrderPtrStruct_; 134 | begin 135 | if FFirst <> nil then 136 | begin 137 | tmp := FFirst^.Next; 138 | DoInternalFree(FFirst); 139 | FFirst := tmp; 140 | if FFirst = nil then 141 | FLast := nil; 142 | Dec(FNum); 143 | end; 144 | end; 145 | 146 | procedure TOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Push(Data: T_); 147 | var 148 | p: POrderPtrStruct_; 149 | begin 150 | new(p); 151 | new(p^.Data); 152 | p^.Data^ := Data; 153 | p^.Next := nil; 154 | 155 | Inc(FNum); 156 | if (FFirst = nil) and (FLast = nil) then 157 | begin 158 | FFirst := p; 159 | FLast := p; 160 | end 161 | else if FLast <> nil then 162 | begin 163 | FLast^.Next := p; 164 | FLast := p; 165 | end; 166 | end; 167 | 168 | procedure TOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.PushPtr(Data: PT_); 169 | var 170 | p: POrderPtrStruct_; 171 | begin 172 | new(p); 173 | p^.Data := Data; 174 | p^.Next := nil; 175 | 176 | Inc(FNum); 177 | if (FFirst = nil) and (FLast = nil) then 178 | begin 179 | FFirst := p; 180 | FLast := p; 181 | end 182 | else if FLast <> nil then 183 | begin 184 | FLast^.Next := p; 185 | FLast := p; 186 | end; 187 | end; 188 | 189 | procedure TCriticalOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.DoInternalFree(p: POrderStruct_); 190 | begin 191 | try 192 | DoFree(p^.Data); 193 | Dispose(p); 194 | except 195 | end; 196 | end; 197 | 198 | constructor TCriticalOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Create; 199 | begin 200 | inherited Create; 201 | FCritical := TCritical.Create; 202 | FFirst := nil; 203 | FLast := nil; 204 | FNum := 0; 205 | FOnFreeCriticalOrderStruct := nil; 206 | end; 207 | 208 | destructor TCriticalOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Destroy; 209 | begin 210 | Clear; 211 | FCritical.Free; 212 | inherited Destroy; 213 | end; 214 | 215 | procedure TCriticalOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.DoFree(var Data: T_); 216 | begin 217 | if Assigned(FOnFreeCriticalOrderStruct) then 218 | FOnFreeCriticalOrderStruct(Data); 219 | end; 220 | 221 | procedure TCriticalOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Clear; 222 | var 223 | p, tmp: POrderStruct_; 224 | begin 225 | FCritical.Lock; 226 | p := FFirst; 227 | while p <> nil do 228 | begin 229 | tmp := p^.Next; 230 | DoInternalFree(p); 231 | p := tmp; 232 | end; 233 | FFirst := nil; 234 | FLast := nil; 235 | FNum := 0; 236 | FCritical.UnLock; 237 | end; 238 | 239 | function TCriticalOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.GetCurrent: POrderStruct_; 240 | begin 241 | FCritical.Lock; 242 | Result := FFirst; 243 | FCritical.UnLock; 244 | end; 245 | 246 | procedure TCriticalOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Next; 247 | var 248 | tmp: POrderStruct_; 249 | begin 250 | FCritical.Lock; 251 | if FFirst <> nil then 252 | begin 253 | tmp := FFirst^.Next; 254 | DoInternalFree(FFirst); 255 | FFirst := tmp; 256 | if FFirst = nil then 257 | FLast := nil; 258 | Dec(FNum); 259 | end; 260 | FCritical.UnLock; 261 | end; 262 | 263 | procedure TCriticalOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Push(Data: T_); 264 | var 265 | p: POrderStruct_; 266 | begin 267 | new(p); 268 | p^.Data := Data; 269 | p^.Next := nil; 270 | 271 | FCritical.Lock; 272 | Inc(FNum); 273 | if (FFirst = nil) and (FLast = nil) then 274 | begin 275 | FFirst := p; 276 | FLast := p; 277 | end 278 | else if FLast <> nil then 279 | begin 280 | FLast^.Next := p; 281 | FLast := p; 282 | end; 283 | FCritical.UnLock; 284 | end; 285 | 286 | function TCriticalOrderStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.GetNum: NativeInt; 287 | begin 288 | FCritical.Lock; 289 | Result := FNum; 290 | FCritical.UnLock; 291 | end; 292 | 293 | procedure TCriticalOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.DoInternalFree(p: POrderPtrStruct_); 294 | begin 295 | try 296 | DoFree(p^.Data); 297 | Dispose(p); 298 | except 299 | end; 300 | end; 301 | 302 | constructor TCriticalOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Create; 303 | begin 304 | inherited Create; 305 | FCritical := TCritical.Create; 306 | FFirst := nil; 307 | FLast := nil; 308 | FNum := 0; 309 | FOnFreeCriticalOrderStruct := nil; 310 | end; 311 | 312 | destructor TCriticalOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Destroy; 313 | begin 314 | Clear; 315 | FCritical.Free; 316 | inherited Destroy; 317 | end; 318 | 319 | procedure TCriticalOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.DoFree(Data: PT_); 320 | begin 321 | if Assigned(FOnFreeCriticalOrderStruct) then 322 | FOnFreeCriticalOrderStruct(Data) 323 | else 324 | Dispose(Data); 325 | end; 326 | 327 | procedure TCriticalOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Clear; 328 | var 329 | p, tmp: POrderPtrStruct_; 330 | begin 331 | FCritical.Lock; 332 | p := FFirst; 333 | while p <> nil do 334 | begin 335 | tmp := p^.Next; 336 | DoInternalFree(p); 337 | p := tmp; 338 | end; 339 | FFirst := nil; 340 | FLast := nil; 341 | FNum := 0; 342 | FCritical.UnLock; 343 | end; 344 | 345 | function TCriticalOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.GetCurrent: POrderPtrStruct_; 346 | begin 347 | FCritical.Lock; 348 | Result := FFirst; 349 | FCritical.UnLock; 350 | end; 351 | 352 | procedure TCriticalOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Next; 353 | var 354 | tmp: POrderPtrStruct_; 355 | begin 356 | FCritical.Lock; 357 | if FFirst <> nil then 358 | begin 359 | tmp := FFirst^.Next; 360 | DoInternalFree(FFirst); 361 | FFirst := tmp; 362 | if FFirst = nil then 363 | FLast := nil; 364 | Dec(FNum); 365 | end; 366 | FCritical.UnLock; 367 | end; 368 | 369 | procedure TCriticalOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.Push(Data: T_); 370 | var 371 | p: POrderPtrStruct_; 372 | begin 373 | new(p); 374 | new(p^.Data); 375 | p^.Data^ := Data; 376 | p^.Next := nil; 377 | 378 | FCritical.Lock; 379 | Inc(FNum); 380 | if (FFirst = nil) and (FLast = nil) then 381 | begin 382 | FFirst := p; 383 | FLast := p; 384 | end 385 | else if FLast <> nil then 386 | begin 387 | FLast^.Next := p; 388 | FLast := p; 389 | end; 390 | FCritical.UnLock; 391 | end; 392 | 393 | procedure TCriticalOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.PushPtr(Data: PT_); 394 | var 395 | p: POrderPtrStruct_; 396 | begin 397 | new(p); 398 | p^.Data := Data; 399 | p^.Next := nil; 400 | 401 | FCritical.Lock; 402 | Inc(FNum); 403 | if (FFirst = nil) and (FLast = nil) then 404 | begin 405 | FFirst := p; 406 | FLast := p; 407 | end 408 | else if FLast <> nil then 409 | begin 410 | FLast^.Next := p; 411 | FLast := p; 412 | end; 413 | FCritical.UnLock; 414 | end; 415 | 416 | function TCriticalOrderPtrStruct{$IFNDEF FPC}<T_>{$ENDIF FPC}.GetNum: NativeInt; 417 | begin 418 | FCritical.Lock; 419 | Result := FNum; 420 | FCritical.UnLock; 421 | end; 422 | -------------------------------------------------------------------------------- /Source/FPCGenericStructlist.pas: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { * Generic list of any type (TGenericStructList). * } 3 | { ****************************************************************************** } 4 | { * https://zpascal.net * } 5 | { * https://github.com/PassByYou888/zAI * } 6 | { * https://github.com/PassByYou888/ZServer4D * } 7 | { * https://github.com/PassByYou888/PascalString * } 8 | { * https://github.com/PassByYou888/zRasterization * } 9 | { * https://github.com/PassByYou888/CoreCipher * } 10 | { * https://github.com/PassByYou888/zSound * } 11 | { * https://github.com/PassByYou888/zChinese * } 12 | { * https://github.com/PassByYou888/zExpression * } 13 | { * https://github.com/PassByYou888/zGameWare * } 14 | { * https://github.com/PassByYou888/zAnalysis * } 15 | { * https://github.com/PassByYou888/FFMPEG-Header * } 16 | { * https://github.com/PassByYou888/zTranslate * } 17 | { * https://github.com/PassByYou888/InfiniteIoT * } 18 | { * https://github.com/PassByYou888/FastMD5 * } 19 | { ****************************************************************************** } 20 | { 21 | Based on FPC FGL unit, copyright by FPC team. 22 | License of FPC RTL is the same as our engine (modified LGPL, 23 | see COPYING.txt for details). 24 | Fixed to compile also under FPC 2.4.0 and 2.2.4. 25 | Some small comfortable methods added. 26 | } 27 | 28 | unit FPCGenericStructlist; 29 | 30 | {$IFDEF FPC} 31 | {$mode objfpc}{$H+} 32 | 33 | {$IF defined(VER2_2)} {$DEFINE OldSyntax} {$IFEND} 34 | {$IF defined(VER2_4)} {$DEFINE OldSyntax} {$IFEND} 35 | 36 | {$define HAS_ENUMERATOR} 37 | {$ifdef VER2_2} {$undef HAS_ENUMERATOR} {$endif} 38 | {$ifdef VER2_4_0} {$undef HAS_ENUMERATOR} {$endif} 39 | { Just undef enumerator always, in FPC 2.7.1 it's either broken 40 | or I shouldn't overuse TFPGListEnumeratorSpec. } 41 | {$undef HAS_ENUMERATOR} 42 | 43 | { FPC < 2.6.0 had buggy version of the Extract function, 44 | also with different interface, see http://bugs.freepascal.org/view.php?id=19960. } 45 | {$define HAS_EXTRACT} 46 | {$ifdef VER2_2} {$undef HAS_EXTRACT} {$endif} 47 | {$ifdef VER2_4} {$undef HAS_EXTRACT} {$endif} 48 | {$ENDIF FPC} 49 | 50 | interface 51 | 52 | {$IFDEF FPC} 53 | 54 | uses fgl; 55 | 56 | type 57 | { Generic list of types that are compared by CompareByte. 58 | 59 | This is equivalent to TFPGList, except it doesn't override IndexOf, 60 | so your type doesn't need to have a "=" operator built-in inside FPC. 61 | When calling IndexOf or Remove, it will simply compare values using 62 | CompareByte, this is what TFPSList.IndexOf uses. 63 | This way it works to create lists of records, vectors (constant size arrays), 64 | old-style TP objects, and also is suitable to create a list of methods 65 | (since for methods, the "=" is broken, for Delphi compatibility, 66 | see http://bugs.freepascal.org/view.php?id=9228). 67 | 68 | We also add some trivial helper methods like @link(Add) and @link(L). } 69 | generic TGenericsList<t> = class(TFPSList) 70 | private 71 | type 72 | TCompareFunc = function(const Item1, Item2: t): Integer; 73 | TTypeList = array[0..MaxGListSize] of t; 74 | PTypeList = ^TTypeList; 75 | {$ifdef HAS_ENUMERATOR} TFPGListEnumeratorSpec = specialize TFPGListEnumerator<t>; {$endif} 76 | 77 | {$ifndef OldSyntax}protected var{$else} 78 | {$ifdef PASDOC}protected var{$else} { PasDoc can't handle "var protected", and I don't know how/if they should be handled? } 79 | var protected{$endif}{$endif} FOnCompare: TCompareFunc; 80 | 81 | procedure CopyItem(Src, dest: Pointer); override; 82 | procedure Deref(Item: Pointer); override; 83 | function Get(index: Integer): t; {$ifdef CLASSESINLINE} inline; {$endif} 84 | function GetList: PTypeList; {$ifdef CLASSESINLINE} inline; {$endif} 85 | function ItemPtrCompare(Item1, Item2: Pointer): Integer; 86 | procedure Put(index: Integer; const Item: t); {$ifdef CLASSESINLINE} inline; {$endif} 87 | public 88 | constructor Create; 89 | function Add(const Item: t): Integer; {$ifdef CLASSESINLINE} inline; {$endif} 90 | {$ifdef HAS_EXTRACT} function Extract(const Item: t): t; {$ifdef CLASSESINLINE} inline; {$endif} {$endif} 91 | function First: t; {$ifdef CLASSESINLINE} inline; {$endif} 92 | {$ifdef HAS_ENUMERATOR} function GetEnumerator: TFPGListEnumeratorSpec; {$ifdef CLASSESINLINE} inline; {$endif} {$endif} 93 | function IndexOf(const Item: t): Integer; 94 | procedure Insert(index: Integer; const Item: t); {$ifdef CLASSESINLINE} inline; {$endif} 95 | function Last: t; {$ifdef CLASSESINLINE} inline; {$endif} 96 | {$ifndef OldSyntax} 97 | procedure Assign(Source: TGenericsList); 98 | {$endif OldSyntax} 99 | function Remove(const Item: t): Integer; {$ifdef CLASSESINLINE} inline; {$endif} 100 | procedure Sort(Compare: TCompareFunc); 101 | property Items[index: Integer]: t read Get write Put; default; 102 | property List: PTypeList read GetList; 103 | property ListData: PTypeList read GetList; 104 | end; 105 | 106 | {$ENDIF FPC} 107 | 108 | implementation 109 | 110 | {$IFDEF FPC} 111 | constructor TGenericsList.Create; 112 | begin 113 | inherited Create(SizeOf(t)); 114 | end; 115 | 116 | procedure TGenericsList.CopyItem(Src, dest: Pointer); 117 | begin 118 | t(dest^) := t(Src^); 119 | end; 120 | 121 | procedure TGenericsList.Deref(Item: Pointer); 122 | begin 123 | Finalize(t(Item^)); 124 | end; 125 | 126 | function TGenericsList.Get(index: Integer): t; 127 | begin 128 | Result := t(inherited Get(index)^); 129 | end; 130 | 131 | function TGenericsList.GetList: PTypeList; 132 | begin 133 | Result := PTypeList(FList); 134 | end; 135 | 136 | function TGenericsList.ItemPtrCompare(Item1, Item2: Pointer): Integer; 137 | begin 138 | Result := FOnCompare(t(Item1^), t(Item2^)); 139 | end; 140 | 141 | procedure TGenericsList.Put(index: Integer; const Item: t); 142 | begin 143 | inherited Put(index, @Item); 144 | end; 145 | 146 | function TGenericsList.Add(const Item: t): Integer; 147 | begin 148 | Result := inherited Add(@Item); 149 | end; 150 | 151 | {$ifdef HAS_EXTRACT} 152 | function TGenericsList.Extract(const Item: t): t; 153 | begin 154 | inherited Extract(@Item, @Result); 155 | end; 156 | {$endif} 157 | 158 | function TGenericsList.First: t; 159 | begin 160 | Result := t(inherited First^); 161 | end; 162 | 163 | {$ifdef HAS_ENUMERATOR} 164 | function TGenericsList.GetEnumerator: TFPGListEnumeratorSpec; 165 | begin 166 | Result := TFPGListEnumeratorSpec.Create(Self); 167 | end; 168 | {$endif} 169 | 170 | function TGenericsList.IndexOf(const Item: t): Integer; 171 | begin 172 | Result := inherited IndexOf(@Item); 173 | end; 174 | 175 | procedure TGenericsList.Insert(index: Integer; const Item: t); 176 | begin 177 | t(inherited Insert(index)^) := Item; 178 | end; 179 | 180 | function TGenericsList.Last: t; 181 | begin 182 | Result := t(inherited Last^); 183 | end; 184 | 185 | {$ifndef OldSyntax} 186 | procedure TGenericsList.Assign(Source: TGenericsList); 187 | var 188 | i: Integer; 189 | begin 190 | Clear; 191 | for i := 0 to Source.Count - 1 do 192 | Add(Source[i]); 193 | end; 194 | {$endif OldSyntax} 195 | 196 | function TGenericsList.Remove(const Item: t): Integer; 197 | begin 198 | Result := IndexOf(Item); 199 | if Result >= 0 then 200 | Delete(Result); 201 | end; 202 | 203 | procedure TGenericsList.Sort(Compare: TCompareFunc); 204 | begin 205 | FOnCompare := Compare; 206 | inherited Sort(@ItemPtrCompare); 207 | end; 208 | 209 | {$ENDIF FPC} 210 | 211 | end. 212 | 213 | 214 | 215 | -------------------------------------------------------------------------------- /Source/Fast_MD5.pas: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { * Fast md5 * } 3 | { * https://zpascal.net * } 4 | { * https://github.com/PassByYou888/zAI * } 5 | { * https://github.com/PassByYou888/ZServer4D * } 6 | { * https://github.com/PassByYou888/PascalString * } 7 | { * https://github.com/PassByYou888/zRasterization * } 8 | { * https://github.com/PassByYou888/CoreCipher * } 9 | { * https://github.com/PassByYou888/zSound * } 10 | { * https://github.com/PassByYou888/zChinese * } 11 | { * https://github.com/PassByYou888/zExpression * } 12 | { * https://github.com/PassByYou888/zGameWare * } 13 | { * https://github.com/PassByYou888/zAnalysis * } 14 | { * https://github.com/PassByYou888/FFMPEG-Header * } 15 | { * https://github.com/PassByYou888/zTranslate * } 16 | { * https://github.com/PassByYou888/InfiniteIoT * } 17 | { * https://github.com/PassByYou888/FastMD5 * } 18 | { ****************************************************************************** } 19 | unit Fast_MD5; 20 | 21 | {$INCLUDE zDefine.inc} 22 | 23 | interface 24 | 25 | 26 | uses CoreClasses, UnicodeMixedLib; 27 | 28 | {$IF Defined(MSWINDOWS) and Defined(Delphi)} 29 | procedure MD5_Transform(var Accu; const Buf); 30 | {$ENDIF Defined(MSWINDOWS) and Defined(Delphi)} 31 | 32 | function FastMD5(const buffPtr: PByte; bufSiz: nativeUInt): TMD5; overload; 33 | function FastMD5(stream: TCoreClassStream; StartPos, EndPos: Int64): TMD5; overload; 34 | 35 | implementation 36 | 37 | {$IF Defined(MSWINDOWS) and Defined(Delphi)} 38 | 39 | 40 | uses MemoryStream64; 41 | 42 | (* 43 | fastMD5 algorithm by Maxim Masiutin 44 | https://github.com/maximmasiutin/MD5_Transform-x64 45 | 46 | delphi imp by 600585@qq.com 47 | https://github.com/PassByYou888/FastMD5 48 | *) 49 | 50 | {$IF Defined(WIN32)} 51 | (* 52 | ; ============================================================== 53 | ; 54 | ; MD5_386.Asm - 386 optimized helper routine for calculating 55 | ; MD Message-Digest values 56 | ; written 2/2/94 by 57 | ; 58 | ; Peter Sawatzki 59 | ; Buchenhof 3 60 | ; D58091 Hagen, Germany Fed Rep 61 | ; 62 | ; EMail: Peter@Sawatzki.de 63 | ; EMail: 100031.3002@compuserve.com 64 | ; WWW: http://www.sawatzki.de 65 | ; 66 | ; 67 | ; original C Source was found in Dr. Dobbs Journal Sep 91 68 | ; MD5 algorithm from RSA Data Security, Inc. 69 | *) 70 | {$L MD5_32.obj} 71 | {$ELSEIF Defined(WIN64)} 72 | (* 73 | ; MD5_Transform-x64 74 | ; MD5 transform routine oprimized for x64 processors 75 | ; Copyright 2018 Ritlabs, SRL 76 | ; The 64-bit version is written by Maxim Masiutin <max@ritlabs.com> 77 | 78 | ; The main advantage of this 64-bit version is that 79 | ; it loads 64 bytes of hashed message into 8 64-bit registers 80 | ; (RBP, R8, R9, R10, R11, R12, R13, R14) at the beginning, 81 | ; to avoid excessive memory load operations 82 | ; througout the routine. 83 | 84 | ; To operate with 32-bit values store in higher bits 85 | ; of a 64-bit register (bits 32-63) uses "Ror" by 32; 86 | ; 8 macro variables (M1-M8) are used to keep record 87 | ; or corrent state of whether the register has been 88 | ; Ror'ed or not. 89 | 90 | ; It also has an ability to use Lea instruction instead 91 | ; of two sequental Adds (uncomment UseLea=1), but it is 92 | ; slower on Skylake processors. Also, Intel in the 93 | ; Optimization Reference Maual discourages us of 94 | ; Lea as a replacement of two adds, since it is slower 95 | ; on the Atom processors. 96 | 97 | ; MD5_Transform-x64 is released under a dual license, 98 | ; and you may choose to use it under either the 99 | ; Mozilla Public License 2.0 (MPL 2.1, available from 100 | ; https://www.mozilla.org/en-US/MPL/2.0/) or the 101 | ; GNU Lesser General Public License Version 3, 102 | ; dated 29 June 2007 (LGPL 3, available from 103 | ; https://www.gnu.org/licenses/lgpl.html). 104 | 105 | ; MD5_Transform-x64 is based 106 | ; on the following code by Peter Sawatzki. 107 | 108 | ; The original notice by Peter Sawatzki follows. 109 | *) 110 | {$L MD5_64.obj} 111 | {$ENDIF} 112 | 113 | procedure MD5_Transform(var Accu; const Buf); register; external; 114 | 115 | function FastMD5(const buffPtr: PByte; bufSiz: nativeUInt): TMD5; 116 | var 117 | Digest: TMD5; 118 | Lo, Hi: Cardinal; 119 | p: PByte; 120 | ChunkIndex: Byte; 121 | ChunkBuff: array [0 .. 63] of Byte; 122 | begin 123 | Lo := 0; 124 | Hi := 0; 125 | PCardinal(@Digest[0])^ := $67452301; 126 | PCardinal(@Digest[4])^ := $EFCDAB89; 127 | PCardinal(@Digest[8])^ := $98BADCFE; 128 | PCardinal(@Digest[12])^ := $10325476; 129 | 130 | inc(Lo, bufSiz shl 3); 131 | inc(Hi, bufSiz shr 29); 132 | 133 | p := buffPtr; 134 | 135 | while bufSiz >= $40 do 136 | begin 137 | MD5_Transform(Digest, p^); 138 | inc(p, $40); 139 | dec(bufSiz, $40); 140 | end; 141 | if bufSiz > 0 then 142 | CopyPtr(p, @ChunkBuff[0], bufSiz); 143 | 144 | Result := PMD5(@Digest[0])^; 145 | ChunkBuff[bufSiz] := $80; 146 | ChunkIndex := bufSiz + 1; 147 | if ChunkIndex > $38 then 148 | begin 149 | if ChunkIndex < $40 then 150 | FillPtrByte(@ChunkBuff[ChunkIndex], $40 - ChunkIndex, 0); 151 | MD5_Transform(Result, ChunkBuff); 152 | ChunkIndex := 0 153 | end; 154 | FillPtrByte(@ChunkBuff[ChunkIndex], $38 - ChunkIndex, 0); 155 | PCardinal(@ChunkBuff[$38])^ := Lo; 156 | PCardinal(@ChunkBuff[$3C])^ := Hi; 157 | MD5_Transform(Result, ChunkBuff); 158 | end; 159 | 160 | function FastMD5(stream: TCoreClassStream; StartPos, EndPos: Int64): TMD5; 161 | const 162 | deltaSize: Cardinal = $40 * $FFFF; 163 | 164 | var 165 | Digest: TMD5; 166 | Lo, Hi: Cardinal; 167 | DeltaBuf: Pointer; 168 | bufSiz: Int64; 169 | Rest: Cardinal; 170 | p: PByte; 171 | ChunkIndex: Byte; 172 | ChunkBuff: array [0 .. 63] of Byte; 173 | begin 174 | if StartPos > EndPos then 175 | Swap(StartPos, EndPos); 176 | StartPos := umlClamp(StartPos, 0, stream.Size); 177 | EndPos := umlClamp(EndPos, 0, stream.Size); 178 | if EndPos - StartPos <= 0 then 179 | begin 180 | Result := FastMD5(nil, 0); 181 | exit; 182 | end; 183 | {$IFDEF OptimizationMemoryStreamMD5} 184 | if stream is TCoreClassMemoryStream then 185 | begin 186 | Result := FastMD5(Pointer(nativeUInt(TCoreClassMemoryStream(stream).Memory) + StartPos), EndPos - StartPos); 187 | exit; 188 | end; 189 | if stream is TMemoryStream64 then 190 | begin 191 | Result := FastMD5(TMemoryStream64(stream).PositionAsPtr(StartPos), EndPos - StartPos); 192 | exit; 193 | end; 194 | {$ENDIF} 195 | // 196 | Lo := 0; 197 | Hi := 0; 198 | PCardinal(@Digest[0])^ := $67452301; 199 | PCardinal(@Digest[4])^ := $EFCDAB89; 200 | PCardinal(@Digest[8])^ := $98BADCFE; 201 | PCardinal(@Digest[12])^ := $10325476; 202 | 203 | bufSiz := EndPos - StartPos; 204 | Rest := 0; 205 | 206 | inc(Lo, bufSiz shl 3); 207 | inc(Hi, bufSiz shr 29); 208 | 209 | DeltaBuf := GetMemory(deltaSize); 210 | stream.Position := StartPos; 211 | 212 | if bufSiz < $40 then 213 | begin 214 | stream.read(DeltaBuf^, bufSiz); 215 | p := DeltaBuf; 216 | end 217 | else 218 | while bufSiz >= $40 do 219 | begin 220 | if Rest = 0 then 221 | begin 222 | if bufSiz >= deltaSize then 223 | Rest := deltaSize 224 | else 225 | Rest := bufSiz; 226 | stream.ReadBuffer(DeltaBuf^, Rest); 227 | 228 | p := DeltaBuf; 229 | end; 230 | MD5_Transform(Digest, p^); 231 | inc(p, $40); 232 | dec(bufSiz, $40); 233 | dec(Rest, $40); 234 | end; 235 | 236 | if bufSiz > 0 then 237 | CopyPtr(p, @ChunkBuff[0], bufSiz); 238 | 239 | FreeMemory(DeltaBuf); 240 | 241 | Result := PMD5(@Digest[0])^; 242 | ChunkBuff[bufSiz] := $80; 243 | ChunkIndex := bufSiz + 1; 244 | if ChunkIndex > $38 then 245 | begin 246 | if ChunkIndex < $40 then 247 | FillPtrByte(@ChunkBuff[ChunkIndex], $40 - ChunkIndex, 0); 248 | MD5_Transform(Result, ChunkBuff); 249 | ChunkIndex := 0 250 | end; 251 | FillPtrByte(@ChunkBuff[ChunkIndex], $38 - ChunkIndex, 0); 252 | PCardinal(@ChunkBuff[$38])^ := Lo; 253 | PCardinal(@ChunkBuff[$3C])^ := Hi; 254 | MD5_Transform(Result, ChunkBuff); 255 | end; 256 | 257 | {$ELSE} 258 | 259 | 260 | function FastMD5(const buffPtr: PByte; bufSiz: nativeUInt): TMD5; 261 | begin 262 | Result := umlMD5(buffPtr, bufSiz); 263 | end; 264 | 265 | function FastMD5(stream: TCoreClassStream; StartPos, EndPos: Int64): TMD5; 266 | begin 267 | Result := umlStreamMD5(stream, StartPos, EndPos); 268 | end; 269 | 270 | {$ENDIF Defined(MSWINDOWS) and Defined(Delphi)} 271 | 272 | end. 273 | -------------------------------------------------------------------------------- /Source/LinearAction.pas: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { * linear action written by QQ 600585@qq.com * } 3 | { * https://zpascal.net * } 4 | { * https://github.com/PassByYou888/zAI * } 5 | { * https://github.com/PassByYou888/ZServer4D * } 6 | { * https://github.com/PassByYou888/PascalString * } 7 | { * https://github.com/PassByYou888/zRasterization * } 8 | { * https://github.com/PassByYou888/CoreCipher * } 9 | { * https://github.com/PassByYou888/zSound * } 10 | { * https://github.com/PassByYou888/zChinese * } 11 | { * https://github.com/PassByYou888/zExpression * } 12 | { * https://github.com/PassByYou888/zGameWare * } 13 | { * https://github.com/PassByYou888/zAnalysis * } 14 | { * https://github.com/PassByYou888/FFMPEG-Header * } 15 | { * https://github.com/PassByYou888/zTranslate * } 16 | { * https://github.com/PassByYou888/InfiniteIoT * } 17 | { * https://github.com/PassByYou888/FastMD5 * } 18 | { ****************************************************************************** } 19 | unit LinearAction; 20 | 21 | {$INCLUDE zDefine.inc} 22 | 23 | interface 24 | 25 | uses CoreClasses, DoStatusIO, PascalStrings, UnicodeMixedLib; 26 | 27 | type 28 | TCoreActionID = Integer; 29 | TCoreActionString = SystemString; 30 | TCoreActionState = (asPlaying, asPause, asStop, asOver); 31 | TCoreActionStates = set of TCoreActionState; 32 | TCoreAction = class; 33 | TCoreActionList = class; 34 | TCoreActionLinear = class; 35 | 36 | TCoreAction = class(TCoreClassObject) 37 | public 38 | Owner: TCoreActionList; 39 | State: TCoreActionStates; 40 | ID: TCoreActionID; 41 | Desc: TCoreActionString; 42 | 43 | constructor Create(Owner_: TCoreActionList); virtual; 44 | destructor Destroy; override; 45 | 46 | procedure Run(); virtual; 47 | procedure Over(); virtual; 48 | procedure Stop(); virtual; 49 | procedure Pause(); virtual; 50 | procedure Progress(deltaTime: Double); virtual; 51 | end; 52 | 53 | TCoreActionClass = class of TCoreAction; 54 | 55 | TCoreActionList = class(TCoreClassObject) 56 | protected 57 | FSequenceList: TCoreClassListForObj; 58 | FFocusIndex: Integer; 59 | FLast: TCoreAction; 60 | public 61 | Owner: TCoreActionLinear; 62 | constructor Create(Owner_: TCoreActionLinear); 63 | destructor Destroy; override; 64 | procedure Clear; 65 | function Add(ActionClass_: TCoreActionClass): TCoreAction; overload; 66 | procedure Run(); 67 | procedure Over(); 68 | procedure Stop(); 69 | function IsOver(): Boolean; 70 | function IsStop(): Boolean; 71 | property Last: TCoreAction read FLast; 72 | procedure Progress(deltaTime: Double); 73 | end; 74 | 75 | TCoreActionLinear = class(TCoreClassObject) 76 | protected 77 | FSequenceList: TCoreClassListForObj; 78 | FFocusIndex: Integer; 79 | FLast: TCoreActionList; 80 | public 81 | constructor Create(); 82 | destructor Destroy; override; 83 | procedure Clear; 84 | function Add: TCoreActionList; 85 | procedure Run(); 86 | procedure Stop(); 87 | procedure Over(); 88 | property Last: TCoreActionList read FLast; 89 | procedure Progress(deltaTime: Double); 90 | 91 | class procedure Test(); 92 | end; 93 | 94 | implementation 95 | 96 | constructor TCoreAction.Create(Owner_: TCoreActionList); 97 | begin 98 | inherited Create; 99 | Owner := Owner_; 100 | State := []; 101 | ID := 0; 102 | Desc := ''; 103 | end; 104 | 105 | destructor TCoreAction.Destroy; 106 | begin 107 | inherited Destroy; 108 | end; 109 | 110 | procedure TCoreAction.Run; 111 | begin 112 | State := [asPlaying]; 113 | end; 114 | 115 | procedure TCoreAction.Over; 116 | begin 117 | if asPlaying in State then 118 | State := [asOver]; 119 | end; 120 | 121 | procedure TCoreAction.Stop; 122 | begin 123 | if asPlaying in State then 124 | State := [asStop]; 125 | end; 126 | 127 | procedure TCoreAction.Pause; 128 | begin 129 | if asPlaying in State then 130 | State := [asPlaying, asPause]; 131 | end; 132 | 133 | procedure TCoreAction.Progress(deltaTime: Double); 134 | begin 135 | 136 | end; 137 | 138 | constructor TCoreActionList.Create(Owner_: TCoreActionLinear); 139 | begin 140 | inherited Create; 141 | FSequenceList := TCoreClassListForObj.Create; 142 | FFocusIndex := -1; 143 | FLast := nil; 144 | Owner := Owner_; 145 | end; 146 | 147 | destructor TCoreActionList.Destroy; 148 | begin 149 | Clear; 150 | DisposeObject(FSequenceList); 151 | inherited Destroy; 152 | end; 153 | 154 | procedure TCoreActionList.Clear; 155 | var 156 | i: Integer; 157 | begin 158 | for i := FSequenceList.Count - 1 downto 0 do 159 | DisposeObject(FSequenceList[i]); 160 | FSequenceList.Clear; 161 | end; 162 | 163 | function TCoreActionList.Add(ActionClass_: TCoreActionClass): TCoreAction; 164 | begin 165 | Result := ActionClass_.Create(Self); 166 | FSequenceList.Add(Result); 167 | end; 168 | 169 | procedure TCoreActionList.Run(); 170 | begin 171 | if FSequenceList.Count > 0 then 172 | begin 173 | FFocusIndex := 0; 174 | FLast := FSequenceList[FFocusIndex] as TCoreAction; 175 | end 176 | else 177 | begin 178 | FFocusIndex := -1; 179 | FLast := nil; 180 | end; 181 | end; 182 | 183 | procedure TCoreActionList.Over; 184 | begin 185 | if FLast <> nil then 186 | FFocusIndex := FSequenceList.Count; 187 | end; 188 | 189 | procedure TCoreActionList.Stop; 190 | begin 191 | if FLast <> nil then 192 | FFocusIndex := -1; 193 | end; 194 | 195 | function TCoreActionList.IsOver: Boolean; 196 | begin 197 | Result := FFocusIndex >= FSequenceList.Count; 198 | end; 199 | 200 | function TCoreActionList.IsStop: Boolean; 201 | begin 202 | Result := FFocusIndex < 0; 203 | end; 204 | 205 | procedure TCoreActionList.Progress(deltaTime: Double); 206 | begin 207 | if (FFocusIndex < 0) or (FFocusIndex >= FSequenceList.Count) then 208 | Exit; 209 | 210 | FLast := FSequenceList[FFocusIndex] as TCoreAction; 211 | 212 | if FLast.State = [] then 213 | begin 214 | FLast.Run; 215 | Exit; 216 | end; 217 | 218 | if asPlaying in FLast.State then 219 | begin 220 | FLast.Progress(deltaTime); 221 | Exit; 222 | end; 223 | 224 | if asStop in FLast.State then 225 | begin 226 | FFocusIndex := -1; 227 | if Owner <> nil then 228 | Owner.Stop; 229 | Exit; 230 | end; 231 | 232 | if asOver in FLast.State then 233 | begin 234 | inc(FFocusIndex); 235 | if (FFocusIndex >= FSequenceList.Count) and (Owner <> nil) then 236 | Owner.Over; 237 | Exit; 238 | end; 239 | end; 240 | 241 | constructor TCoreActionLinear.Create(); 242 | begin 243 | inherited Create; 244 | FSequenceList := TCoreClassListForObj.Create; 245 | FFocusIndex := -1; 246 | FLast := nil; 247 | end; 248 | 249 | destructor TCoreActionLinear.Destroy; 250 | begin 251 | Clear; 252 | DisposeObject(FSequenceList); 253 | inherited Destroy; 254 | end; 255 | 256 | procedure TCoreActionLinear.Clear; 257 | var 258 | i: Integer; 259 | begin 260 | for i := FSequenceList.Count - 1 downto 0 do 261 | DisposeObject(FSequenceList[i]); 262 | FSequenceList.Clear; 263 | FFocusIndex := -1; 264 | FLast := nil; 265 | end; 266 | 267 | function TCoreActionLinear.Add: TCoreActionList; 268 | begin 269 | Result := TCoreActionList.Create(Self); 270 | FSequenceList.Add(Result); 271 | end; 272 | 273 | procedure TCoreActionLinear.Run; 274 | begin 275 | if FSequenceList.Count > 0 then 276 | begin 277 | FFocusIndex := 0; 278 | FLast := FSequenceList[FFocusIndex] as TCoreActionList; 279 | end 280 | else 281 | begin 282 | FFocusIndex := -1; 283 | FLast := nil; 284 | end; 285 | end; 286 | 287 | procedure TCoreActionLinear.Stop; 288 | begin 289 | Clear; 290 | end; 291 | 292 | procedure TCoreActionLinear.Over; 293 | begin 294 | inc(FFocusIndex); 295 | if FFocusIndex < FSequenceList.Count then 296 | begin 297 | FLast := FSequenceList[FFocusIndex] as TCoreActionList; 298 | end 299 | else 300 | begin 301 | Clear; 302 | end; 303 | end; 304 | 305 | procedure TCoreActionLinear.Progress(deltaTime: Double); 306 | begin 307 | if FLast <> nil then 308 | FLast.Progress(deltaTime); 309 | end; 310 | 311 | class procedure TCoreActionLinear.Test(); 312 | var 313 | al: TCoreActionList; 314 | i: Integer; 315 | begin 316 | al := TCoreActionList.Create(nil); 317 | for i := 1 to 2 do 318 | with al.Add(TCoreAction) do 319 | begin 320 | ID := i; 321 | Desc := PFormat('description %d', [i]); 322 | end; 323 | al.Run; 324 | while True do 325 | begin 326 | al.Progress(0.1); 327 | al.Last.Over; 328 | if al.IsOver or al.IsStop then 329 | Break; 330 | end; 331 | 332 | DisposeObject(al); 333 | end; 334 | 335 | end. 336 | -------------------------------------------------------------------------------- /Source/MH.pas: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { * Low MemoryHook written by QQ 600585@qq.com * } 3 | { * https://zpascal.net * } 4 | { * https://github.com/PassByYou888/zAI * } 5 | { * https://github.com/PassByYou888/ZServer4D * } 6 | { * https://github.com/PassByYou888/PascalString * } 7 | { * https://github.com/PassByYou888/zRasterization * } 8 | { * https://github.com/PassByYou888/CoreCipher * } 9 | { * https://github.com/PassByYou888/zSound * } 10 | { * https://github.com/PassByYou888/zChinese * } 11 | { * https://github.com/PassByYou888/zExpression * } 12 | { * https://github.com/PassByYou888/zGameWare * } 13 | { * https://github.com/PassByYou888/zAnalysis * } 14 | { * https://github.com/PassByYou888/FFMPEG-Header * } 15 | { * https://github.com/PassByYou888/zTranslate * } 16 | { * https://github.com/PassByYou888/InfiniteIoT * } 17 | { * https://github.com/PassByYou888/FastMD5 * } 18 | { ****************************************************************************** } 19 | 20 | (* 21 | update history 22 | 2017-12-31 23 | *) 24 | 25 | unit MH; 26 | 27 | {$INCLUDE zDefine.inc} 28 | 29 | interface 30 | 31 | uses CoreClasses, SyncObjs, ListEngine; 32 | 33 | procedure BeginMemoryHook_1; 34 | procedure EndMemoryHook_1; 35 | function GetHookMemorySize_1: nativeUInt; 36 | function GetHookPtrList_1: TPointerHashNativeUIntList; 37 | 38 | procedure BeginMemoryHook_2; 39 | procedure EndMemoryHook_2; 40 | function GetHookMemorySize_2: nativeUInt; 41 | function GetHookPtrList_2: TPointerHashNativeUIntList; 42 | 43 | procedure BeginMemoryHook_3; 44 | procedure EndMemoryHook_3; 45 | function GetHookMemorySize_3: nativeUInt; 46 | function GetHookPtrList_3: TPointerHashNativeUIntList; 47 | 48 | implementation 49 | 50 | uses MH_ZDB, MH_1, MH_2, MH_3, DoStatusIO, PascalStrings; 51 | 52 | procedure BeginMemoryHook_1; 53 | begin 54 | MH_1.BeginMemoryHook($FFFF); 55 | end; 56 | 57 | procedure EndMemoryHook_1; 58 | begin 59 | MH_1.EndMemoryHook; 60 | end; 61 | 62 | function GetHookMemorySize_1: nativeUInt; 63 | begin 64 | Result := MH_1.GetHookMemorySize; 65 | end; 66 | 67 | function GetHookPtrList_1: TPointerHashNativeUIntList; 68 | begin 69 | Result := MH_1.GetHookPtrList; 70 | end; 71 | 72 | procedure BeginMemoryHook_2; 73 | begin 74 | MH_2.BeginMemoryHook($FFFF); 75 | end; 76 | 77 | procedure EndMemoryHook_2; 78 | begin 79 | MH_2.EndMemoryHook; 80 | end; 81 | 82 | function GetHookMemorySize_2: nativeUInt; 83 | begin 84 | Result := MH_2.GetHookMemorySize; 85 | end; 86 | 87 | function GetHookPtrList_2: TPointerHashNativeUIntList; 88 | begin 89 | Result := MH_2.GetHookPtrList; 90 | end; 91 | 92 | procedure BeginMemoryHook_3; 93 | begin 94 | MH_3.BeginMemoryHook($FFFF); 95 | end; 96 | 97 | procedure EndMemoryHook_3; 98 | begin 99 | MH_3.EndMemoryHook; 100 | end; 101 | 102 | function GetHookMemorySize_3: nativeUInt; 103 | begin 104 | Result := MH_3.GetHookMemorySize; 105 | end; 106 | 107 | function GetHookPtrList_3: TPointerHashNativeUIntList; 108 | begin 109 | Result := MH_3.GetHookPtrList; 110 | end; 111 | 112 | var 113 | MHStatusCritical: TCriticalSection; 114 | OriginDoStatusHook: TDoStatusCall; 115 | 116 | procedure InternalDoStatus(Text: SystemString; const ID: Integer); 117 | var 118 | hook_state_bak: Boolean; 119 | begin 120 | hook_state_bak := GlobalMemoryHook.V; 121 | GlobalMemoryHook.V := False; 122 | MHStatusCritical.Acquire; 123 | try 124 | OriginDoStatusHook(Text, ID); 125 | finally 126 | MHStatusCritical.Release; 127 | GlobalMemoryHook.V := hook_state_bak; 128 | end; 129 | end; 130 | 131 | initialization 132 | 133 | MHStatusCritical := TCriticalSection.Create; 134 | OriginDoStatusHook := OnDoStatusHook; 135 | OnDoStatusHook := {$IFDEF FPC}@{$ENDIF FPC}InternalDoStatus; 136 | 137 | finalization 138 | 139 | DisposeObject(MHStatusCritical); 140 | OnDoStatusHook := OriginDoStatusHook; 141 | 142 | end. 143 | -------------------------------------------------------------------------------- /Source/MH_1.pas: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { * Low MemoryHook written by QQ 600585@qq.com * } 3 | { * https://zpascal.net * } 4 | { * https://github.com/PassByYou888/zAI * } 5 | { * https://github.com/PassByYou888/ZServer4D * } 6 | { * https://github.com/PassByYou888/PascalString * } 7 | { * https://github.com/PassByYou888/zRasterization * } 8 | { * https://github.com/PassByYou888/CoreCipher * } 9 | { * https://github.com/PassByYou888/zSound * } 10 | { * https://github.com/PassByYou888/zChinese * } 11 | { * https://github.com/PassByYou888/zExpression * } 12 | { * https://github.com/PassByYou888/zGameWare * } 13 | { * https://github.com/PassByYou888/zAnalysis * } 14 | { * https://github.com/PassByYou888/FFMPEG-Header * } 15 | { * https://github.com/PassByYou888/zTranslate * } 16 | { * https://github.com/PassByYou888/InfiniteIoT * } 17 | { * https://github.com/PassByYou888/FastMD5 * } 18 | { ****************************************************************************** } 19 | 20 | (* 21 | update history 22 | 2017-12-31 23 | *) 24 | 25 | unit MH_1; 26 | 27 | {$INCLUDE zDefine.inc} 28 | 29 | interface 30 | 31 | uses ListEngine, CoreClasses; 32 | 33 | procedure BeginMemoryHook; overload; 34 | procedure BeginMemoryHook(cacheLen: Integer); overload; 35 | procedure EndMemoryHook; 36 | function GetHookMemorySize: nativeUInt; overload; 37 | function GetHookMemorySize(p: Pointer): nativeUInt; overload; 38 | function GetHookMemoryMinimizePtr: Pointer; 39 | function GetHookMemoryMaximumPtr: Pointer; 40 | function GetHookPtrList: TPointerHashNativeUIntList; 41 | function GetMemoryHooked: TAtomBool; 42 | 43 | implementation 44 | 45 | var 46 | HookPtrList: TPointerHashNativeUIntList; 47 | MemoryHooked: TAtomBool; 48 | 49 | {$IFDEF FPC} 50 | {$INCLUDE MH_fpc.inc} 51 | {$ELSE} 52 | {$INCLUDE MH_delphi.inc} 53 | {$ENDIF} 54 | 55 | 56 | initialization 57 | 58 | InstallMemoryHook; 59 | 60 | finalization 61 | 62 | UnInstallMemoryHook; 63 | 64 | end. 65 | -------------------------------------------------------------------------------- /Source/MH_2.pas: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { * Low MemoryHook written by QQ 600585@qq.com * } 3 | { * https://zpascal.net * } 4 | { * https://github.com/PassByYou888/zAI * } 5 | { * https://github.com/PassByYou888/ZServer4D * } 6 | { * https://github.com/PassByYou888/PascalString * } 7 | { * https://github.com/PassByYou888/zRasterization * } 8 | { * https://github.com/PassByYou888/CoreCipher * } 9 | { * https://github.com/PassByYou888/zSound * } 10 | { * https://github.com/PassByYou888/zChinese * } 11 | { * https://github.com/PassByYou888/zExpression * } 12 | { * https://github.com/PassByYou888/zGameWare * } 13 | { * https://github.com/PassByYou888/zAnalysis * } 14 | { * https://github.com/PassByYou888/FFMPEG-Header * } 15 | { * https://github.com/PassByYou888/zTranslate * } 16 | { * https://github.com/PassByYou888/InfiniteIoT * } 17 | { * https://github.com/PassByYou888/FastMD5 * } 18 | { ****************************************************************************** } 19 | 20 | (* 21 | update history 22 | 2017-12-31 23 | *) 24 | 25 | unit MH_2; 26 | 27 | {$INCLUDE zDefine.inc} 28 | 29 | interface 30 | 31 | uses ListEngine, CoreClasses; 32 | 33 | procedure BeginMemoryHook; overload; 34 | procedure BeginMemoryHook(cacheLen: Integer); overload; 35 | procedure EndMemoryHook; 36 | function GetHookMemorySize: nativeUInt; overload; 37 | function GetHookMemorySize(p: Pointer): nativeUInt; overload; 38 | function GetHookMemoryMinimizePtr: Pointer; 39 | function GetHookMemoryMaximumPtr: Pointer; 40 | function GetHookPtrList: TPointerHashNativeUIntList; 41 | function GetMemoryHooked: TAtomBool; 42 | 43 | implementation 44 | 45 | var 46 | HookPtrList: TPointerHashNativeUIntList; 47 | MemoryHooked: TAtomBool; 48 | 49 | {$IFDEF FPC} 50 | {$INCLUDE MH_fpc.inc} 51 | {$ELSE} 52 | {$INCLUDE MH_delphi.inc} 53 | {$ENDIF} 54 | 55 | initialization 56 | 57 | InstallMemoryHook; 58 | 59 | finalization 60 | 61 | UnInstallMemoryHook; 62 | 63 | end. 64 | -------------------------------------------------------------------------------- /Source/MH_3.pas: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { * Low MemoryHook written by QQ 600585@qq.com * } 3 | { * https://zpascal.net * } 4 | { * https://github.com/PassByYou888/zAI * } 5 | { * https://github.com/PassByYou888/ZServer4D * } 6 | { * https://github.com/PassByYou888/PascalString * } 7 | { * https://github.com/PassByYou888/zRasterization * } 8 | { * https://github.com/PassByYou888/CoreCipher * } 9 | { * https://github.com/PassByYou888/zSound * } 10 | { * https://github.com/PassByYou888/zChinese * } 11 | { * https://github.com/PassByYou888/zExpression * } 12 | { * https://github.com/PassByYou888/zGameWare * } 13 | { * https://github.com/PassByYou888/zAnalysis * } 14 | { * https://github.com/PassByYou888/FFMPEG-Header * } 15 | { * https://github.com/PassByYou888/zTranslate * } 16 | { * https://github.com/PassByYou888/InfiniteIoT * } 17 | { * https://github.com/PassByYou888/FastMD5 * } 18 | { ****************************************************************************** } 19 | 20 | (* 21 | update history 22 | 2017-12-31 23 | *) 24 | 25 | unit MH_3; 26 | 27 | {$INCLUDE zDefine.inc} 28 | 29 | interface 30 | 31 | uses ListEngine, CoreClasses; 32 | 33 | procedure BeginMemoryHook; overload; 34 | procedure BeginMemoryHook(cacheLen: Integer); overload; 35 | procedure EndMemoryHook; 36 | function GetHookMemorySize: nativeUInt; overload; 37 | function GetHookMemorySize(p: Pointer): nativeUInt; overload; 38 | function GetHookMemoryMinimizePtr: Pointer; 39 | function GetHookMemoryMaximumPtr: Pointer; 40 | function GetHookPtrList: TPointerHashNativeUIntList; 41 | function GetMemoryHooked: TAtomBool; 42 | 43 | implementation 44 | 45 | var 46 | HookPtrList: TPointerHashNativeUIntList; 47 | MemoryHooked: TAtomBool; 48 | 49 | {$IFDEF FPC} 50 | {$INCLUDE MH_fpc.inc} 51 | {$ELSE} 52 | {$INCLUDE MH_delphi.inc} 53 | {$ENDIF} 54 | 55 | initialization 56 | 57 | InstallMemoryHook; 58 | 59 | finalization 60 | 61 | UnInstallMemoryHook; 62 | 63 | end. 64 | -------------------------------------------------------------------------------- /Source/MH_ZDB.pas: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { * Low MemoryHook written by QQ 600585@qq.com * } 3 | { * https://zpascal.net * } 4 | { * https://github.com/PassByYou888/zAI * } 5 | { * https://github.com/PassByYou888/ZServer4D * } 6 | { * https://github.com/PassByYou888/PascalString * } 7 | { * https://github.com/PassByYou888/zRasterization * } 8 | { * https://github.com/PassByYou888/CoreCipher * } 9 | { * https://github.com/PassByYou888/zSound * } 10 | { * https://github.com/PassByYou888/zChinese * } 11 | { * https://github.com/PassByYou888/zExpression * } 12 | { * https://github.com/PassByYou888/zGameWare * } 13 | { * https://github.com/PassByYou888/zAnalysis * } 14 | { * https://github.com/PassByYou888/FFMPEG-Header * } 15 | { * https://github.com/PassByYou888/zTranslate * } 16 | { * https://github.com/PassByYou888/InfiniteIoT * } 17 | { * https://github.com/PassByYou888/FastMD5 * } 18 | { ****************************************************************************** } 19 | 20 | (* 21 | update history 22 | 2017-12-31 23 | *) 24 | 25 | unit MH_ZDB; 26 | 27 | {$INCLUDE zDefine.inc} 28 | 29 | interface 30 | 31 | uses ListEngine, CoreClasses; 32 | 33 | procedure BeginMemoryHook; overload; 34 | procedure BeginMemoryHook(cacheLen: Integer); overload; 35 | procedure EndMemoryHook; 36 | function GetHookMemorySize: nativeUInt; overload; 37 | function GetHookMemorySize(p: Pointer): nativeUInt; overload; 38 | function GetHookMemoryMinimizePtr: Pointer; 39 | function GetHookMemoryMaximumPtr: Pointer; 40 | function GetHookPtrList: TPointerHashNativeUIntList; 41 | function GetMemoryHooked: TAtomBool; 42 | 43 | implementation 44 | 45 | var 46 | HookPtrList: TPointerHashNativeUIntList; 47 | MemoryHooked: TAtomBool; 48 | 49 | {$IFDEF FPC} 50 | {$INCLUDE MH_fpc.inc} 51 | {$ELSE} 52 | {$INCLUDE MH_delphi.inc} 53 | {$ENDIF} 54 | 55 | initialization 56 | 57 | InstallMemoryHook; 58 | 59 | finalization 60 | 61 | UnInstallMemoryHook; 62 | 63 | end. 64 | -------------------------------------------------------------------------------- /Source/MH_delphi.inc: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { * https://zpascal.net * } 3 | { * https://github.com/PassByYou888/zAI * } 4 | { * https://github.com/PassByYou888/ZServer4D * } 5 | { * https://github.com/PassByYou888/PascalString * } 6 | { * https://github.com/PassByYou888/zRasterization * } 7 | { * https://github.com/PassByYou888/CoreCipher * } 8 | { * https://github.com/PassByYou888/zSound * } 9 | { * https://github.com/PassByYou888/zChinese * } 10 | { * https://github.com/PassByYou888/zExpression * } 11 | { * https://github.com/PassByYou888/zGameWare * } 12 | { * https://github.com/PassByYou888/zAnalysis * } 13 | { * https://github.com/PassByYou888/FFMPEG-Header * } 14 | { * https://github.com/PassByYou888/zTranslate * } 15 | { * https://github.com/PassByYou888/InfiniteIoT * } 16 | { * https://github.com/PassByYou888/FastMD5 * } 17 | { ****************************************************************************** } 18 | type 19 | MPtrUInt = nativeUInt; 20 | MPtr = Pointer; 21 | PMPtrUInt = ^MPtrUInt; 22 | 23 | var 24 | OriginMM: TMemoryManagerEx; 25 | HookMM: TMemoryManagerEx; 26 | CurrentHookThread: TCoreClassThread; 27 | 28 | procedure BeginMemoryHook; 29 | begin 30 | if (MemoryHooked.V) or (CurrentHookThread <> nil) then 31 | RaiseInfo('illegal BeginMemoryHook'); 32 | 33 | CurrentHookThread := TCoreClassThread.CurrentThread; 34 | HookPtrList.FastClear; 35 | MemoryHooked.V := True; 36 | end; 37 | 38 | procedure BeginMemoryHook(cacheLen: Integer); 39 | begin 40 | if (MemoryHooked.V) or (CurrentHookThread <> nil) then 41 | RaiseInfo('illegal BeginMemoryHook'); 42 | 43 | CurrentHookThread := TCoreClassThread.CurrentThread; 44 | if length(HookPtrList.ListBuffer^) <> cacheLen then 45 | HookPtrList.SetHashBlockCount(cacheLen) 46 | else 47 | HookPtrList.FastClear; 48 | 49 | MemoryHooked.V := True; 50 | end; 51 | 52 | procedure EndMemoryHook; 53 | begin 54 | if not MemoryHooked.V then 55 | RaiseInfo('illegal EndMemoryHook'); 56 | 57 | MemoryHooked.V := False; 58 | CurrentHookThread := nil; 59 | end; 60 | 61 | function GetHookMemorySize: nativeUInt; 62 | begin 63 | Result := HookPtrList.Total; 64 | end; 65 | 66 | function GetHookMemorySize(p: Pointer): nativeUInt; 67 | begin 68 | Result := HookPtrList[p]; 69 | end; 70 | 71 | function GetHookMemoryMinimizePtr: Pointer; 72 | begin 73 | Result := HookPtrList.MinimizePtr; 74 | end; 75 | 76 | function GetHookMemoryMaximumPtr: Pointer; 77 | begin 78 | Result := HookPtrList.MaximumPtr; 79 | end; 80 | 81 | function GetHookPtrList: TPointerHashNativeUIntList; 82 | begin 83 | Result := HookPtrList; 84 | end; 85 | 86 | function GetMemoryHooked: TAtomBool; 87 | begin 88 | Result := MemoryHooked; 89 | end; 90 | 91 | function Hash_GetMem(Size: NativeInt): MPtr; 92 | begin 93 | Result := OriginMM.GetMem(DeltaStep(Size, C_MH_MemoryDelta)); 94 | if (not MemoryHooked.V) or (not GlobalMemoryHook.V) or (Result = nil) or (CurrentHookThread <> TCoreClassThread.CurrentThread) then 95 | Exit; 96 | MemoryHooked.V := False; 97 | GlobalMemoryHook.V := False; 98 | HookPtrList.Add(Result, Size, False); 99 | MemoryHooked.V := True; 100 | GlobalMemoryHook.V := True; 101 | end; 102 | 103 | function Hash_FreeMem(p: MPtr): Integer; 104 | begin 105 | Result := OriginMM.FreeMem(p); 106 | if (not MemoryHooked.V) or (not GlobalMemoryHook.V) or (p = nil) or (CurrentHookThread <> TCoreClassThread.CurrentThread) then 107 | Exit; 108 | MemoryHooked.V := False; 109 | GlobalMemoryHook.V := False; 110 | HookPtrList.Delete(p); 111 | MemoryHooked.V := True; 112 | GlobalMemoryHook.V := True; 113 | end; 114 | 115 | function Hash_ReallocMem(p: MPtr; Size: NativeInt): MPtr; 116 | begin 117 | Result := OriginMM.ReallocMem(p, DeltaStep(Size, C_MH_MemoryDelta)); 118 | if (not MemoryHooked.V) or (not GlobalMemoryHook.V) or (CurrentHookThread <> TCoreClassThread.CurrentThread) then 119 | Exit; 120 | MemoryHooked.V := False; 121 | GlobalMemoryHook.V := False; 122 | if p <> nil then 123 | begin 124 | if HookPtrList.Delete(p) then 125 | if Result <> nil then 126 | HookPtrList.Add(Result, Size, False); 127 | end 128 | else if Result <> nil then 129 | HookPtrList.Add(Result, Size, False); 130 | MemoryHooked.V := True; 131 | GlobalMemoryHook.V := True; 132 | end; 133 | 134 | function Hash_AllocMem(Size: NativeInt): MPtr; 135 | begin 136 | Result := OriginMM.AllocMem(DeltaStep(Size, C_MH_MemoryDelta)); 137 | if (not MemoryHooked.V) or (not GlobalMemoryHook.V) or (Result = nil) or (CurrentHookThread <> TCoreClassThread.CurrentThread) then 138 | Exit; 139 | MemoryHooked.V := False; 140 | GlobalMemoryHook.V := False; 141 | HookPtrList.Add(Result, Size, False); 142 | MemoryHooked.V := True; 143 | GlobalMemoryHook.V := True; 144 | end; 145 | 146 | procedure InstallMemoryHook; 147 | begin 148 | HookPtrList := TPointerHashNativeUIntList.CustomCreate(32); 149 | CurrentHookThread := nil; 150 | 151 | GetMemoryManager(OriginMM); 152 | HookMM := OriginMM; 153 | 154 | MemoryHooked := TAtomBool.Create(False); 155 | 156 | HookMM.GetMem := Hash_GetMem; 157 | HookMM.FreeMem := Hash_FreeMem; 158 | HookMM.ReallocMem := Hash_ReallocMem; 159 | HookMM.AllocMem := Hash_AllocMem; 160 | 161 | SetMemoryManager(HookMM); 162 | end; 163 | 164 | procedure UnInstallMemoryHook; 165 | begin 166 | SetMemoryManager(OriginMM); 167 | DisposeObject(HookPtrList); 168 | MemoryHooked.Free; 169 | MemoryHooked := nil; 170 | end; 171 | -------------------------------------------------------------------------------- /Source/MH_fpc.inc: -------------------------------------------------------------------------------- 1 | { * https://zpascal.net * } 2 | { * https://github.com/PassByYou888/zAI * } 3 | { * https://github.com/PassByYou888/ZServer4D * } 4 | { * https://github.com/PassByYou888/PascalString * } 5 | { * https://github.com/PassByYou888/zRasterization * } 6 | { * https://github.com/PassByYou888/CoreCipher * } 7 | { * https://github.com/PassByYou888/zSound * } 8 | { * https://github.com/PassByYou888/zChinese * } 9 | { * https://github.com/PassByYou888/zExpression * } 10 | { * https://github.com/PassByYou888/zGameWare * } 11 | { * https://github.com/PassByYou888/zAnalysis * } 12 | { * https://github.com/PassByYou888/FFMPEG-Header * } 13 | { * https://github.com/PassByYou888/zTranslate * } 14 | { * https://github.com/PassByYou888/InfiniteIoT * } 15 | { * https://github.com/PassByYou888/FastMD5 * } 16 | { ****************************************************************************** } 17 | 18 | type 19 | MPtrUInt = ptruint; 20 | MPtr = Pointer; 21 | PMPtrUInt = ^MPtrUInt; 22 | 23 | var 24 | OriginMM: TMemoryManager; 25 | HookMM: TMemoryManager; 26 | CurrentHookThread: TCoreClassThread; 27 | 28 | procedure BeginMemoryHook; 29 | begin 30 | if (MemoryHooked.V) or (CurrentHookThread <> nil) then 31 | RaiseInfo('illegal BeginMemoryHook'); 32 | 33 | CurrentHookThread := TCoreClassThread.CurrentThread; 34 | HookPtrList.FastClear; 35 | MemoryHooked.V := True; 36 | end; 37 | 38 | procedure BeginMemoryHook(cacheLen: Integer); 39 | begin 40 | if (MemoryHooked.V) or (CurrentHookThread <> nil) then 41 | RaiseInfo('illegal BeginMemoryHook'); 42 | 43 | CurrentHookThread := TCoreClassThread.CurrentThread; 44 | if length(HookPtrList.ListBuffer^) <> cacheLen then 45 | HookPtrList.SetHashBlockCount(cacheLen) 46 | else 47 | HookPtrList.FastClear; 48 | 49 | MemoryHooked.V := True; 50 | end; 51 | 52 | procedure EndMemoryHook; 53 | begin 54 | if not MemoryHooked.V then 55 | RaiseInfo('illegal EndMemoryHook'); 56 | 57 | MemoryHooked.V := False; 58 | CurrentHookThread := nil; 59 | end; 60 | 61 | function GetHookMemorySize: nativeUInt; 62 | begin 63 | Result := HookPtrList.Total; 64 | end; 65 | 66 | function GetHookMemorySize(p: Pointer): nativeUInt; 67 | begin 68 | Result := HookPtrList[p]; 69 | end; 70 | 71 | function GetHookMemoryMinimizePtr: Pointer; 72 | begin 73 | Result := HookPtrList.MinimizePtr; 74 | end; 75 | 76 | function GetHookMemoryMaximumPtr: Pointer; 77 | begin 78 | Result := HookPtrList.MaximumPtr; 79 | end; 80 | 81 | function GetHookPtrList: TPointerHashNativeUIntList; 82 | begin 83 | Result := HookPtrList; 84 | end; 85 | 86 | function GetMemoryHooked: TAtomBool; 87 | begin 88 | Result := MemoryHooked; 89 | end; 90 | 91 | function Hash_GetMem(Size: ptruint): Pointer; 92 | begin 93 | Result := OriginMM.GetMem(DeltaStep(Size, C_MH_MemoryDelta)); 94 | if (not MemoryHooked.V) or (not GlobalMemoryHook.V) or (Result = nil) or (CurrentHookThread <> TCoreClassThread.CurrentThread) then 95 | Exit; 96 | MemoryHooked.V := False; 97 | GlobalMemoryHook.V := False; 98 | HookPtrList.Add(Result, Size, False); 99 | MemoryHooked.V := True; 100 | GlobalMemoryHook.V := True; 101 | end; 102 | 103 | function Hash_FreeMem(p: Pointer): ptruint; 104 | begin 105 | Result := OriginMM.FreeMem(p); 106 | if (not MemoryHooked.V) or (not GlobalMemoryHook.V) or (p = nil) or (CurrentHookThread <> TCoreClassThread.CurrentThread) then 107 | Exit; 108 | MemoryHooked.V := False; 109 | GlobalMemoryHook.V := False; 110 | HookPtrList.Delete(p); 111 | MemoryHooked.V := True; 112 | GlobalMemoryHook.V := True; 113 | end; 114 | 115 | function Hash_FreememSize(p: Pointer; Size: ptruint): ptruint; 116 | begin 117 | Result := OriginMM.FreememSize(p, DeltaStep(Size, C_MH_MemoryDelta)); 118 | if (not MemoryHooked.V) or (not GlobalMemoryHook.V) or (p = nil) or (CurrentHookThread <> TCoreClassThread.CurrentThread) then 119 | Exit; 120 | MemoryHooked.V := False; 121 | GlobalMemoryHook.V := False; 122 | HookPtrList.Delete(p); 123 | MemoryHooked.V := True; 124 | GlobalMemoryHook.V := True; 125 | end; 126 | 127 | function Hash_AllocMem(Size: ptruint): Pointer; 128 | begin 129 | Result := OriginMM.AllocMem(DeltaStep(Size, C_MH_MemoryDelta)); 130 | if (not MemoryHooked.V) or (not GlobalMemoryHook.V) or (Result = nil) or (CurrentHookThread <> TCoreClassThread.CurrentThread) then 131 | Exit; 132 | MemoryHooked.V := False; 133 | GlobalMemoryHook.V := False; 134 | HookPtrList.Add(Result, Size, True); 135 | MemoryHooked.V := True; 136 | GlobalMemoryHook.V := True; 137 | end; 138 | 139 | function Hash_ReallocMem(var p: Pointer; Size: ptruint): Pointer; 140 | begin 141 | Result := OriginMM.ReallocMem(p, DeltaStep(Size, C_MH_MemoryDelta)); 142 | if (not MemoryHooked.V) or (not GlobalMemoryHook.V) or (CurrentHookThread <> TCoreClassThread.CurrentThread) then 143 | Exit; 144 | MemoryHooked.V := False; 145 | GlobalMemoryHook.V := False; 146 | if p <> nil then 147 | begin 148 | if HookPtrList.Delete(p) then 149 | if Result <> nil then 150 | HookPtrList.Add(Result, Size, False); 151 | end 152 | else if Result <> nil then 153 | HookPtrList.Add(Result, Size, False); 154 | MemoryHooked.V := True; 155 | GlobalMemoryHook.V := True; 156 | end; 157 | 158 | procedure InstallMemoryHook; 159 | begin 160 | HookPtrList := TPointerHashNativeUIntList.CustomCreate(32); 161 | CurrentHookThread := nil; 162 | 163 | GetMemoryManager(OriginMM); 164 | HookMM := OriginMM; 165 | 166 | MemoryHooked := TAtomBool.Create(False); 167 | 168 | HookMM.GetMem := @Hash_GetMem; 169 | HookMM.FreeMem := @Hash_FreeMem; 170 | HookMM.FreememSize := @Hash_FreememSize; 171 | HookMM.AllocMem := @Hash_AllocMem; 172 | HookMM.ReallocMem := @Hash_ReallocMem; 173 | 174 | SetMemoryManager(HookMM); 175 | end; 176 | 177 | procedure UnInstallMemoryHook; 178 | begin 179 | SetMemoryManager(OriginMM); 180 | DisposeObject(HookPtrList); 181 | MemoryHooked.Free; 182 | MemoryHooked := nil; 183 | end; 184 | -------------------------------------------------------------------------------- /Source/ZJson_delphi.inc: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { * json object library for delphi/objfpc * } 3 | { * https://zpascal.net * } 4 | { * https://github.com/PassByYou888/zAI * } 5 | { * https://github.com/PassByYou888/ZServer4D * } 6 | { * https://github.com/PassByYou888/PascalString * } 7 | { * https://github.com/PassByYou888/zRasterization * } 8 | { * https://github.com/PassByYou888/CoreCipher * } 9 | { * https://github.com/PassByYou888/zSound * } 10 | { * https://github.com/PassByYou888/zChinese * } 11 | { * https://github.com/PassByYou888/zExpression * } 12 | { * https://github.com/PassByYou888/zGameWare * } 13 | { * https://github.com/PassByYou888/zAnalysis * } 14 | { * https://github.com/PassByYou888/FFMPEG-Header * } 15 | { * https://github.com/PassByYou888/zTranslate * } 16 | { * https://github.com/PassByYou888/InfiniteIoT * } 17 | { * https://github.com/PassByYou888/FastMD5 * } 18 | { ****************************************************************************** } 19 | 20 | procedure TZ_JsonArray.Clear; 21 | begin 22 | FInstance.Clear; 23 | end; 24 | 25 | procedure TZ_JsonArray.Delete(Index: Integer); 26 | begin 27 | FInstance.Delete(index); 28 | end; 29 | 30 | procedure TZ_JsonArray.Add(const v_: string); 31 | begin 32 | FInstance.Add(v_); 33 | end; 34 | 35 | procedure TZ_JsonArray.Add(const v_: TPascalString); 36 | begin 37 | FInstance.Add(v_.Text); 38 | end; 39 | 40 | procedure TZ_JsonArray.Add(const v_: Integer); 41 | begin 42 | FInstance.Add(v_); 43 | end; 44 | 45 | procedure TZ_JsonArray.Add(const v_: Int64); 46 | begin 47 | FInstance.Add(v_); 48 | end; 49 | 50 | procedure TZ_JsonArray.Add(const v_: UInt64); 51 | begin 52 | FInstance.Add(v_); 53 | end; 54 | 55 | procedure TZ_JsonArray.AddF(const v_: Double); 56 | begin 57 | FInstance.Add(v_); 58 | end; 59 | 60 | procedure TZ_JsonArray.Add(const v_: TDateTime); 61 | begin 62 | FInstance.Add(umlDateTimeToStr(v_).Text); 63 | end; 64 | 65 | procedure TZ_JsonArray.Add(const v_: Boolean); 66 | begin 67 | FInstance.Add(v_); 68 | end; 69 | 70 | function TZ_JsonArray.AddArray: TZ_JsonArray; 71 | begin 72 | Result := TZ_JsonArray.Create(self); 73 | Result.FInstance := FInstance.AddArray; 74 | end; 75 | 76 | function TZ_JsonArray.AddObject: TZ_JsonObject; 77 | begin 78 | Result := TZ_JsonObject.Create(self); 79 | Result.FInstance := FInstance.AddObject; 80 | end; 81 | 82 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: string); 83 | begin 84 | FInstance.Insert(index, v_); 85 | end; 86 | 87 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: Integer); 88 | begin 89 | FInstance.Insert(index, v_); 90 | end; 91 | 92 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: Int64); 93 | begin 94 | FInstance.Insert(index, v_); 95 | end; 96 | 97 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: UInt64); 98 | begin 99 | FInstance.Insert(index, v_); 100 | end; 101 | 102 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: Double); 103 | begin 104 | FInstance.Insert(index, v_); 105 | end; 106 | 107 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: TDateTime); 108 | begin 109 | FInstance.Insert(index, umlDateTimeToStr(v_).Text); 110 | end; 111 | 112 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: Boolean); 113 | begin 114 | FInstance.Insert(index, v_); 115 | end; 116 | 117 | function TZ_JsonArray.InsertArray(Index: Integer): TZ_JsonArray; 118 | begin 119 | Result := TZ_JsonArray.Create(self); 120 | Result.FInstance := FInstance.InsertArray(index); 121 | end; 122 | 123 | function TZ_JsonArray.InsertObject(Index: Integer): TZ_JsonObject; 124 | begin 125 | Result := TZ_JsonObject.Create(self); 126 | Result.FInstance := FInstance.InsertObject(index); 127 | end; 128 | 129 | function TZ_JsonArray.GetString(Index: Integer): string; 130 | begin 131 | Result := FInstance.S[index]; 132 | end; 133 | 134 | procedure TZ_JsonArray.SetString(Index: Integer; const Value: string); 135 | begin 136 | FInstance.S[index] := Value; 137 | end; 138 | 139 | function TZ_JsonArray.GetInt(Index: Integer): Integer; 140 | begin 141 | Result := FInstance.I[index]; 142 | end; 143 | 144 | procedure TZ_JsonArray.SetInt(Index: Integer; const Value: Integer); 145 | begin 146 | FInstance.I[index] := Value; 147 | end; 148 | 149 | function TZ_JsonArray.GetLong(Index: Integer): Int64; 150 | begin 151 | Result := FInstance.I64[index]; 152 | end; 153 | 154 | procedure TZ_JsonArray.SetLong(Index: Integer; const Value: Int64); 155 | begin 156 | FInstance.I64[index] := Value; 157 | end; 158 | 159 | function TZ_JsonArray.GetULong(Index: Integer): UInt64; 160 | begin 161 | Result := FInstance.U64[index]; 162 | end; 163 | 164 | procedure TZ_JsonArray.SetULong(Index: Integer; const Value: UInt64); 165 | begin 166 | FInstance.U64[index] := Value; 167 | end; 168 | 169 | function TZ_JsonArray.GetFloat(Index: Integer): Double; 170 | begin 171 | Result := FInstance.F[index]; 172 | end; 173 | 174 | procedure TZ_JsonArray.SetFloat(Index: Integer; const Value: Double); 175 | begin 176 | FInstance.F[index] := Value; 177 | end; 178 | 179 | function TZ_JsonArray.GetDateTime(Index: Integer): TDateTime; 180 | begin 181 | Result := umlStrToDateTime(FInstance.S[index]); 182 | end; 183 | 184 | procedure TZ_JsonArray.SetDateTime(Index: Integer; const Value: TDateTime); 185 | begin 186 | FInstance.S[index] := umlDateTimeToStr(Value).Text; 187 | end; 188 | 189 | function TZ_JsonArray.GetBool(Index: Integer): Boolean; 190 | begin 191 | Result := FInstance.B[index]; 192 | end; 193 | 194 | procedure TZ_JsonArray.SetBool(Index: Integer; const Value: Boolean); 195 | begin 196 | FInstance.B[index] := Value; 197 | end; 198 | 199 | function TZ_JsonArray.GetArray(Index: Integer): TZ_JsonArray; 200 | var 201 | arry: TZ_Instance_JsonArray; 202 | j: Integer; 203 | begin 204 | arry := FInstance.A[index]; 205 | for j := FList.Count - 1 downto 0 do 206 | if (FList[j] is TZ_JsonArray) and (TZ_JsonArray(FList[j]).FInstance = arry) then 207 | begin 208 | Result := TZ_JsonArray(FList[j]); 209 | exit; 210 | end; 211 | Result := TZ_JsonArray.Create(self); 212 | Result.FInstance := arry; 213 | end; 214 | 215 | function TZ_JsonArray.GetObject(Index: Integer): TZ_JsonObject; 216 | var 217 | Obj_: TZ_Instance_JsonObject; 218 | j: Integer; 219 | begin 220 | Obj_ := FInstance.O[Index]; 221 | for j := FList.Count - 1 downto 0 do 222 | if (FList[j] is TZ_JsonObject) and (TZ_JsonObject(FList[j]).FInstance = Obj_) then 223 | begin 224 | Result := TZ_JsonObject(FList[j]); 225 | exit; 226 | end; 227 | Result := TZ_JsonObject.Create(self); 228 | Result.FInstance := Obj_; 229 | end; 230 | 231 | function TZ_JsonArray.GetCount: Integer; 232 | begin 233 | Result := FInstance.Count; 234 | end; 235 | 236 | procedure TZ_JsonObject.Clear; 237 | begin 238 | FInstance.Clear; 239 | end; 240 | 241 | function TZ_JsonObject.IndexOf(const Name: string): Integer; 242 | begin 243 | Result := FInstance.IndexOf(Name); 244 | end; 245 | 246 | function TZ_JsonObject.GetString(const Name: string): string; 247 | begin 248 | Result := FInstance.S[Name]; 249 | end; 250 | 251 | procedure TZ_JsonObject.SetString(const Name, Value: string); 252 | begin 253 | FInstance.S[Name] := Value; 254 | end; 255 | 256 | function TZ_JsonObject.GetInt(const Name: string): Integer; 257 | begin 258 | Result := FInstance.I[Name]; 259 | end; 260 | 261 | procedure TZ_JsonObject.SetInt(const Name: string; const Value: Integer); 262 | begin 263 | FInstance.I[Name] := Value; 264 | end; 265 | 266 | function TZ_JsonObject.GetLong(const Name: string): Int64; 267 | begin 268 | Result := FInstance.I64[Name]; 269 | end; 270 | 271 | procedure TZ_JsonObject.SetLong(const Name: string; const Value: Int64); 272 | begin 273 | FInstance.I64[Name] := Value; 274 | end; 275 | 276 | function TZ_JsonObject.GetULong(const Name: string): UInt64; 277 | begin 278 | Result := FInstance.U[Name]; 279 | end; 280 | 281 | procedure TZ_JsonObject.SetULong(const Name: string; const Value: UInt64); 282 | begin 283 | FInstance.U[Name] := Value; 284 | end; 285 | 286 | function TZ_JsonObject.GetFloat(const Name: string): Double; 287 | begin 288 | Result := FInstance.F[Name]; 289 | end; 290 | 291 | procedure TZ_JsonObject.SetFloat(const Name: string; const Value: Double); 292 | begin 293 | FInstance.F[Name] := Value; 294 | end; 295 | 296 | function TZ_JsonObject.GetDateTime(const Name: string): TDateTime; 297 | begin 298 | Result := umlStrToDateTime(FInstance.S[Name]); 299 | end; 300 | 301 | procedure TZ_JsonObject.SetDateTime(const Name: string; const Value: TDateTime); 302 | begin 303 | FInstance.S[Name] := umlDateTimeToStr(Value).Text; 304 | end; 305 | 306 | function TZ_JsonObject.GetBool(const Name: string): Boolean; 307 | begin 308 | Result := FInstance.B[Name]; 309 | end; 310 | 311 | procedure TZ_JsonObject.SetBool(const Name: string; const Value: Boolean); 312 | begin 313 | FInstance.B[Name] := Value; 314 | end; 315 | 316 | function TZ_JsonObject.GetArray(const Name: string): TZ_JsonArray; 317 | var 318 | arry: TZ_Instance_JsonArray; 319 | j: Integer; 320 | begin 321 | arry := FInstance.A[Name]; 322 | for j := FList.Count - 1 downto 0 do 323 | if (FList[j] is TZ_JsonArray) and (TZ_JsonArray(FList[j]).FInstance = arry) then 324 | begin 325 | Result := TZ_JsonArray(FList[j]); 326 | exit; 327 | end; 328 | Result := TZ_JsonArray.Create(self); 329 | Result.FInstance := arry; 330 | end; 331 | 332 | function TZ_JsonObject.GetObject(const Name: string): TZ_JsonObject; 333 | var 334 | Obj_: TZ_Instance_JsonObject; 335 | j: Integer; 336 | begin 337 | Obj_ := FInstance.O[Name]; 338 | for j := FList.Count - 1 downto 0 do 339 | if (FList[j] is TZ_JsonObject) and (TZ_JsonObject(FList[j]).FInstance = Obj_) then 340 | begin 341 | Result := TZ_JsonObject(FList[j]); 342 | exit; 343 | end; 344 | Result := TZ_JsonObject.Create(self); 345 | Result.FInstance := Obj_; 346 | end; 347 | 348 | function TZ_JsonObject.GetName(Index: Integer): string; 349 | begin 350 | Result := FInstance.Names[Index]; 351 | end; 352 | 353 | function TZ_JsonObject.GetCount: Integer; 354 | begin 355 | Result := FInstance.Count; 356 | end; 357 | 358 | procedure TZ_JsonObject.SaveToStream(stream: TCoreClassStream; Formated_: Boolean); 359 | begin 360 | FInstance.SaveToStream(stream, not Formated_, TEncoding.UTF8, True); 361 | end; 362 | 363 | procedure TZ_JsonObject.LoadFromStream(stream: TCoreClassStream); 364 | begin 365 | FInstance.LoadFromStream(stream, TEncoding.UTF8, True); 366 | end; 367 | -------------------------------------------------------------------------------- /Source/ZJson_fpc.inc: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { * json object library for delphi/objfpc * } 3 | { * https://zpascal.net * } 4 | { * https://github.com/PassByYou888/zAI * } 5 | { * https://github.com/PassByYou888/ZServer4D * } 6 | { * https://github.com/PassByYou888/PascalString * } 7 | { * https://github.com/PassByYou888/zRasterization * } 8 | { * https://github.com/PassByYou888/CoreCipher * } 9 | { * https://github.com/PassByYou888/zSound * } 10 | { * https://github.com/PassByYou888/zChinese * } 11 | { * https://github.com/PassByYou888/zExpression * } 12 | { * https://github.com/PassByYou888/zGameWare * } 13 | { * https://github.com/PassByYou888/zAnalysis * } 14 | { * https://github.com/PassByYou888/FFMPEG-Header * } 15 | { * https://github.com/PassByYou888/zTranslate * } 16 | { * https://github.com/PassByYou888/InfiniteIoT * } 17 | { * https://github.com/PassByYou888/FastMD5 * } 18 | { ****************************************************************************** } 19 | procedure TZ_JsonArray.Clear; 20 | begin 21 | FInstance.Clear; 22 | end; 23 | 24 | procedure TZ_JsonArray.Delete(Index: Integer); 25 | begin 26 | FInstance.Delete(index); 27 | end; 28 | 29 | procedure TZ_JsonArray.Add(const v_: string); 30 | begin 31 | FInstance.Add(v_); 32 | end; 33 | 34 | procedure TZ_JsonArray.Add(const v_: TPascalString); 35 | begin 36 | FInstance.Add(v_.Text); 37 | end; 38 | 39 | procedure TZ_JsonArray.Add(const v_: Integer); 40 | begin 41 | FInstance.Add(v_); 42 | end; 43 | 44 | procedure TZ_JsonArray.Add(const v_: Int64); 45 | begin 46 | FInstance.Add(v_); 47 | end; 48 | 49 | procedure TZ_JsonArray.Add(const v_: UInt64); 50 | begin 51 | FInstance.Add(v_); 52 | end; 53 | 54 | procedure TZ_JsonArray.AddF(const v_: Double); 55 | begin 56 | FInstance.Add(v_); 57 | end; 58 | 59 | procedure TZ_JsonArray.Add(const v_: TDateTime); 60 | begin 61 | FInstance.Add(umlDateTimeToStr(v_).Text); 62 | end; 63 | 64 | procedure TZ_JsonArray.Add(const v_: Boolean); 65 | begin 66 | FInstance.Add(v_); 67 | end; 68 | 69 | function TZ_JsonArray.AddArray: TZ_JsonArray; 70 | begin 71 | Result := TZ_JsonArray.Create(self); 72 | Result.FInstance := TZ_Instance_JsonArray.Create; 73 | FInstance.Add(Result.FInstance); 74 | end; 75 | 76 | function TZ_JsonArray.AddObject: TZ_JsonObject; 77 | begin 78 | Result := TZ_JsonObject.Create(self); 79 | Result.FInstance := TZ_Instance_JsonObject.Create; 80 | FInstance.Add(Result.FInstance); 81 | end; 82 | 83 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: string); 84 | begin 85 | FInstance.Insert(index, v_); 86 | end; 87 | 88 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: Integer); 89 | begin 90 | FInstance.Insert(index, v_); 91 | end; 92 | 93 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: Int64); 94 | begin 95 | FInstance.Insert(index, v_); 96 | end; 97 | 98 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: UInt64); 99 | begin 100 | FInstance.Insert(index, v_); 101 | end; 102 | 103 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: Double); 104 | begin 105 | FInstance.Insert(index, v_); 106 | end; 107 | 108 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: TDateTime); 109 | begin 110 | FInstance.Insert(index, umlDateTimeToStr(v_).Text); 111 | end; 112 | 113 | procedure TZ_JsonArray.Insert(Index: Integer; const v_: Boolean); 114 | begin 115 | FInstance.Insert(index, v_); 116 | end; 117 | 118 | function TZ_JsonArray.InsertArray(Index: Integer): TZ_JsonArray; 119 | begin 120 | Result := TZ_JsonArray.Create(self); 121 | Result.FInstance := TZ_Instance_JsonArray.Create; 122 | FInstance.Insert(index, Result.FInstance); 123 | end; 124 | 125 | function TZ_JsonArray.InsertObject(Index: Integer): TZ_JsonObject; 126 | begin 127 | Result := TZ_JsonObject.Create(self); 128 | Result.FInstance := TZ_Instance_JsonObject.Create; 129 | FInstance.Insert(index, Result.FInstance); 130 | end; 131 | 132 | function TZ_JsonArray.GetString(Index: Integer): string; 133 | begin 134 | Result := FInstance.Strings[index]; 135 | end; 136 | 137 | procedure TZ_JsonArray.SetString(Index: Integer; const Value: string); 138 | begin 139 | FInstance.Strings[index] := Value; 140 | end; 141 | 142 | function TZ_JsonArray.GetInt(Index: Integer): Integer; 143 | begin 144 | Result := FInstance.Integers[index]; 145 | end; 146 | 147 | procedure TZ_JsonArray.SetInt(Index: Integer; const Value: Integer); 148 | begin 149 | FInstance.Integers[index] := Value; 150 | end; 151 | 152 | function TZ_JsonArray.GetLong(Index: Integer): Int64; 153 | begin 154 | Result := FInstance.Int64s[index]; 155 | end; 156 | 157 | procedure TZ_JsonArray.SetLong(Index: Integer; const Value: Int64); 158 | begin 159 | FInstance.Int64s[index] := Value; 160 | end; 161 | 162 | function TZ_JsonArray.GetULong(Index: Integer): UInt64; 163 | begin 164 | Result := FInstance.QWords[index]; 165 | end; 166 | 167 | procedure TZ_JsonArray.SetULong(Index: Integer; const Value: UInt64); 168 | begin 169 | FInstance.QWords[index] := Value; 170 | end; 171 | 172 | function TZ_JsonArray.GetFloat(Index: Integer): Double; 173 | begin 174 | Result := FInstance.Floats[index]; 175 | end; 176 | 177 | procedure TZ_JsonArray.SetFloat(Index: Integer; const Value: Double); 178 | begin 179 | FInstance.Floats[index] := Value; 180 | end; 181 | 182 | function TZ_JsonArray.GetDateTime(Index: Integer): TDateTime; 183 | begin 184 | Result := umlStrToDateTime(FInstance.Strings[index]); 185 | end; 186 | 187 | procedure TZ_JsonArray.SetDateTime(Index: Integer; const Value: TDateTime); 188 | begin 189 | FInstance.Strings[index] := umlDateTimeToStr(Value).Text; 190 | end; 191 | 192 | function TZ_JsonArray.GetBool(Index: Integer): Boolean; 193 | begin 194 | Result := FInstance.Booleans[index]; 195 | end; 196 | 197 | procedure TZ_JsonArray.SetBool(Index: Integer; const Value: Boolean); 198 | begin 199 | FInstance.Booleans[index] := Value; 200 | end; 201 | 202 | function TZ_JsonArray.GetArray(Index: Integer): TZ_JsonArray; 203 | var 204 | arry: TZ_Instance_JsonArray; 205 | j: Integer; 206 | begin 207 | arry := FInstance.Arrays[index]; 208 | for j := FList.Count - 1 downto 0 do 209 | if (FList[j] is TZ_JsonArray) and (TZ_JsonArray(FList[j]).FInstance = arry) then 210 | begin 211 | Result := TZ_JsonArray(FList[j]); 212 | exit; 213 | end; 214 | Result := TZ_JsonArray.Create(self); 215 | Result.FInstance := arry; 216 | end; 217 | 218 | function TZ_JsonArray.GetObject(Index: Integer): TZ_JsonObject; 219 | var 220 | Obj_: TZ_Instance_JsonObject; 221 | j: Integer; 222 | begin 223 | Obj_ := FInstance.Objects[Index]; 224 | for j := FList.Count - 1 downto 0 do 225 | if (FList[j] is TZ_JsonObject) and (TZ_JsonObject(FList[j]).FInstance = Obj_) then 226 | begin 227 | Result := TZ_JsonObject(FList[j]); 228 | exit; 229 | end; 230 | Result := TZ_JsonObject.Create(self); 231 | Result.FInstance := Obj_; 232 | end; 233 | 234 | function TZ_JsonArray.GetCount: Integer; 235 | begin 236 | Result := FInstance.Count; 237 | end; 238 | 239 | procedure TZ_JsonObject.Clear; 240 | begin 241 | FInstance.Clear; 242 | end; 243 | 244 | function TZ_JsonObject.IndexOf(const Name: string): Integer; 245 | begin 246 | Result := FInstance.IndexOfName(Name); 247 | end; 248 | 249 | function TZ_JsonObject.GetString(const Name: string): string; 250 | begin 251 | Result := FInstance.Strings[Name]; 252 | end; 253 | 254 | procedure TZ_JsonObject.SetString(const Name, Value: string); 255 | begin 256 | FInstance.Strings[Name] := Value; 257 | end; 258 | 259 | function TZ_JsonObject.GetInt(const Name: string): Integer; 260 | begin 261 | Result := FInstance.Integers[Name]; 262 | end; 263 | 264 | procedure TZ_JsonObject.SetInt(const Name: string; const Value: Integer); 265 | begin 266 | FInstance.Integers[Name] := Value; 267 | end; 268 | 269 | function TZ_JsonObject.GetLong(const Name: string): Int64; 270 | begin 271 | Result := FInstance.Int64s[Name]; 272 | end; 273 | 274 | procedure TZ_JsonObject.SetLong(const Name: string; const Value: Int64); 275 | begin 276 | FInstance.Int64s[Name] := Value; 277 | end; 278 | 279 | function TZ_JsonObject.GetULong(const Name: string): UInt64; 280 | begin 281 | Result := FInstance.QWords[Name]; 282 | end; 283 | 284 | procedure TZ_JsonObject.SetULong(const Name: string; const Value: UInt64); 285 | begin 286 | FInstance.QWords[Name] := Value; 287 | end; 288 | 289 | function TZ_JsonObject.GetFloat(const Name: string): Double; 290 | begin 291 | Result := FInstance.Floats[Name]; 292 | end; 293 | 294 | procedure TZ_JsonObject.SetFloat(const Name: string; const Value: Double); 295 | begin 296 | FInstance.Floats[Name] := Value; 297 | end; 298 | 299 | function TZ_JsonObject.GetDateTime(const Name: string): TDateTime; 300 | begin 301 | Result := umlStrToDateTime(FInstance.Strings[Name]); 302 | end; 303 | 304 | procedure TZ_JsonObject.SetDateTime(const Name: string; const Value: TDateTime); 305 | begin 306 | FInstance.Strings[Name] := umlDateTimeToStr(Value).Text; 307 | end; 308 | 309 | function TZ_JsonObject.GetBool(const Name: string): Boolean; 310 | begin 311 | Result := FInstance.Booleans[Name]; 312 | end; 313 | 314 | procedure TZ_JsonObject.SetBool(const Name: string; const Value: Boolean); 315 | begin 316 | FInstance.Booleans[Name] := Value; 317 | end; 318 | 319 | function TZ_JsonObject.GetArray(const Name: string): TZ_JsonArray; 320 | var 321 | arry: TZ_Instance_JsonArray; 322 | j: Integer; 323 | begin 324 | if FInstance.Find(Name, arry) then 325 | begin 326 | for j := FList.Count - 1 downto 0 do 327 | if (FList[j] is TZ_JsonArray) and (TZ_JsonArray(FList[j]).FInstance = arry) then 328 | begin 329 | Result := TZ_JsonArray(FList[j]); 330 | exit; 331 | end; 332 | end; 333 | 334 | arry := TZ_Instance_JsonArray.Create(); 335 | FInstance.Arrays[Name] := arry; 336 | Result := TZ_JsonArray.Create(self); 337 | Result.FInstance := arry; 338 | end; 339 | 340 | function TZ_JsonObject.GetObject(const Name: string): TZ_JsonObject; 341 | var 342 | Obj_: TZ_Instance_JsonObject; 343 | j: Integer; 344 | begin 345 | if FInstance.Find(Name, Obj_) then 346 | begin 347 | for j := FList.Count - 1 downto 0 do 348 | if (FList[j] is TZ_JsonObject) and (TZ_JsonObject(FList[j]).FInstance = Obj_) then 349 | begin 350 | Result := TZ_JsonObject(FList[j]); 351 | exit; 352 | end; 353 | end; 354 | 355 | Obj_ := TZ_Instance_JsonObject.Create(); 356 | FInstance.Objects[Name] := Obj_; 357 | Result := TZ_JsonObject.Create(self); 358 | Result.FInstance := Obj_; 359 | end; 360 | 361 | function TZ_JsonObject.GetName(Index: Integer): string; 362 | begin 363 | Result := FInstance.Names[index]; 364 | end; 365 | 366 | function TZ_JsonObject.GetCount: Integer; 367 | begin 368 | Result := FInstance.Count; 369 | end; 370 | 371 | procedure TZ_JsonObject.SaveToStream(stream: TCoreClassStream; Formated_: Boolean); 372 | var 373 | s_: TPascalString; 374 | buff: TBytes; 375 | begin 376 | if Formated_ then 377 | s_.Text := FInstance.FormatJSON() 378 | else 379 | s_.Text := FInstance.AsJSON; 380 | buff := s_.Bytes; 381 | s_ := ''; 382 | stream.Write(buff[0], length(buff)); 383 | SetLength(buff, 0); 384 | end; 385 | 386 | procedure TZ_JsonObject.LoadFromStream(stream: TCoreClassStream); 387 | Var 388 | P: TJSONParser; 389 | j: TJSONData; 390 | begin 391 | DisposeObjectAndNil(FInstance); 392 | P := TJSONParser.Create(stream, [joUTF8]); 393 | try 394 | j := P.Parse; 395 | if j is TZ_Instance_JsonObject then 396 | FInstance := TZ_Instance_JsonObject(j) 397 | except 398 | end; 399 | FreeAndNil(P); 400 | end; 401 | -------------------------------------------------------------------------------- /Source/clear_with_dcu.bat: -------------------------------------------------------------------------------- 1 | del/s *.dcu 2 | del/s *.o 3 | del/s *.ppu 4 | del/s *.rsm 5 | del/s *.replay 6 | del/s *.loginpackage 7 | del/s *.dres 8 | del/s *.local 9 | del/s *.identcache 10 | del/s *.stat 11 | del/s *.tvsconfig 12 | del/s *.deployproj 13 | del/s *.stat 14 | del/s *.delphilsp.json 15 | rem del/s *.pdb 16 | rem del/s *.exp 17 | rem del/s zAI\*.pdb 18 | rem del/s zAI\*.obj 19 | rem del/s zAI\*.lib 20 | rem del/s zAI\*.tlog 21 | rem del/s zAI\*.db 22 | rem rd/q/s zAI\AI_Build\cuda\dlib_build\dlib\Debug 23 | rem rd/q/s zAI\AI_Build\cuda\dlib_build\dlib\Release 24 | rem rd/q/s zAI\AI_Build\cuda\dlib_build\dlib\x64 25 | rem rd/q/s zAI\AI_Build\cuda\Debug 26 | rem rd/q/s zAI\AI_Build\cuda\Release 27 | rem rd/q/s zAI\AI_Build\cuda\x64 28 | -------------------------------------------------------------------------------- /Source/md5_32.asm: -------------------------------------------------------------------------------- 1 | ;{ ****************************************************************************** } 2 | ;{ * https://zpascal.net * } 3 | ;{ * https://github.com/PassByYou888/zAI * } 4 | ;{ * https://github.com/PassByYou888/ZServer4D * } 5 | ;{ * https://github.com/PassByYou888/PascalString * } 6 | ;{ * https://github.com/PassByYou888/zRasterization * } 7 | ;{ * https://github.com/PassByYou888/CoreCipher * } 8 | ;{ * https://github.com/PassByYou888/zSound * } 9 | ;{ * https://github.com/PassByYou888/zChinese * } 10 | ;{ * https://github.com/PassByYou888/zExpression * } 11 | ;{ * https://github.com/PassByYou888/zGameWare * } 12 | ;{ * https://github.com/PassByYou888/zAnalysis * } 13 | ;{ * https://github.com/PassByYou888/FFMPEG-Header * } 14 | ;{ * https://github.com/PassByYou888/zTranslate * } 15 | ;{ * https://github.com/PassByYou888/InfiniteIoT * } 16 | ;{ * https://github.com/PassByYou888/FastMD5 * } 17 | ;{ ****************************************************************************** } 18 | 19 | 20 | ; MD5_386.Asm - 386 optimized helper routine for calculating 21 | ; MD Message-Digest values 22 | ; written 2/2/94 by 23 | ; 24 | ; Peter Sawatzki 25 | ; Buchenhof 3 26 | ; D58091 Hagen, Germany Fed Rep 27 | ; 28 | ; EMail: Peter@Sawatzki.de 29 | ; EMail: 100031.3002@compuserve.com 30 | ; WWW: http://www.sawatzki.de 31 | ; 32 | ; 33 | ; original C Source was found in Dr. Dobbs Journal Sep 91 34 | ; MD5 algorithm from RSA Data Security, Inc. 35 | 36 | 37 | ; This is a 32-bit version of MD5_Transform 38 | ; modifief by Maxim Masiutin for Borland 32-bit "register" 39 | ; calling convention. For more information on this calling convension, see 40 | ; https://en.wikipedia.org/wiki/X86_calling_conventions#Borland_register 41 | 42 | ; You can compile this code using Microsoft Macro Assembler 43 | ; ml.exe /c md5_32.asm 44 | ; or using Borland Turbo Assembler 45 | ; tasm32.exe /m md5_32.asm 46 | 47 | .386 48 | .MODEL FLAT 49 | .CODE 50 | 51 | FF Macro a,b,c,d,x,s,ac 52 | ; a:= ROL (a+x+ac + (b And c Or Not b And d), s) + b 53 | Add a, [EBp+(4*x)] 54 | Add a, ac 55 | Mov ESi, b 56 | Not ESi 57 | And ESi, d 58 | Mov EDi, c 59 | And EDi, b 60 | Or ESi, EDi 61 | Add a, ESi 62 | Rol a, s 63 | Add a, b 64 | EndM 65 | 66 | GG Macro a,b,c,d,x,s,ac 67 | ; a:= ROL (a+x+ac + (b And d Or c And Not d), s) + b 68 | Add a, [EBp+(4*x)] 69 | Add a, ac 70 | Mov ESi, d 71 | Not ESi 72 | And ESi, c 73 | Mov EDi, d 74 | And EDi, b 75 | Or ESi, EDi 76 | Add a, ESi 77 | Rol a, s 78 | Add a, b 79 | EndM 80 | 81 | HH Macro a,b,c,d,x,s,ac 82 | ; a:= ROL (a+x+ac + (b Xor c Xor d), s) + b 83 | Add a, [EBp+(4*x)] 84 | Add a, ac 85 | Mov ESi, d 86 | Xor ESi, c 87 | Xor ESi, b 88 | Add a, ESi 89 | Rol a, s 90 | Add a, b 91 | EndM 92 | 93 | II Macro a,b,c,d,x,s,ac 94 | ; a:= ROL (a+x+ac + (c Xor (b Or Not d)), s) + b 95 | Add a, [EBp+(4*x)] 96 | Add a, ac 97 | Mov ESi, d 98 | Not ESi 99 | Or ESi, b 100 | Xor ESi, c 101 | Add a, ESi 102 | Rol a, s 103 | Add a, b 104 | EndM 105 | 106 | MD5_Transform Proc 107 | Public MD5_Transform 108 | 109 | ; Use 32-bit Borland Register calling convention 110 | ; First Parameter in EAX 111 | ; Second Paramerter in EDX 112 | 113 | ; State buffer offset - in EAx 114 | ; Message offset - in EDx 115 | 116 | Push EBx 117 | Push ESi 118 | Push EDi 119 | Push EBp 120 | 121 | Mov EBp, EDx ; Now EBp holds Message offset 122 | Push EAx 123 | Mov EDx, [EAx+12] 124 | Mov ECx, [EAx+8] 125 | Mov EBx, [EAx+4] 126 | Mov EAx, [EAx] 127 | 128 | FF EAx,EBx,ECx,EDx, 0, 7, 0d76aa478h ; 1 129 | FF EDx,EAx,EBx,ECx, 1, 12, 0e8c7b756h ; 2 130 | FF ECx,EDx,EAx,EBx, 2, 17, 0242070dbh ; 3 131 | FF EBx,ECx,EDx,EAx, 3, 22, 0c1bdceeeh ; 4 132 | FF EAx,EBx,ECx,EDx, 4, 7, 0f57c0fafh ; 5 133 | FF EDx,EAx,EBx,ECx, 5, 12, 04787c62ah ; 6 134 | FF ECx,EDx,EAx,EBx, 6, 17, 0a8304613h ; 7 135 | FF EBx,ECx,EDx,EAx, 7, 22, 0fd469501h ; 8 136 | FF EAx,EBx,ECx,EDx, 8, 7, 0698098d8h ; 9 137 | FF EDx,EAx,EBx,ECx, 9, 12, 08b44f7afh ; 10 138 | FF ECx,EDx,EAx,EBx, 10, 17, 0ffff5bb1h ; 11 139 | FF EBx,ECx,EDx,EAx, 11, 22, 0895cd7beh ; 12 140 | FF EAx,EBx,ECx,EDx, 12, 7, 06b901122h ; 13 141 | FF EDx,EAx,EBx,ECx, 13, 12, 0fd987193h ; 14 142 | FF ECx,EDx,EAx,EBx, 14, 17, 0a679438eh ; 15 143 | FF EBx,ECx,EDx,EAx, 15, 22, 049b40821h ; 16 144 | 145 | GG EAx,EBx,ECx,EDx, 1, 5, 0f61e2562h ; 17 146 | GG EDx,EAx,EBx,ECx, 6, 9, 0c040b340h ; 18 147 | GG ECx,EDx,EAx,EBx, 11, 14, 0265e5a51h ; 19 148 | GG EBx,ECx,EDx,EAx, 0, 20, 0e9b6c7aah ; 20 149 | GG EAx,EBx,ECx,EDx, 5, 5, 0d62f105dh ; 21 150 | GG EDx,EAx,EBx,ECx, 10, 9, 002441453h ; 22 151 | GG ECx,EDx,EAx,EBx, 15, 14, 0d8a1e681h ; 23 152 | GG EBx,ECx,EDx,EAx, 4, 20, 0e7d3fbc8h ; 24 153 | GG EAx,EBx,ECx,EDx, 9, 5, 021e1cde6h ; 25 154 | GG EDx,EAx,EBx,ECx, 14, 9, 0c33707d6h ; 26 155 | GG ECx,EDx,EAx,EBx, 3, 14, 0f4d50d87h ; 27 156 | GG EBx,ECx,EDx,EAx, 8, 20, 0455a14edh ; 28 157 | GG EAx,EBx,ECx,EDx, 13, 5, 0a9e3e905h ; 29 158 | GG EDx,EAx,EBx,ECx, 2, 9, 0fcefa3f8h ; 30 159 | GG ECx,EDx,EAx,EBx, 7, 14, 0676f02d9h ; 31 160 | GG EBx,ECx,EDx,EAx, 12, 20, 08d2a4c8ah ; 32 161 | 162 | HH EAx,EBx,ECx,EDx, 5, 4, 0fffa3942h ; 33 163 | HH EDx,EAx,EBx,ECx, 8, 11, 08771f681h ; 34 164 | HH ECx,EDx,EAx,EBx, 11, 16, 06d9d6122h ; 35 165 | HH EBx,ECx,EDx,EAx, 14, 23, 0fde5380ch ; 36 166 | HH EAx,EBx,ECx,EDx, 1, 4, 0a4beea44h ; 37 167 | HH EDx,EAx,EBx,ECx, 4, 11, 04bdecfa9h ; 38 168 | HH ECx,EDx,EAx,EBx, 7, 16, 0f6bb4b60h ; 39 169 | HH EBx,ECx,EDx,EAx, 10, 23, 0bebfbc70h ; 40 170 | HH EAx,EBx,ECx,EDx, 13, 4, 0289b7ec6h ; 41 171 | HH EDx,EAx,EBx,ECx, 0, 11, 0eaa127fah ; 42 172 | HH ECx,EDx,EAx,EBx, 3, 16, 0d4ef3085h ; 43 173 | HH EBx,ECx,EDx,EAx, 6, 23, 004881d05h ; 44 174 | HH EAx,EBx,ECx,EDx, 9, 4, 0d9d4d039h ; 45 175 | HH EDx,EAx,EBx,ECx, 12, 11, 0e6db99e5h ; 46 176 | HH ECx,EDx,EAx,EBx, 15, 16, 01fa27cf8h ; 47 177 | HH EBx,ECx,EDx,EAx, 2, 23, 0c4ac5665h ; 48 178 | 179 | II EAx,EBx,ECx,EDx, 0, 6, 0f4292244h ; 49 180 | II EDx,EAx,EBx,ECx, 7, 10, 0432aff97h ; 50 181 | II ECx,EDx,EAx,EBx, 14, 15, 0ab9423a7h ; 51 182 | II EBx,ECx,EDx,EAx, 5, 21, 0fc93a039h ; 52 183 | II EAx,EBx,ECx,EDx, 12, 6, 0655b59c3h ; 53 184 | II EDx,EAx,EBx,ECx, 3, 10, 08f0ccc92h ; 54 185 | II ECx,EDx,EAx,EBx, 10, 15, 0ffeff47dh ; 55 186 | II EBx,ECx,EDx,EAx, 1, 21, 085845dd1h ; 56 187 | II EAx,EBx,ECx,EDx, 8, 6, 06fa87e4fh ; 57 188 | II EDx,EAx,EBx,ECx, 15, 10, 0fe2ce6e0h ; 58 189 | II ECx,EDx,EAx,EBx, 6, 15, 0a3014314h ; 59 190 | II EBx,ECx,EDx,EAx, 13, 21, 04e0811a1h ; 60 191 | II EAx,EBx,ECx,EDx, 4, 6, 0f7537e82h ; 61 192 | II EDx,EAx,EBx,ECx, 11, 10, 0bd3af235h ; 62 193 | II ECx,EDx,EAx,EBx, 2, 15, 02ad7d2bbh ; 63 194 | II EBx,ECx,EDx,EAx, 9, 21, 0eb86d391h ; 64 195 | 196 | Pop ESi 197 | Add [ESi], EAx 198 | Add [ESi+4], EBx 199 | Add [ESi+8], ECx 200 | Add [ESi+12], EDx 201 | 202 | ; restore the registers to comply to the calling convention 203 | Pop EBp 204 | Pop EDi 205 | Pop ESi 206 | Pop EBx 207 | 208 | Ret 209 | MD5_Transform EndP 210 | 211 | End 212 | -------------------------------------------------------------------------------- /Source/md5_32.obj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PassByYou888/CoreCipher/c3757295fe4e252b42187e1a28f21588b57b6728/Source/md5_32.obj -------------------------------------------------------------------------------- /Source/md5_64.asm: -------------------------------------------------------------------------------- 1 | ;{ ****************************************************************************** } 2 | ;{ * https://zpascal.net * } 3 | ;{ * https://github.com/PassByYou888/zAI * } 4 | ;{ * https://github.com/PassByYou888/ZServer4D * } 5 | ;{ * https://github.com/PassByYou888/PascalString * } 6 | ;{ * https://github.com/PassByYou888/zRasterization * } 7 | ;{ * https://github.com/PassByYou888/CoreCipher * } 8 | ;{ * https://github.com/PassByYou888/zSound * } 9 | ;{ * https://github.com/PassByYou888/zChinese * } 10 | ;{ * https://github.com/PassByYou888/zExpression * } 11 | ;{ * https://github.com/PassByYou888/zGameWare * } 12 | ;{ * https://github.com/PassByYou888/zAnalysis * } 13 | ;{ * https://github.com/PassByYou888/FFMPEG-Header * } 14 | ;{ * https://github.com/PassByYou888/zTranslate * } 15 | ;{ * https://github.com/PassByYou888/InfiniteIoT * } 16 | ;{ * https://github.com/PassByYou888/FastMD5 * } 17 | ;{ ****************************************************************************** } 18 | 19 | 20 | ; MD5_Transform-x64 21 | ; MD5 transform routine oprimized for x64 processors 22 | ; Copyright 2018 Ritlabs, SRL 23 | ; The 64-bit version is written by Maxim Masiutin <max@ritlabs.com> 24 | 25 | ; The main advantage of this 64-bit version is that 26 | ; it loads 64 bytes of hashed message into 8 64-bit registers 27 | ; (RBP, R8, R9, R10, R11, R12, R13, R14) at the beginning, 28 | ; to avoid excessive memory load operations 29 | ; througout the routine. 30 | 31 | ; To operate with 32-bit values store in higher bits 32 | ; of a 64-bit register (bits 32-63) uses "Ror" by 32; 33 | ; 8 macro variables (M1-M8) are used to keep record 34 | ; or corrent state of whether the register has been 35 | ; Ror'ed or not. 36 | 37 | ; It also has an ability to use Lea instruction instead 38 | ; of two sequental Adds (uncomment UseLea=1), but it is 39 | ; slower on Skylake processors. Also, Intel in the 40 | ; Optimization Reference Maual discourages us of 41 | ; Lea as a replacement of two adds, since it is slower 42 | ; on the Atom processors. 43 | 44 | ; MD5_Transform-x64 is released under a dual license, 45 | ; and you may choose to use it under either the 46 | ; Mozilla Public License 2.0 (MPL 2.1, available from 47 | ; https://www.mozilla.org/en-US/MPL/2.0/) or the 48 | ; GNU Lesser General Public License Version 3, 49 | ; dated 29 June 2007 (LGPL 3, available from 50 | ; https://www.gnu.org/licenses/lgpl.html). 51 | 52 | ; MD5_Transform-x64 is based 53 | ; on the following code by Peter Sawatzki. 54 | 55 | ; The original notice by Peter Sawatzki follows. 56 | 57 | ; ============================================================== 58 | ; 59 | ; MD5_386.Asm - 386 optimized helper routine for calculating 60 | ; MD Message-Digest values 61 | ; written 2/2/94 by 62 | ; 63 | ; Peter Sawatzki 64 | ; Buchenhof 3 65 | ; D58091 Hagen, Germany Fed Rep 66 | ; 67 | ; EMail: Peter@Sawatzki.de 68 | ; EMail: 100031.3002@compuserve.com 69 | ; WWW: http://www.sawatzki.de 70 | ; 71 | ; 72 | ; original C Source was found in Dr. Dobbs Journal Sep 91 73 | ; MD5 algorithm from RSA Data Security, Inc. 74 | 75 | 76 | 77 | .CODE 78 | 79 | 80 | ; You can compile this code using Microsoft Macro Assembler 81 | ; ml64.exe /c md5_64.asm 82 | 83 | 84 | 85 | ; Uncomment the line below if you wish to have 86 | ; a "Lea" instruction instead of two subsequent "Add". 87 | 88 | ; UseLea=1 89 | 90 | 91 | 92 | ; The AA macro adds r to ac to a and stores result to r 93 | ; r and a can be either 32-bit (for the "Add" version) 94 | ; or 64-bit (for the "Lea" version) 95 | 96 | AA Macro r32,r64,ac,a32,a64 97 | IFDEF UseLea 98 | Lea r64, [r64+ac+a64] 99 | ELSE 100 | Add r32, ac 101 | Add r32, a32 102 | ENDIF 103 | EndM 104 | 105 | ; The JJ macro adds value from state buffer to the "a" register 106 | ; The "a" register can be either 32-bit (for the "Add" version) 107 | ; or 64-bit (for "Lea") - in this case it is passed as "r" 108 | 109 | JJ Macro a,x,ac,r 110 | IFE x 111 | IF M1 112 | Ror RBp, 32 113 | M1=0 114 | ENDIF 115 | AA a, r, ac, EBp, RBp 116 | ENDIF 117 | IFE x-1 118 | IFE M1 119 | Ror RBp, 32 120 | M1=1 121 | ENDIF 122 | AA a, r, ac, EBp, RBp 123 | ENDIF 124 | IFE x-2 125 | IF M2 126 | Ror R8, 32 127 | M2=0 128 | ENDIF 129 | AA a, r, ac, R8d, R8 130 | ENDIF 131 | IFE x-3 132 | IFE M2 133 | Ror R8, 32 134 | M2=1 135 | ENDIF 136 | AA a, r, ac, R8d, R8 137 | ENDIF 138 | IFE x-4 139 | IF M3 140 | Ror R9, 32 141 | M3=0 142 | ENDIF 143 | AA a, r, ac, R9d, R9 144 | ENDIF 145 | IFE x-5 146 | IFE M3 147 | Ror R9, 32 148 | M3=1 149 | ENDIF 150 | AA a, r, ac, R9d, R9 151 | ENDIF 152 | IFE x-6 153 | IF M4 154 | Ror R10, 32 155 | M4=0 156 | ENDIF 157 | AA a, r, ac, R10d, R10 158 | ENDIF 159 | IFE x-7 160 | IFE M4 161 | Ror R10, 32 162 | M4=1 163 | ENDIF 164 | AA a, r, ac, R10d, R10 165 | ENDIF 166 | IFE x-8 167 | IF M5 168 | Ror R11, 32 169 | M5=0 170 | ENDIF 171 | AA a, r, ac, R11d, R11 172 | ENDIF 173 | IFE x-9 174 | IFE M5 175 | Ror R11, 32 176 | M5=1 177 | ENDIF 178 | AA a, r, ac, R11d, R11 179 | ENDIF 180 | IFE x-10 181 | IF M6 182 | Ror R12, 32 183 | M6=0 184 | ENDIF 185 | AA a, r, ac, R12d, R12 186 | ENDIF 187 | IFE x-11 188 | IFE M6 189 | Ror R12, 32 190 | M6=1 191 | ENDIF 192 | AA a, r, ac, R12d, R12 193 | ENDIF 194 | IFE x-12 195 | IF M7 196 | Ror R13, 32 197 | M7=0 198 | ENDIF 199 | AA a, r, ac, R13d, R13 200 | ENDIF 201 | IFE x-13 202 | IFE M7 203 | Ror R13, 32 204 | M7=1 205 | ENDIF 206 | AA a, r, ac, R13d, R13 207 | ENDIF 208 | IFE x-14 209 | IF M8 210 | Ror R14, 32 211 | M8=0 212 | ENDIF 213 | AA a, r, ac, R14d, R14 214 | ENDIF 215 | IFE x-15 216 | IFE M8 217 | Ror R14, 32 218 | M8=1 219 | ENDIF 220 | AA a, r, ac, R14d, R14 221 | ENDIF 222 | EndM 223 | 224 | 225 | FF Macro a,b,c,d,x,s,ac,r 226 | ; a:= ROL (a+x+ac + (b And c Or Not b And d), s) + b 227 | JJ a, x, ac, r 228 | Mov ESI, b 229 | Not ESI 230 | And ESI, d 231 | Mov EDI, c 232 | And EDI, b 233 | Or ESI, EDI 234 | Add a, ESI 235 | Rol a, s 236 | Add a, b 237 | EndM 238 | 239 | GG Macro a,b,c,d,x,s,ac,r 240 | ; a:= ROL (a+x+ac + (b And d Or c And Not d), s) + b 241 | JJ a, x, ac, r 242 | Mov ESI, d 243 | Not ESI 244 | And ESI, c 245 | Mov EDI, d 246 | And EDI, b 247 | Or ESI, EDI 248 | Add a, ESI 249 | Rol a, s 250 | Add a, b 251 | EndM 252 | 253 | HH Macro a,b,c,d,x,s,ac,r 254 | ; a:= ROL (a+x+ac + (b Xor c Xor d), s) + b 255 | JJ a, x, ac, r 256 | Mov ESI, d 257 | Xor ESI, c 258 | Xor ESI, b 259 | Add a, ESI 260 | Rol a, s 261 | Add a, b 262 | EndM 263 | 264 | II Macro a,b,c,d,x,s,ac,r 265 | ; a:= ROL (a+x+ac + (c Xor (b Or Not d)), s) + b 266 | JJ a, x, ac, r 267 | Mov ESI, d 268 | Not ESI 269 | Or ESI, b 270 | Xor ESI, c 271 | Add a, ESI 272 | Rol a, s 273 | Add a, b 274 | EndM 275 | 276 | MD5_Transform Proc 277 | Public MD5_Transform 278 | 279 | ; save registers that the caller requires to be restored 280 | Push RBx 281 | Push RSi 282 | Push RDi 283 | 284 | Push RBp 285 | Push R12 286 | Push R13 287 | Push R14 288 | 289 | ; First parameter is passed in RCX, Second - in RDX 290 | 291 | ; State - in RCX 292 | ; Message - in RDX 293 | 294 | M1 = 0 295 | M2 = 0 296 | M3 = 0 297 | M4 = 0 298 | M5 = 0 299 | M6 = 0 300 | M7 = 0 301 | M8 = 0 302 | 303 | Mov R14, RDX ; Now the message buffer offset is in R14 304 | 305 | Mov RSi, Rcx ; Now state structure offset is in RSi 306 | Push Rsi ; State -> Stack 307 | Mov EAx, [RSi] 308 | Mov EBx, [RSi+4] 309 | Mov ECx, [RSi+8] 310 | Mov EDx, [RSi+12] 311 | 312 | Mov RBP, [R14+4*0] 313 | FF EAx,EBx,ECx,EDx, 0, 7, 0d76aa478h, RAx ; 1 314 | FF EDx,EAx,EBx,ECx, 1, 12, 0e8c7b756h, RDx ; 2 315 | Mov R8, [R14+4*2] 316 | FF ECx,EDx,EAx,EBx, 2, 17, 0242070dbh, RCx ; 3 317 | FF EBx,ECx,EDx,EAx, 3, 22, 0c1bdceeeh, RBx ; 4 318 | Mov R9, [R14+4*4] 319 | FF EAx,EBx,ECx,EDx, 4, 7, 0f57c0fafh, RAx ; 5 320 | FF EDx,EAx,EBx,ECx, 5, 12, 04787c62ah, RDx ; 6 321 | Mov R10, [R14+4*6] 322 | FF ECx,EDx,EAx,EBx, 6, 17, 0a8304613h, RCx ; 7 323 | FF EBx,ECx,EDx,EAx, 7, 22, 0fd469501h, RBx ; 8 324 | Mov R11, [R14+4*8] 325 | FF EAx,EBx,ECx,EDx, 8, 7, 0698098d8h, RAx ; 9 326 | FF EDx,EAx,EBx,ECx, 9, 12, 08b44f7afh, RDx ; 10 327 | Mov R12, [R14+4*10] 328 | FF ECx,EDx,EAx,EBx, 10, 17, 0ffff5bb1h, RCx ; 11 329 | FF EBx,ECx,EDx,EAx, 11, 22, 0895cd7beh, RBx ; 12 330 | Mov R13, [R14+4*12] 331 | FF EAx,EBx,ECx,EDx, 12, 7, 06b901122h, RAx ; 13 332 | FF EDx,EAx,EBx,ECx, 13, 12, 0fd987193h, RDx ; 14 333 | Mov R14, [R14+4*14] 334 | FF ECx,EDx,EAx,EBx, 14, 17, 0a679438eh, RCx ; 15 335 | FF EBx,ECx,EDx,EAx, 15, 22, 049b40821h, RBx ; 16 336 | 337 | GG EAx,EBx,ECx,EDx, 1, 5, 0f61e2562h, RAx ; 17 338 | GG EDx,EAx,EBx,ECx, 6, 9, 0c040b340h, RDx ; 18 339 | GG ECx,EDx,EAx,EBx, 11, 14, 0265e5a51h, RCx ; 19 340 | GG EBx,ECx,EDx,EAx, 0, 20, 0e9b6c7aah, RBx ; 20 341 | GG EAx,EBx,ECx,EDx, 5, 5, 0d62f105dh, RAx ; 21 342 | GG EDx,EAx,EBx,ECx, 10, 9, 002441453h, RDx ; 22 343 | GG ECx,EDx,EAx,EBx, 15, 14, 0d8a1e681h, RCx ; 23 344 | GG EBx,ECx,EDx,EAx, 4, 20, 0e7d3fbc8h, RBx ; 24 345 | GG EAx,EBx,ECx,EDx, 9, 5, 021e1cde6h, RAx ; 25 346 | GG EDx,EAx,EBx,ECx, 14, 9, 0c33707d6h, RDx ; 26 347 | GG ECx,EDx,EAx,EBx, 3, 14, 0f4d50d87h, RCx ; 27 348 | GG EBx,ECx,EDx,EAx, 8, 20, 0455a14edh, RBx ; 28 349 | GG EAx,EBx,ECx,EDx, 13, 5, 0a9e3e905h, RAx ; 29 350 | GG EDx,EAx,EBx,ECx, 2, 9, 0fcefa3f8h, RDx ; 30 351 | GG ECx,EDx,EAx,EBx, 7, 14, 0676f02d9h, RCx ; 31 352 | GG EBx,ECx,EDx,EAx, 12, 20, 08d2a4c8ah, RBx ; 32 353 | 354 | HH EAx,EBx,ECx,EDx, 5, 4, 0fffa3942h, RAx ; 33 355 | HH EDx,EAx,EBx,ECx, 8, 11, 08771f681h, RDx ; 34 356 | HH ECx,EDx,EAx,EBx, 11, 16, 06d9d6122h, RCx ; 35 357 | HH EBx,ECx,EDx,EAx, 14, 23, 0fde5380ch, RBx ; 36 358 | HH EAx,EBx,ECx,EDx, 1, 4, 0a4beea44h, RAx ; 37 359 | HH EDx,EAx,EBx,ECx, 4, 11, 04bdecfa9h, RDx ; 38 360 | HH ECx,EDx,EAx,EBx, 7, 16, 0f6bb4b60h, RCx ; 39 361 | HH EBx,ECx,EDx,EAx, 10, 23, 0bebfbc70h, RBx ; 40 362 | HH EAx,EBx,ECx,EDx, 13, 4, 0289b7ec6h, RAx ; 41 363 | HH EDx,EAx,EBx,ECx, 0, 11, 0eaa127fah, RDx ; 42 364 | HH ECx,EDx,EAx,EBx, 3, 16, 0d4ef3085h, RCx ; 43 365 | HH EBx,ECx,EDx,EAx, 6, 23, 004881d05h, RBx ; 44 366 | HH EAx,EBx,ECx,EDx, 9, 4, 0d9d4d039h, RAx ; 45 367 | HH EDx,EAx,EBx,ECx, 12, 11, 0e6db99e5h, RDx ; 46 368 | HH ECx,EDx,EAx,EBx, 15, 16, 01fa27cf8h, RCx ; 47 369 | HH EBx,ECx,EDx,EAx, 2, 23, 0c4ac5665h, RBx ; 48 370 | 371 | II EAx,EBx,ECx,EDx, 0, 6, 0f4292244h, RAx ; 49 372 | II EDx,EAx,EBx,ECx, 7, 10, 0432aff97h, RDx ; 50 373 | II ECx,EDx,EAx,EBx, 14, 15, 0ab9423a7h, RCx ; 51 374 | II EBx,ECx,EDx,EAx, 5, 21, 0fc93a039h, RBx ; 52 375 | II EAx,EBx,ECx,EDx, 12, 6, 0655b59c3h, RAx ; 53 376 | II EDx,EAx,EBx,ECx, 3, 10, 08f0ccc92h, RDx ; 54 377 | II ECx,EDx,EAx,EBx, 10, 15, 0ffeff47dh, RCx ; 55 378 | II EBx,ECx,EDx,EAx, 1, 21, 085845dd1h, RBx ; 56 379 | II EAx,EBx,ECx,EDx, 8, 6, 06fa87e4fh, RAx ; 57 380 | II EDx,EAx,EBx,ECx, 15, 10, 0fe2ce6e0h, RDx ; 58 381 | II ECx,EDx,EAx,EBx, 6, 15, 0a3014314h, RCx ; 59 382 | II EBx,ECx,EDx,EAx, 13, 21, 04e0811a1h, RBx ; 60 383 | II EAx,EBx,ECx,EDx, 4, 6, 0f7537e82h, RAx ; 61 384 | II EDx,EAx,EBx,ECx, 11, 10, 0bd3af235h, RDx ; 62 385 | II ECx,EDx,EAx,EBx, 2, 15, 02ad7d2bbh, RCx ; 63 386 | II EBx,ECx,EDx,EAx, 9, 21, 0eb86d391h, RBx ; 64 387 | 388 | Pop RSi ; get State pointer from stack 389 | Add [RSi], EAx 390 | Add [RSi+4], EBx 391 | Add [RSi+8], ECx 392 | Add [RSi+12], EDx 393 | 394 | ; restore volatile registers 395 | Pop R14 396 | Pop R13 397 | Pop R12 398 | Pop RBp 399 | 400 | Pop RDi 401 | Pop RSi 402 | Pop RBx 403 | 404 | Ret 405 | MD5_Transform EndP 406 | 407 | End 408 | 409 | ; That's All Folks! 410 | -------------------------------------------------------------------------------- /Source/md5_64.obj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PassByYou888/CoreCipher/c3757295fe4e252b42187e1a28f21588b57b6728/Source/md5_64.obj -------------------------------------------------------------------------------- /Source/zDefine.inc: -------------------------------------------------------------------------------- 1 | { * https://zpascal.net * } 2 | { * https://github.com/PassByYou888/zAI * } 3 | { * https://github.com/PassByYou888/ZServer4D * } 4 | { * https://github.com/PassByYou888/PascalString * } 5 | { * https://github.com/PassByYou888/zRasterization * } 6 | { * https://github.com/PassByYou888/CoreCipher * } 7 | { * https://github.com/PassByYou888/zSound * } 8 | { * https://github.com/PassByYou888/zChinese * } 9 | { * https://github.com/PassByYou888/zExpression * } 10 | { * https://github.com/PassByYou888/zGameWare * } 11 | { * https://github.com/PassByYou888/zAnalysis * } 12 | { * https://github.com/PassByYou888/FFMPEG-Header * } 13 | { * https://github.com/PassByYou888/zTranslate * } 14 | { * https://github.com/PassByYou888/InfiniteIoT * } 15 | { * https://github.com/PassByYou888/FastMD5 * } 16 | { ****************************************************************************** } 17 | 18 | {$IFDEF FPC} 19 | {$IFDEF FPC_DELPHI_MODE} 20 | {$MODE delphi} 21 | {$ELSE FPC_DELPHI_MODE} 22 | {$MODE objfpc} 23 | {$ENDIF FPC_DELPHI_MODE} 24 | 25 | {$MODESWITCH AdvancedRecords} 26 | {$MODESWITCH NestedProcVars} 27 | {$MODESWITCH NESTEDCOMMENTS} 28 | {$NOTES OFF} 29 | {$STACKFRAMES OFF} 30 | {$COPERATORS OFF} 31 | {$GOTO ON} 32 | {$INLINE ON} 33 | {$MACRO ON} 34 | {$HINTS ON} 35 | {$IEEEERRORS ON} 36 | 37 | {$DEFINE LITTLE_ENDIAN} 38 | {$UNDEF BIG_ENDIAN} 39 | {$IFDEF FPC_BIG_ENDIAN} 40 | {$UNDEF LITTLE_ENDIAN} 41 | {$DEFINE BIG_ENDIAN} 42 | {$ENDIF} 43 | 44 | {$UNDEF FirstCharInZero} 45 | 46 | {$UNDEF Delphi} 47 | 48 | // nativeint as int or int64 type variable when Modifier is overload 49 | {$UNDEF OVERLOAD_NATIVEINT} 50 | 51 | // fast MD5 only delphi supported, https://github.com/PassByYou888/FastMD5 52 | {$UNDEF FastMD5} 53 | 54 | // stream is MemoryStream64 or MemoryStream, usage fastMD5 or PurePascal MD5 55 | // be associate api: UnicodeMixedLib.umlStreamMD5, Fast_MD5.FastMD5 56 | {$DEFINE OptimizationMemoryStreamMD5} 57 | 58 | // multi thread Parallel switch. 59 | {$DEFINE Parallel} 60 | 61 | // Parallel for fold make better use CPU of multi core 62 | // if rem this "FoldParallel" parallel for block program, thread can use linear address 63 | {$DEFINE FoldParallel} 64 | 65 | // MT19937 of seed in the startup TCompute is 0 66 | {$DEFINE MT19937SeedOnTComputeThreadIs0} 67 | 68 | // automated loading common AI datasets on boot-time 69 | {$DEFINE Z_AI_Dataset_Build_In} 70 | 71 | // With SMALL_RASTER_FONT_Build_In and LARGE_RASTER_FONT_Build_In, boot-time memory usage increase by 100M-200M and start-up time to be delay 100ms 72 | {$DEFINE SMALL_RASTER_FONT_Build_In} 73 | // {$DEFINE LARGE_RASTER_FONT_Build_In} 74 | 75 | // ZDB_BACKUP is automatically made and replica caching is enabled. 76 | // usage ZDB_BACKUP so slows the open of large size ZDB file, after time, but does is high performance. 77 | // {$DEFINE ZDB_BACKUP} 78 | 79 | // ZDB Flush() uses physical IO as the temp storage device 80 | // {$DEFINE ZDB_PHYSICAL_FLUSH} 81 | 82 | // used Critical Simulate Atomic with TMonitor.Enter(obj) and TMonitor.Exit(obj) 83 | // CriticalSimulateAtomic defined so performance to be reduced 84 | {$DEFINE CriticalSimulateAtomic} 85 | 86 | // used soft Simulate Critical(ring) 87 | // SoftCritical defined so performance to be reduced 88 | // {$DEFINE SoftCritical} 89 | // {$DEFINE ANTI_DEAD_ATOMIC_LOCK} 90 | 91 | {$UNDEF debug} 92 | {$DEFINE release} 93 | {$DEFINE INLINE_ASM} 94 | {$R-} 95 | {$I-} 96 | {$S-} 97 | {$OPTIMIZATION ON} 98 | {$ELSE FPC} { IF DELPHI } 99 | {$DEFINE Delphi} 100 | 101 | {$DEFINE LITTLE_ENDIAN} 102 | {$UNDEF BIG_ENDIAN} 103 | 104 | {$IFDEF ANDROID} 105 | {$DEFINE FirstCharInZero} 106 | {$ENDIF ANDROID} 107 | 108 | {$IFDEF IOS} 109 | {$DEFINE FirstCharInZero} 110 | {$ENDIF IOS} 111 | 112 | // nativeint as int or int64 type variable when Modifier is overload 113 | {$DEFINE OVERLOAD_NATIVEINT} 114 | 115 | // fast MD5 only delphi supported, https://github.com/PassByYou888/FastMD5 116 | {$DEFINE FastMD5} 117 | 118 | // stream is MemoryStream64 or MemoryStream, usage fastMD5 or PurePascal MD5 119 | // be associate api: UnicodeMixedLib.umlStreamMD5, Fast_MD5.FastMD5 120 | {$DEFINE OptimizationMemoryStreamMD5} 121 | 122 | // multi thread Parallel switch. 123 | {$DEFINE Parallel} 124 | 125 | // Parallel for fold make better use CPU of multi core 126 | // if rem this "FoldParallel" is parallel for block program, thread can use linear address 127 | {$DEFINE FoldParallel} 128 | 129 | // Parallel programs use the delphi default TParallel 130 | // {$DEFINE SystemParallel} 131 | 132 | // paper: Mersenne Twister: A 623-dimensionallyequidistributed uniformpseudorandom number generator 133 | // Using this paper replace of Delphi Random() and Randomize() function, work on xe 10.3 or laster 134 | {$UNDEF InstallMT19937CoreToDelphi} 135 | 136 | // delphi 10.3 137 | {$IFDEF VER330} 138 | {$DEFINE InstallMT19937CoreToDelphi} 139 | {$ENDIF VER330} 140 | 141 | // delphi 10.4 142 | {$IFDEF VER340} 143 | {$DEFINE InstallMT19937CoreToDelphi} 144 | {$UNDEF FirstCharInZero} 145 | {$ENDIF VER340} 146 | 147 | // delphi 11.0 148 | {$IFDEF VER350} 149 | {$DEFINE InstallMT19937CoreToDelphi} 150 | {$UNDEF FirstCharInZero} 151 | {$ENDIF VER350} 152 | 153 | // delphi 11.x 154 | {$IFDEF VER360} 155 | {$DEFINE InstallMT19937CoreToDelphi} 156 | {$UNDEF FirstCharInZero} 157 | {$ENDIF VER360} 158 | 159 | // MT19937 of seed in the startup TCompute is 0 160 | {$DEFINE MT19937SeedOnTComputeThreadIs0} 161 | 162 | // automated loading common AI datasets on boot-time 163 | // {$DEFINE Z_AI_Dataset_Build_In} 164 | 165 | // With SMALL_RASTER_FONT_Build_In and LARGE_RASTER_FONT_Build_In, boot-time memory usage increase by 100M-200M and start-up time to be delay 100ms 166 | // {$DEFINE SMALL_RASTER_FONT_Build_In} 167 | // {$DEFINE LARGE_RASTER_FONT_Build_In} 168 | 169 | {$IF Defined(Android) or Defined(IOS)} 170 | {$DEFINE SMALL_RASTER_FONT_Build_In} 171 | {$ENDIF} 172 | 173 | // ZDB_BACKUP is automatically made and replica caching is enabled. 174 | // usage ZDB_BACKUP so slows the open of large size ZDB file, after time, but does is high performance. 175 | // {$DEFINE ZDB_BACKUP} 176 | 177 | // ZDB Flush() uses physical IO as the temp storage device 178 | // {$DEFINE ZDB_PHYSICAL_FLUSH} 179 | 180 | // used Critical Simulate Atomic with TMonitor.Enter(obj) and TMonitor.Exit(obj) 181 | // CriticalSimulateAtomic defined so performance to be reduced 182 | // {$DEFINE CriticalSimulateAtomic} 183 | 184 | // used soft Simulate Critical(ring) 185 | // SoftCritical defined so performance to be reduced 186 | // {$DEFINE SoftCritical} 187 | // {$DEFINE ANTI_DEAD_ATOMIC_LOCK} 188 | 189 | {$IFDEF release} 190 | {$DEFINE INLINE_ASM} 191 | {$R-} { range check } 192 | {$I-} { Input output checking } 193 | {$IF Defined(Android) or Defined(IOS)} 194 | {$O-} { close optimization } 195 | {$ELSE} 196 | {$O+} { open optimization } 197 | {$INLINE AUTO} { inline } 198 | {$IFEND} 199 | {$ELSE} 200 | {$UNDEF INLINE_ASM} 201 | {$O-} { close optimization } 202 | {$R-} { range check } 203 | {$I-} { Input output checking } 204 | {$D+} { debug information } 205 | {$ENDIF} 206 | 207 | {$IF Defined(Android) or Defined(IOS)} 208 | {$DEFINE SMALL_RASTER_FONT_Build_In} 209 | {$DEFINE PhysicsIO_On_Indy} 210 | {$ELSE} 211 | // PhysicsIO interface 212 | // {$DEFINE PhysicsIO_On_ICS} 213 | {$DEFINE PhysicsIO_On_CrossSocket} 214 | // {$DEFINE PhysicsIO_On_DIOCP} 215 | // {$DEFINE PhysicsIO_On_Indy} 216 | // {$DEFINE PhysicsIO_On_Synapse} 217 | {$IFEND} 218 | 219 | {$X+} { Extended syntax } 220 | {$Z1} { Minimum enum size } 221 | {$ENDIF FPC} 222 | 223 | // ZDB2.0 optimized TMemoryStream/TMemoryStream64 for Replace 224 | {$DEFINE ZDB2_Core_Used_Mem64} 225 | 226 | // Using fillchar replace of FillPtr 227 | // Maybe fillchar works on MMX / SSE2, 228 | // {$Define FillPtr_Used_FillChar} 229 | 230 | // Using Move replace of CopyPtr 231 | // {$Define CopyPtr_Used_Move} 232 | 233 | // Sequence packets default are opened in Physics-IO 234 | // Sequence package can support multi platform keep-alive mode 235 | // building a network CS system, the symmetry of compiler(FPC/Delphi) "UsedSequencePacket" 236 | {$DEFINE UsedSequencePacket} 237 | 238 | // Sequence package can support multi platform keep-alive mode 239 | // building a network CS system, the symmetry of compiler(FPC/Delphi) "UsedSequencePacketOnP2PVM" 240 | // Sequence packets default are closed in P2PVM-IO 241 | {$UNDEF UsedSequencePacketOnP2PVM} 242 | 243 | // CommunicationFramework used QuietMode 244 | {$UNDEF Communication_QuietMode} 245 | 246 | {$IFDEF DEBUG} 247 | // initialization status prompt 248 | {$DEFINE initializationStatus} 249 | // warning prompt 250 | {$WARNINGS ON} 251 | // JPEG support can output debug info 252 | {$UNDEF JPEG_Debug} 253 | {$ELSE DEBUG} 254 | // initialization status prompt 255 | {$UNDEF initializationStatus} 256 | // warning prompt 257 | {$WARNINGS OFF} 258 | // JPEG support can output debug info 259 | {$UNDEF JPEG_Debug} 260 | {$ENDIF DEBUG} 261 | 262 | {$IFDEF Parallel} 263 | // TMemoryRaster Parallel switch. 264 | {$UNDEF MemoryRaster_Parallel} 265 | // TRasterVertex Parallel switch. 266 | {$UNDEF Vertex_Parallel} 267 | // TMorphomatics Parallel switch. 268 | {$DEFINE Morphomatics_Parallel} 269 | // TMorphologyBinaryzation Parallel switch. 270 | {$DEFINE MorphologyBinaryzation_Parallel} 271 | {$ENDIF Parallel} 272 | 273 | {$HINTS OFF} 274 | {$C+} { Assertions } 275 | {$M-} { Run-Time Type Information } 276 | {$H+} { long string } 277 | {$A+} { Word Align Data } 278 | {$Q-} { Overflow checking } 279 | {$B-} { Complete boolean evaluation } 280 | {$J+} { Writeable typed constants } 281 | 282 | (* 283 | Pointer math is simply treating any given typed pointer in some narrow, 284 | instances as a scaled ordinal where you can perform simple arithmetic operations directly on the pointer variable. 285 | *) 286 | {$POINTERMATH OFF} 287 | 288 | {$UNDEF CPU64} 289 | 290 | {$IFDEF CPU64BITS} 291 | {$DEFINE CPU64} 292 | {$ELSE CPU64BITS} 293 | {$IFDEF CPUX64} 294 | {$DEFINE CPU64} 295 | {$ENDIF CPUX64} 296 | {$ENDIF CPU64BITS} 297 | 298 | {$IFNDEF CPU64} 299 | {$DEFINE CPU32} 300 | {$ENDIF CPU64} 301 | 302 | {$IFDEF BIG_ENDIAN} 303 | {$MESSAGE FATAL 'Big-endian system not supported'} 304 | {$ENDIF BIG_ENDIAN} 305 | 306 | {$IFOPT R+} 307 | {$DEFINE RangeCheck} 308 | {$ENDIF} 309 | 310 | {$IFOPT Q+} 311 | {$DEFINE OverflowCheck} 312 | {$ENDIF} 313 | -------------------------------------------------------------------------------- /clear_with_dcu.bat: -------------------------------------------------------------------------------- 1 | del/s *.dcu 2 | del/s *.o 3 | del/s *.ppu 4 | del/s *.rsm 5 | del/s *.replay 6 | del/s *.loginpackage 7 | del/s *.dres 8 | del/s *.local 9 | del/s *.identcache 10 | del/s *.stat 11 | --------------------------------------------------------------------------------