chroma/lexers/testdata/objectpascal.actual

{*******************************************************}
{            a totally senseless test unit              }
{*******************************************************}

unit UnitLexerTest;

interface

uses
  System.Classes,
  System.SysUtils;

{$SCOPEDENUMS ON}

resourcestring
  sEIsRunning = 'Cannot perform this operation when test is running.';
  sENotRunning = 'Test not running.';

const
  CUNICODE = '<27><>';
  CBUFFERSIZE = 1024;
  CLITERALNUMBERFLOAT = 0.123;
  CLITERALNUMBERHEX = $1F2A3C platform deprecated;
  CInteger = 123;
  CLo = $0A7640000;
  CHi = $00DE0B6B3;
  CEXTENDED: Extended = 1E18;

const
  EmptyString: string = '';
  NullString: PString = @EmptyString;

  (*
    This is
    a multiline
    comment block
  *)

type
  TState = (undefined = -1, hidden, showing);
  TDataBuffer = array [0 .. CBUFFERSIZE - 1] of AnsiChar;

  TFlag = (Default, Unicode);
  TFlags = set of TFlag;

  TIntSet = set of 0 .. SizeOf(Integer) * 8 - 1;

  { This is
    another multiline
    comment block }

  WRec = packed record
    case Integer of
      0: (Lo, Hi: Byte);
      1: (Bytes: array [0 .. 1] of Byte);
  end;

  { Comment }
  // Comment Single

const
  cMultiLineString1 = '''
    some text
    and now '''
    some more text
  ''';

const
  cMultiLineString2 = '''''
    some text
    and now '''
    some more text
  ''''';

var
  fp1: real := 6.123e-22;
  fp2: real := 612.3e-24;
  fp3: real := 61.23e-23;
  fp4: real := 1.1e-8;
  Epsilon: Single = 1E-40;

{$NODEFINE    string       'UnicodeString' } {$OBJTYPENAME string   'NUnicodeString'} { defined in ustring.h }
{-NODEFINE    string       'String'        } {$OBJTYPENAME string   'NUnicodeString'} { defined in ustring.h }
{-EXTERNALSYM ShortInt     'signed char'   } {-OBJTYPENAME ShortInt 'Bzc'}

(*$hints off*) // another valid compiler directive

const
   CLineBreak = {$IFDEF POSIX} _AnsiStr(#10) {$ENDIF}
       {$IFDEF MSWINDOWS} _AnsiStr(#13#10) {$ENDIF};

  IntegerArray  = array[0..$effffff] of Integer;
  PIntegerArray = ^IntegerArray;

  PointerArray = array [0..512*1024*1024 - 2] of Pointer;
  PPointerArray = ^PointerArray;

  TPCharArray = packed array[0..(High(Integer) div SizeOf(PChar))-1] of PChar;
  PPCharArray = ^TPCharArray;

var
  LNativeInt: NativeInt;
  LNativeUInt: NativeUInt;
  LLongInt: LongInt;
  LLongWord: LongWord;
  LInteger: Integer;
  LInt64: Int64;
  LCardinal: Cardinal;
  LUInt64: UInt64;
  LShortInt: ShortInt;
  LSmallInt: SmallInt;
  LFixedInt: FixedInt;
  LByte: Byte;
  LWord: Word;
  LFixedUInt: FixedUInt;
  LInt8: Int8;
  LInt16: Int16;
  LInt32: Int32;
  LUInt8: UInt8;
  LUInt16: UInt16;
  LUInt32: UInt32;
  LReal48: Real48;
  LSingle: Single;
  LDouble: Double;
  LReal: Real;
  LExtended: Extended;
  LComp: Comp;
  LCurrency: Currency;
  LChar: Char;
  LAnsiChar: AnsiChar;
  LWideChar: WideChar;
  LUCS2Char: UCS2Char;
  LUCS4Char: UCS4Char;
  Lstring: string;
  LShortString: ShortString;
  LAnsiString: AnsiString;
  LUnicodeString: UnicodeString;
  LWideString: WideString;
  LRawByteString: RawByteString;
  LUTF8String: UTF8String;
  LFile: File;
  LTextFile: TextFile;
  LText: Text;
  LBoolean: Boolean;
  LByteBool: ByteBool;
  LWordBool: WordBool;
  LLongBool: LongBool;
  LPointer: Pointer;
  LVariant: Variant;
  LOleVariant: OleVariant;

var
  LTSingleRec: TSingleRec; // deprecated
  LTDoubleRec: TDoubleRec; // deprecated
  LTExtended80Rec: TExtended80Rec;
  LTByteArray: TByteArray;
  LTTextBuf: TTextBuf;
  LTVarRec: TVarRec;
  LTWordArray: TWordArray;

var
  LPChar: PChar;
  LPAnsiChar: PAnsiChar;
  LPWideChar: PWideChar;
  LPRawByteString: PRawByteString;
  LPUnicodeString: PUnicodeString;
  LPString: PString;
  LPAnsiString: PAnsiString;
  LPShortString: PShortString;
  LPTextBuf: PTextBuf;
  LPWideString: PWideString;
  LPByte: PByte;
  LPShortInt: PShortInt;
  LPWord: PWord;
  LPSmallInt: PSmallInt;
  LPCardinal: PCardinal;
  LPLongWord: PLongWord;
  LPFixedUInt: PFixedUInt;
  LPLongint: PLongint;
  LPFixedInt: PFixedInt;
  LPUInt64: PUInt64;
  LPInt64: PInt64;
  LPNativeUInt: PNativeUInt;
  LPNativeInt: PNativeInt;
  LPByteArray: PByteArray;
  LPCurrency: PCurrency;
  LPDouble: PDouble;
  LPExtended: PExtended;
  LPSingle: PSingle;
  LPInteger: PInteger;
  LPOleVariant: POleVariant;
  LPVarRec: PVarRec;
  LPVariant: PVariant;
  LPWordArray: PWordArray;
  LPBoolean: PBoolean;
  LPWordBool: PWordBool;
  LPLongBool: PLongBool;
  LPPointer: PPointer;

type
  TLexerPath = class
  strict private
  const
    CLexerFolder = '\LEXER';
{$IFDEF MSWINDOWS}
    class function GetSystemDrivePath: string; static;
    class function GetProgramFilesPath: string; static;
{$ENDIF}
    class function GetTempPath: string; static;
  public
{$IFDEF MSWINDOWS}
    class property SystemDrivePath: string read GetSystemDrivePath;
    class property ProgramFilesPath: string read GetProgramFilesPath;
{$ENDIF}
    class property TempPath: string read GetTempPath;
  end;

type
  ILexerTest = interface
    ['{F2A3AC58-4CBD-4AFB-8ACC-5AA0DCB6E23E}']
    function GetLexerHandle: THandle;
  end;

  [ComponentPlatformsAttribute(pfidWindows)]
  TLexerTest = class(TComponent, ILexerTest)
  private
    FLexerHandle: THandle;
    FTag: NativeInt;
    procedure SetTag(const Value: NativeInt);
  protected
    function GetLexerHandle: THandle;
    property LexerHandle: THandle read GetLexerHandle;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Run;
  published
    property Tag: NativeInt read FTag write SetTag default 0;
  end;

implementation

uses
  System.IOUtils;

function AllocateLexer: THandle;
begin
  Result := 1; // ???
end;

function GetResult(const AInputString: string): Boolean; // this is hurting
var
  LResult: Boolean;
  LInt: Integer;
  LIntPtr: PInteger;
begin
  Result := False;
  var
    Lstring: string := 'string';
  var
    LString2: string := '''a '' string''';
  if string(Lstring + LString2).Equals(AInputString) then Exit(True)
  else
  begin
    var
      LRes: Integer := 1;
    LResult := (AInputString <> ('some input' + LRes.ToString));
  end;
  if LResult then
  begin
    LInt := 66;
    LIntPtr := @LInt;
    Result := ((Round(1 + 2 - 0.45 * 7 / 10) > Ord(#10).ToExtended)) = True;
    if Result then Result := (LIntPtr^ + PInteger(LInt)^) <> 13;
  end;
  Beep;
  try
    if @Result <> nil then
    begin
      Result := 1 = 2;
    end;
  finally
    Beep;
  end;
  var
    s: string := '<rule pattern="\b(?i:([div][mod][not][and][or][xor][shl][shr][in]))\b">';
  s := s + ' ... this will just work, I''m sure';
  for var res in [1, 2] do
  begin
    s := res.ToString + ' ' + s;
  end;
  var
    start: Integer := 0;
  var
    &end: Integer := 9;
  var
    LChar: Char;
  Beep;
  asm
    test  %eax,%eax // fpc
    mov   %fs:(0x2c),%edx // fpc
    mov   $0x1000000,%eax // fpc assembler
    DB    'a string...',0DH,0AH
    DW    0FFFFH
    DD    0FFFFFFFFH
    CMP   AL,"'"
    JE    @@fd3
  @@fd1:  CALL    @@fd3
    SUB   EAX,7FFFH
  @@fd3:  MOV     AL,[EBX]
    MOV   EAX, [LARGE $42]
    MOV&LChar, 1
  end;
end;

{ TLexerPath }

{$IFDEF MSWINDOWS}
class function TLexerPath.GetProgramFilesPath: string;
{$IFDEF WIN32}
const
  CBACKUPPATH = '\Program Files (x86)';
{$ENDIF}
{$IFDEF WIN64}
const
  CBACKUPPATH = '\Program Files';
{$ENDIF}
begin
{$IFDEF WIN32}
  Result := GetEnvironmentVariable('ProgramFiles(x86)') + CLexerFolder;
  if Result.IsEmpty then Result := GetSystemDrivePath + CBACKUPPATH + CLexerFolder;
{$ENDIF}
{$IFDEF WIN64}
  Result := GetEnvironmentVariable('ProgramW6432') + CLexerFolder;
  if Result.IsEmpty then Result := GetSystemDrivePath + CBACKUPPATH + CLexerFolder;
{$ENDIF}
end;

class function TLexerPath.GetSystemDrivePath: string;
const
  CBACKUPPATH = 'C:';
begin
  Result := GetEnvironmentVariable('SystemDrive');
  if Result.IsEmpty then Result := CBACKUPPATH;
end;
{$ENDIF}

class function TLexerPath.GetTempPath: string;
begin
  Result := System.IOUtils.TPath.GetTempPath + CLexerFolder;
end;

{ TLexerTest }

constructor TLexerTest.Create(AOwner: TComponent);
begin
  inherited Create(nil);
  FTag := 10;
end;

destructor TLexerTest.Destroy;
begin
  inherited Destroy;
end;

function TLexerTest.GetLexerHandle: THandle;
begin
  if FLexerHandle = 0 then FLexerHandle := AllocateLexer;
  Result := FLexerHandle;
end;

procedure TLexerTest.Run;
begin
  // DoIt
end;

procedure TLexerTest.SetTag(const Value: NativeInt);
begin
  if FTag <> Value then FTag := Value;
end;

initialization

// Unit initialization code...

finalization

// Unit finalization code...

end.