aboutsummaryrefslogtreecommitdiffstats
path: root/src/base/UCommon.pas
blob: a52349c088649ae2932713fea1158092253eb8fc (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
{* UltraStar Deluxe - Karaoke Game
 *
 * UltraStar Deluxe is the legal property of its developers, whose names
 * are too numerous to list here. Please refer to the COPYRIGHT
 * file distributed with this source distribution.
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License
 * as published by the Free Software Foundation; either version 2
 * of the License, or (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program; see the file COPYING. If not, write to
 * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
 * Boston, MA 02110-1301, USA.
 *
 * $URL$
 * $Id$
 *}

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 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
{$IF Defined(Linux) or Defined(FreeBSD)}

var
  PrevNumLocale: string;

const
  LC_NUMERIC  = 1;

function setlocale(category: integer; locale: pchar): pchar; cdecl; external 'c' name 'setlocale';

{$IFEND}

// 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
  {$IF Defined(LINUX) or Defined(FreeBSD)}
  PrevNumLocale := setlocale(LC_NUMERIC, nil);
  setlocale(LC_NUMERIC, 'C');
  {$IFEND}
end;

procedure RestoreNumericLocale();
begin
  {$IF Defined(LINUX) or Defined(FreeBSD)}
  setlocale(LC_NUMERIC, PChar(PrevNumLocale));
  {$IFEND}
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
{$IF Defined(Linux) or Defined(FreeBSD)}
  // 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}
  // Windows and Mac OS X do not have case sensitive file systems
  Result := FileExists(FileName);
{$IFEND}
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;

{*
 * FPC uses threadvars (TLS) managed by FPC for console output locking.
 * Using WriteLn() from external threads (like in SDL callbacks)
 * will crash the program as those threadvars have never been initialized.
 * 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)
 *}
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.