aboutsummaryrefslogtreecommitdiffstats
path: root/src/classes/UCommon.pas
diff options
context:
space:
mode:
Diffstat (limited to 'src/classes/UCommon.pas')
-rw-r--r--src/classes/UCommon.pas774
1 files changed, 0 insertions, 774 deletions
diff --git a/src/classes/UCommon.pas b/src/classes/UCommon.pas
deleted file mode 100644
index 41e3c1f1..00000000
--- a/src/classes/UCommon.pas
+++ /dev/null
@@ -1,774 +0,0 @@
-unit UCommon;
-
-interface
-
-{$IFDEF FPC}
- {$MODE Delphi}
-{$ENDIF}
-
-{$I switches.inc}
-
-uses
- SysUtils,
- Classes,
- {$IFDEF MSWINDOWS}
- Windows,
- {$ENDIF}
- sdl,
- UConfig,
- ULog;
-
-type
- TMessageType = ( mtInfo, mtError );
-
-procedure ShowMessage( const msg : String; msgType: TMessageType = mtInfo );
-
-procedure ConsoleWriteLn(const msg: string);
-
-function GetResourceStream(const aName, aType : string): TStream;
-function RWopsFromStream(Stream: TStream): PSDL_RWops;
-
-{$IFDEF FPC}
-function RandomRange(aMin: Integer; aMax: Integer) : Integer;
-{$ENDIF}
-
-function StringReplaceW(text : WideString; search, rep: WideChar):WideString;
-function AdaptFilePaths( const aPath : widestring ): widestring;
-
-procedure DisableFloatingPointExceptions();
-procedure SetDefaultNumericLocale();
-procedure RestoreNumericLocale();
-
-{$IFNDEF MSWINDOWS}
- procedure ZeroMemory( Destination: Pointer; Length: DWORD );
- function MakeLong(a, b: Word): Longint;
- (*
- #define LOBYTE(a) (BYTE)(a)
- #define HIBYTE(a) (BYTE)((a)>>8)
- #define LOWORD(a) (WORD)(a)
- #define HIWORD(a) (WORD)((a)>>16)
- #define MAKEWORD(a,b) (WORD)(((a)&0xff)|((b)<<8))
- *)
-{$ENDIF}
-
-function FileExistsInsensitive(var FileName: string): boolean;
-
-(*
- * Character classes
- *)
-
-function IsAlphaChar(ch: WideChar): boolean;
-function IsNumericChar(ch: WideChar): boolean;
-function IsAlphaNumericChar(ch: WideChar): boolean;
-function IsPunctuationChar(ch: WideChar): boolean;
-function IsControlChar(ch: WideChar): boolean;
-
-// A stable alternative to TList.Sort() (use TList.Sort() if applicable, see below)
-procedure MergeSort(List: TList; CompareFunc: TListSortCompare);
-
-function GetAlignedMem(Size: cardinal; Alignment: integer): Pointer;
-procedure FreeAlignedMem(P: Pointer);
-
-
-implementation
-
-uses
- Math,
- {$IFDEF Delphi}
- Dialogs,
- {$ENDIF}
- UMain;
-
-
-// data used by the ...Locale() functions
-{$IFDEF LINUX}
-
-var
- PrevNumLocale: string;
-
-const
- LC_NUMERIC = 1;
-
-function setlocale(category: integer; locale: pchar): pchar; cdecl; external 'c' name 'setlocale';
-
-{$ENDIF}
-
-// In Linux and maybe MacOSX some units (like cwstring) call setlocale(LC_ALL, '')
-// to set the language/country specific locale (e.g. charset) for this application.
-// Unfortunately, LC_NUMERIC is set by this call too.
-// It defines the decimal-separator and other country-specific numeric settings.
-// This parameter is used by the C string-to-float parsing functions atof() and strtod().
-// After changing LC_NUMERIC some external C-based libs (like projectM) are not
-// able to parse strings correctly
-// (e.g. in Germany "0.9" is not recognized as a valid number anymore but "0,9" is).
-// So we reset the numeric settings to the default ('C').
-// Note: The behaviour of Pascal parsing functions (e.g. strtofloat()) is not
-// changed by this because it doesn't use the locale-settings.
-// TODO:
-// - Check if this is needed in MacOSX (at least the locale is set in cwstring)
-// - Find out which libs are concerned by this problem.
-// If only projectM is concerned by this problem set and restore the numeric locale
-// for each call to projectM instead of changing it globally.
-procedure SetDefaultNumericLocale();
-begin
- {$ifdef LINUX}
- PrevNumLocale := setlocale(LC_NUMERIC, nil);
- setlocale(LC_NUMERIC, 'C');
- {$endif}
-end;
-
-procedure RestoreNumericLocale();
-begin
- {$ifdef LINUX}
- setlocale(LC_NUMERIC, PChar(PrevNumLocale));
- {$endif}
-end;
-
-(*
- * If an invalid floating point operation was performed the Floating-point unit (FPU)
- * generates a Floating-point exception (FPE). Dependending on the settings in
- * the FPU's control-register (interrupt mask) the FPE is handled by the FPU itself
- * (we will call this as "FPE disabled" later on) or is passed to the application
- * (FPE enabled).
- * If FPEs are enabled a floating-point division by zero (e.g. 10.0 / 0.0) is
- * considered an error and an exception is thrown. Otherwise the FPU will handle
- * the error and return the result infinity (INF) (10.0 / 0.0 = INF) without
- * throwing an error to the application.
- * The same applies to a division by INF that either raises an exception
- * (FPE enabled) or returns 0.0 (FPE disabled).
- * Normally (as with C-programs), Floating-point exceptions (FPE) are DISABLED
- * on program startup (at least with Intel CPUs), but for some strange reasons
- * they are ENABLED in pascal (both delphi and FPC) by default.
- * Many libs operating with floating-point values rely heavily on the C-specific
- * behaviour. So using them in delphi is a ticking time-bomb because sooner or
- * later they will crash because of an FPE (this problem occurs massively
- * in OpenGL-based libs like projectM). In contrast to this no error will occur
- * if the lib is linked to a C-program.
- *
- * Further info on FPUs:
- * For x86 and x86_64 CPUs we have to consider two FPU instruction sets.
- * The math co-processor i387 (aka 8087 or x87) set introduced with the i386
- * and SSE (Streaming SIMD Extensions) introduced with the Pentium3.
- * Both of them have separate control-registers (x87: FPUControlWord, SSE: MXCSR)
- * to control FPEs. Either has (among others) 6bits to enable/disable several
- * exception types (Invalid,Denormalized,Zero,Overflow,Underflow,Precision).
- * Those exception-types must all be masked (=1) to get the default C behaviour.
- * The control-registers can be set with the asm-ops FLDCW (x87) and LDMXCSR (SSE).
- * Instead of using assembler code, we can use Set8087CW() provided by delphi and
- * FPC to set the x87 control-word. FPC also provides SetSSECSR() for SSE's MXCSR.
- * Note that both Delphi and FPC enable FPEs (e.g. for div-by-zero) on program
- * startup but only FPC enables FPEs (especially div-by-zero) for SSE too.
- * So we have to mask FPEs for x87 in Delphi and FPC and for SSE in FPC only.
- * FPC and Delphi both provide a SetExceptionMask() for control of the FPE
- * mask. SetExceptionMask() sets the masks for x87 in Delphi and for x87 and SSE
- * in FPC (seems as if Delphi [2005] is not SSE aware). So SetExceptionMask()
- * is what we need and it even is plattform and CPU independent.
- *
- * Pascal OpenGL headers (like the Delphi standard ones or JEDI-SDL headers)
- * already call Set8087CW() to disable FPEs but due to some bugs in the JEDI-SDL
- * headers they do not work properly with FPC. I already patched them, so they
- * work at least until they are updated the next time. In addition Set8086CW()
- * does not suffice to disable FPEs because the SSE FPEs are not disabled by this.
- * FPEs with SSE are a big problem with some libs because many linux distributions
- * optimize code for SSE or Pentium3 (for example: int(INF) which convert the
- * double value "infinity" to an integer might be automatically optimized by
- * using SSE's CVTSD2SI instruction). So SSE FPEs must be turned off in any case
- * to make USDX portable.
- *
- * Summary:
- * Call this function on initialization to make sure FPEs are turned off.
- * It will solve a lot of errors with FPEs in external libs.
- *)
-procedure DisableFloatingPointExceptions();
-begin
- (*
- // We will use SetExceptionMask() instead of Set8087CW()/SetSSECSR().
- // Note: Leave these lines for documentation purposes just in case
- // SetExceptionMask() does not work anymore (due to bugs in FPC etc.).
- {$IF Defined(CPU386) or Defined(CPUI386) or Defined(CPUX86_64)}
- Set8087CW($133F);
- {$IFEND}
- {$IF Defined(FPC)}
- if (has_sse_support) then
- SetSSECSR($1F80);
- {$IFEND}
- *)
-
- // disable all of the six FPEs (x87 and SSE) to be compatible with C/C++ and
- // other libs which rely on the standard FPU behaviour (no div-by-zero FPE anymore).
- SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide,
- exOverflow, exUnderflow, exPrecision]);
-end;
-
-function StringReplaceW(text : WideString; search, rep: WideChar) : WideString;
-var
- iPos : integer;
-// sTemp : WideString;
-begin
-(*
- result := text;
- iPos := Pos(search, result);
- while (iPos > 0) do
- begin
- sTemp := copy(result, iPos + length(search), length(result));
- result := copy(result, 1, iPos - 1) + rep + sTEmp;
- iPos := Pos(search, result);
- end;
-*)
- result := text;
-
- if search = rep then
- exit;
-
- for iPos := 1 to length(result) do
- begin
- if result[iPos] = search then
- result[iPos] := rep;
- end;
-end;
-
-function AdaptFilePaths( const aPath : widestring ): widestring;
-begin
- result := StringReplaceW( aPath, '\', PathDelim );//, [rfReplaceAll] );
-end;
-
-
-{$IFNDEF MSWINDOWS}
-procedure ZeroMemory( Destination: Pointer; Length: DWORD );
-begin
- FillChar( Destination^, Length, 0 );
-end;
-
-function MakeLong(A, B: Word): Longint;
-begin
- Result := (LongInt(B) shl 16) + A;
-end;
-
-(*
-function QueryPerformanceCounter(lpPerformanceCount:TLARGEINTEGER):Bool;
-
- // From http://en.wikipedia.org/wiki/RDTSC
- function RDTSC: Int64; register;
- asm
- rdtsc
- end;
-
-begin
- // Use clock_gettime(CLOCK_REALTIME, ...) here (but not from the libc unit)
- lpPerformanceCount := RDTSC();
- result := true;
-end;
-
-function QueryPerformanceFrequency(lpFrequency:TLARGEINTEGER):Bool;
-begin
- // clock_getres(CLOCK_REALTIME, ...)
- lpFrequency := 0;
- result := true;
-end;
-*)
-{$ENDIF}
-
-// Checks if a regular files or directory with the given name exists.
-// The comparison is case insensitive.
-function FileExistsInsensitive(var FileName: string): boolean;
-var
- FilePath, LocalFileName: string;
- SearchInfo: TSearchRec;
-begin
-{$IFDEF LINUX} // eddie: Changed FPC to LINUX: Windows and Mac OS X dont have case sensitive file systems
- // speed up standard case
- if FileExists(FileName) then
- begin
- Result := true;
- exit;
- end;
-
- Result := false;
-
- FilePath := ExtractFilePath(FileName);
- if (FindFirst(FilePath+'*', faAnyFile, SearchInfo) = 0) then
- begin
- LocalFileName := ExtractFileName(FileName);
- repeat
- if (AnsiSameText(LocalFileName, SearchInfo.Name)) then
- begin
- FileName := FilePath + SearchInfo.Name;
- Result := true;
- break;
- end;
- until (FindNext(SearchInfo) <> 0);
- end;
- FindClose(SearchInfo);
-{$ELSE}
- Result := FileExists(FileName);
-{$ENDIF}
-end;
-
-
-{$IFDEF Unix}
- // include resource-file info (stored in the constant array "resources")
- {$I ../resource.inc}
-{$ENDIF}
-
-function GetResourceStream(const aName, aType: string): TStream;
-{$IFDEF Unix}
-var
- ResIndex: integer;
- Filename: string;
-{$ENDIF}
-begin
- Result := nil;
-
- {$IFDEF Unix}
- for ResIndex := 0 to High(resources) do
- begin
- if (resources[ResIndex][0] = aName ) and
- (resources[ResIndex][1] = aType ) then
- begin
- try
- Filename := ResourcesPath + resources[ResIndex][2];
- Result := TFileStream.Create(Filename, fmOpenRead);
- except
- Log.LogError('Failed to open: "'+ resources[ResIndex][2] +'"', 'GetResourceStream');
- end;
- exit;
- end;
- end;
- {$ELSE}
- try
- Result := TResourceStream.Create(HInstance, aName , PChar(aType));
- except
- Log.LogError('Invalid resource: "'+ aType + ':' + aName +'"', 'GetResourceStream');
- end;
- {$ENDIF}
-end;
-
-// +++++++++++++++++++++ helpers for RWOpsFromStream() +++++++++++++++
- function SdlStreamSeek( context : PSDL_RWops; offset : Integer; whence : Integer ) : integer; cdecl;
- var
- stream : TStream;
- origin : Word;
- begin
- stream := TStream( context.unknown );
- if ( stream = nil ) then
- raise EInvalidContainer.Create( 'SDLStreamSeek on nil' );
- case whence of
- 0 : origin := soFromBeginning; // Offset is from the beginning of the resource. Seek moves to the position Offset. Offset must be >= 0.
- 1 : origin := soFromCurrent; // Offset is from the current position in the resource. Seek moves to Position + Offset.
- 2 : origin := soFromEnd;
- else
- origin := soFromBeginning; // just in case
- end;
- Result := stream.Seek( offset, origin );
- end;
-
- function SdlStreamRead( context : PSDL_RWops; Ptr : Pointer; size : Integer; maxnum: Integer ) : Integer; cdecl;
- var
- stream : TStream;
- begin
- stream := TStream( context.unknown );
- if ( stream = nil ) then
- raise EInvalidContainer.Create( 'SDLStreamRead on nil' );
- try
- Result := stream.read( Ptr^, Size * maxnum ) div size;
- except
- Result := -1;
- end;
- end;
-
- function SDLStreamClose( context : PSDL_RWops ) : Integer; cdecl;
- var
- stream : TStream;
- begin
- stream := TStream( context.unknown );
- if ( stream = nil ) then
- raise EInvalidContainer.Create( 'SDLStreamClose on nil' );
- stream.Free;
- Result := 1;
- end;
-// -----------------------------------------------
-
-(*
- * Creates an SDL_RWops handle from a TStream.
- * The stream and RWops must be freed by the user after usage.
- * Use SDL_FreeRW(...) to free the RWops data-struct.
- *)
-function RWopsFromStream(Stream: TStream): PSDL_RWops;
-begin
- Result := SDL_AllocRW();
- if (Result = nil) then
- Exit;
-
- // set RW-callbacks
- with Result^ do
- begin
- unknown := TUnknown(Stream);
- seek := SDLStreamSeek;
- read := SDLStreamRead;
- write := nil;
- close := SDLStreamClose;
- type_ := 2;
- end;
-end;
-
-
-
-{$IFDEF FPC}
-function RandomRange(aMin: Integer; aMax: Integer) : Integer;
-begin
- RandomRange := Random(aMax-aMin) + aMin ;
-end;
-{$ENDIF}
-
-
-{$IFDEF FPC}
-var
- MessageList: TStringList;
- ConsoleHandler: TThreadID;
- // Note: TRTLCriticalSection is defined in the units System and Libc, use System one
- ConsoleCriticalSection: System.TRTLCriticalSection;
- ConsoleEvent: PRTLEvent;
- ConsoleQuit: boolean;
-{$ENDIF}
-
-(*
- * Write to console if one is available.
- * It checks if a console is available before output so it will not
- * crash on windows if none is available.
- * Do not use this function directly because it is not thread-safe,
- * use ConsoleWriteLn() instead.
- *)
-procedure _ConsoleWriteLn(const aString: string); {$IFDEF HasInline}inline;{$ENDIF}
-begin
- {$IFDEF MSWINDOWS}
- // sanity check to avoid crashes with writeln()
- if (IsConsole) then
- begin
- {$ENDIF}
- Writeln(aString);
- {$IFDEF MSWINDOWS}
- end;
- {$ENDIF}
-end;
-
-{$IFDEF FPC}
-{*
- * The console-handlers main-function.
- * TODO: create a quit-event on closing.
- *}
-function ConsoleHandlerFunc(param: pointer): PtrInt;
-var
- i: integer;
- quit: boolean;
-begin
- quit := false;
- while (not quit) do
- begin
- // wait for new output or quit-request
- RTLeventWaitFor(ConsoleEvent);
-
- System.EnterCriticalSection(ConsoleCriticalSection);
- // output pending messages
- for i := 0 to MessageList.Count-1 do
- begin
- _ConsoleWriteLn(MessageList[i]);
- end;
- MessageList.Clear();
-
- // use local quit-variable to avoid accessing
- // ConsoleQuit outside of the critical section
- if (ConsoleQuit) then
- quit := true;
-
- RTLeventResetEvent(ConsoleEvent);
- System.LeaveCriticalSection(ConsoleCriticalSection);
- end;
- result := 0;
-end;
-{$ENDIF}
-
-procedure InitConsoleOutput();
-begin
- {$IFDEF FPC}
- // init thread-safe output
- MessageList := TStringList.Create();
- System.InitCriticalSection(ConsoleCriticalSection);
- ConsoleEvent := RTLEventCreate();
- ConsoleQuit := false;
- // must be a thread managed by FPC. Otherwise (e.g. SDL-thread)
- // it will crash when using Writeln.
- ConsoleHandler := BeginThread(@ConsoleHandlerFunc);
- {$ENDIF}
-end;
-
-procedure FinalizeConsoleOutput();
-begin
- {$IFDEF FPC}
- // terminate console-handler
- System.EnterCriticalSection(ConsoleCriticalSection);
- ConsoleQuit := true;
- RTLeventSetEvent(ConsoleEvent);
- System.LeaveCriticalSection(ConsoleCriticalSection);
- WaitForThreadTerminate(ConsoleHandler, 0);
- // free data
- System.DoneCriticalsection(ConsoleCriticalSection);
- RTLeventDestroy(ConsoleEvent);
- MessageList.Free();
- {$ENDIF}
-end;
-
-{*
- * With FPC console output is not thread-safe.
- * Using WriteLn() from external threads (like in SDL callbacks)
- * will damage the heap and crash the program.
- * Most probably FPC uses thread-local-data (TLS) to lock a mutex on
- * the console-buffer. This does not work with external lib's threads
- * because these do not have the TLS data and so it crashes while
- * accessing unallocated memory.
- * The solution is to create an FPC-managed thread which has the TLS data
- * and use it to handle the console-output (hence it is called Console-Handler)
- * It should be safe to do so, but maybe FPC requires the main-thread to access
- * the console-buffer only. In this case output should be delegated to it.
- *
- * TODO: - check if it is safe if an FPC-managed thread different than the
- * main-thread accesses the console-buffer in FPC.
- * - check if Delphi's WriteLn is thread-safe.
- * - check if we need to synchronize file-output too
- *}
-procedure ConsoleWriteLn(const msg: string);
-begin
-{$IFDEF CONSOLE}
- {$IFDEF FPC}
- // TODO: check for the main-thread and use a simple _ConsoleWriteLn() then?
- //GetCurrentThreadThreadId();
- System.EnterCriticalSection(ConsoleCriticalSection);
- MessageList.Add(msg);
- RTLeventSetEvent(ConsoleEvent);
- System.LeaveCriticalSection(ConsoleCriticalSection);
- {$ELSE}
- _ConsoleWriteLn(msg);
- {$ENDIF}
-{$ENDIF}
-end;
-
-procedure ShowMessage(const msg: String; msgType: TMessageType);
-{$IFDEF MSWINDOWS}
-var Flags: Cardinal;
-{$ENDIF}
-begin
-{$IF Defined(MSWINDOWS)}
- case msgType of
- mtInfo: Flags := MB_ICONINFORMATION or MB_OK;
- mtError: Flags := MB_ICONERROR or MB_OK;
- else Flags := MB_OK;
- end;
- MessageBox(0, PChar(msg), PChar(USDXVersionStr()), Flags);
-{$ELSE}
- ConsoleWriteln(msg);
-{$IFEND}
-end;
-
-function IsAlphaChar(ch: WideChar): boolean;
-begin
- // TODO: add chars > 255 when unicode-fonts work?
- case ch of
- 'A'..'Z', // A-Z
- 'a'..'z', // a-z
- #170,#181,#186,
- #192..#214,
- #216..#246,
- #248..#255:
- Result := true;
- else
- Result := false;
- end;
-end;
-
-function IsNumericChar(ch: WideChar): boolean;
-begin
- case ch of
- '0'..'9':
- Result := true;
- else
- Result := false;
- end;
-end;
-
-function IsAlphaNumericChar(ch: WideChar): boolean;
-begin
- Result := (IsAlphaChar(ch) or IsNumericChar(ch));
-end;
-
-function IsPunctuationChar(ch: WideChar): boolean;
-begin
- // TODO: add chars outside of Latin1 basic (0..127)?
- case ch of
- ' '..'/',':'..'@','['..'`','{'..'~':
- Result := true;
- else
- Result := false;
- end;
-end;
-
-function IsControlChar(ch: WideChar): boolean;
-begin
- case ch of
- #0..#31,
- #127..#159:
- Result := true;
- else
- Result := false;
- end;
-end;
-
-(*
- * Recursive part of the MergeSort algorithm.
- * OutList will be either InList or TempList and will be swapped in each
- * depth-level of recursion. By doing this it we can directly merge into the
- * output-list. If we only had In- and OutList parameters we had to merge into
- * InList after the recursive calls and copy the data to the OutList afterwards.
- *)
-procedure _MergeSort(InList, TempList, OutList: TList; StartPos, BlockSize: integer;
- CompareFunc: TListSortCompare);
-var
- LeftSize, RightSize: integer; // number of elements in left/right block
- LeftEnd, RightEnd: integer; // Index after last element in left/right block
- MidPos: integer; // index of first element in right block
- Pos: integer; // position in output list
-begin
- LeftSize := BlockSize div 2;
- RightSize := BlockSize - LeftSize;
- MidPos := StartPos + LeftSize;
-
- // sort left and right halves of this block by recursive calls of this function
- if (LeftSize >= 2) then
- _MergeSort(InList, OutList, TempList, StartPos, LeftSize, CompareFunc)
- else
- TempList[StartPos] := InList[StartPos];
- if (RightSize >= 2) then
- _MergeSort(InList, OutList, TempList, MidPos, RightSize, CompareFunc)
- else
- TempList[MidPos] := InList[MidPos];
-
- // merge sorted left and right sub-lists into output-list
- LeftEnd := MidPos;
- RightEnd := StartPos + BlockSize;
- Pos := StartPos;
- while ((StartPos < LeftEnd) and (MidPos < RightEnd)) do
- begin
- if (CompareFunc(TempList[StartPos], TempList[MidPos]) <= 0) then
- begin
- OutList[Pos] := TempList[StartPos];
- Inc(StartPos);
- end
- else
- begin
- OutList[Pos] := TempList[MidPos];
- Inc(MidPos);
- end;
- Inc(Pos);
- end;
-
- // copy remaining elements to output-list
- while (StartPos < LeftEnd) do
- begin
- OutList[Pos] := TempList[StartPos];
- Inc(StartPos);
- Inc(Pos);
- end;
- while (MidPos < RightEnd) do
- begin
- OutList[Pos] := TempList[MidPos];
- Inc(MidPos);
- Inc(Pos);
- end;
-end;
-
-(*
- * Stable alternative to the instable TList.Sort() (uses QuickSort) implementation.
- * A stable sorting algorithm preserves preordered items. E.g. if sorting by
- * songs by title first and artist afterwards, the songs of each artist will
- * be ordered by title. In contrast to this an unstable algorithm (like QuickSort)
- * may destroy an existing order, so the songs of an artist will not be ordered
- * by title anymore after sorting by artist in the previous example.
- * If you do not need a stable algorithm, use TList.Sort() instead.
- *)
-procedure MergeSort(List: TList; CompareFunc: TListSortCompare);
-var
- TempList: TList;
-begin
- TempList := TList.Create();
- TempList.Count := List.Count;
- if (List.Count >= 2) then
- _MergeSort(List, TempList, List, 0, List.Count, CompareFunc);
- TempList.Free;
-end;
-
-
-type
- // stores the unaligned pointer of data allocated by GetAlignedMem()
- PMemAlignHeader = ^TMemAlignHeader;
- TMemAlignHeader = Pointer;
-
-(**
- * Use this function to assure that allocated memory is aligned on a specific
- * byte boundary.
- * Alignment must be a power of 2.
- *
- * Important: Memory allocated with GetAlignedMem() MUST be freed with
- * FreeAlignedMem(), FreeMem() will cause a segmentation fault.
- *
- * Hint: If you do not need dynamic memory, consider to allocate memory
- * statically and use the {$ALIGN x} compiler directive. Note that delphi
- * supports an alignment "x" of up to 8 bytes only whereas FPC supports
- * alignments on 16 and 32 byte boundaries too.
- *)
-{$WARNINGS OFF}
-function GetAlignedMem(Size: cardinal; Alignment: integer): Pointer;
-var
- OrigPtr: Pointer;
-const
- MIN_ALIGNMENT = 16;
-begin
- // Delphi and FPC (tested with 2.2.0) align memory blocks allocated with
- // GetMem() at least on 8 byte boundaries. Delphi uses a minimal alignment
- // of either 8 or 16 bytes depending on the size of the requested block
- // (see System.GetMinimumBlockAlignment). As we do not want to change the
- // boundary for the worse, we align at least on MIN_ALIGN.
- if (Alignment < MIN_ALIGNMENT) then
- Alignment := MIN_ALIGNMENT;
-
- // allocate unaligned memory
- GetMem(OrigPtr, SizeOf(TMemAlignHeader) + Size + Alignment);
- if (OrigPtr = nil) then
- begin
- Result := nil;
- Exit;
- end;
-
- // reserve space for the header
- Result := Pointer(PtrUInt(OrigPtr) + SizeOf(TMemAlignHeader));
- // align memory
- Result := Pointer(PtrUInt(Result) + Alignment - PtrUInt(Result) mod Alignment);
-
- // set header with info on old pointer for FreeMem
- PMemAlignHeader(PtrUInt(Result) - SizeOf(TMemAlignHeader))^ := OrigPtr;
-end;
-{$WARNINGS ON}
-
-{$WARNINGS OFF}
-procedure FreeAlignedMem(P: Pointer);
-begin
- if (P <> nil) then
- FreeMem(PMemAlignHeader(PtrUInt(P) - SizeOf(TMemAlignHeader))^);
-end;
-{$WARNINGS ON}
-
-
-initialization
- InitConsoleOutput();
-
-finalization
- FinalizeConsoleOutput();
-
-end.