unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, SyncObjs, ExtCtrls, ComCtrls, DateUtils;
type
//Deklariramo tip array-a v katerega bomo potem začasno prenašali pdatke
//med branjem in pisanjem
TBuffer = Array[0..2048] of Byte;
//Deklaracija razreda za lažji dostop do podatkov
TBuffZapisovanje = record
//Array tipa TBuffer v katerem bodo podatki, ki jih bomo zapisovali v končno
//datoteko
Buffer: TBuffer;
//Št prebranih znakov
NumRead: Integer;
end;
//Bralna nit
TBranje = class(TThread)
protected
procedure Execute; override;
private
//Št prebranih znakov
NumRead: Integer;
//Dva array-a v katera izmenično zapisujemo podatke
Buffer0: TBuffer;
Buffer1: TBuffer;
//Določa, v kater array bomo podatke zapisovali in iz katerega brali
SecondBuffer: Boolean;
//Ime vhodne datoteke
FFileName: String;
public
constructor Create(CreateSuspended: Boolean; FileName: String);
end;
//Zapisovalna nit
TZapisovanje = class(TThread)
protected
procedure Execute; override;
private
//Št zapisanih byt-ov
NumWrite: Integer;
//Ime izhodne datoteke
FFileName: String;
public
constructor Create(CreateSuspended: Boolean; FileName: String);
end;
TForm1 = class(TForm)
Button1: TButton;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
Timer1: TTimer;
ProgressBar1: TProgressBar;
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
EZapisano,EPrebrano: Cardinal; //Eventi
Branje: TBranje; //Bralna nit
Zapisovanje: TZapisovanje; //Zapisovalna nit
BuffZapisovanje: TBuffZapisovanje; //Buffer za zapisovanje
Vhodna: File of Byte; //Vhodna datoteka
Izhodna: File of Byte; //Izhodna datoteka
Velikost, Zapisano, ZapisanoPrej, Hitrost: Real; //Spremenljivke s pomočjo katerih
//spremljamo napredek
Delaj: Boolean; //Potrebno za predhodno prekinitev kopiranja
Zacetek: TTime; //Čas, kdaj se je kopiranje začelo
implementation
{$R *.dfm}
constructor TBranje.Create(CreateSuspended: Boolean; FileName: String);
begin
FreeOnTerminate := True;
Inherited Create(CreateSuspended);
FFileName := FileName;
end;
constructor TZapisovanje.Create(CreateSuspended: Boolean; FileName: String);
begin
FreeOnTerminate := True;
Inherited Create(CreateSuspended);
FFileName := FileName;
end;
procedure TBranje.Execute;
begin
//Dodelimo vhodni datoteki ime fizične datoteke na disku
AssignFile(Vhodna, FFileName);
//Določimo samo bralni dostop do datoteke, pomembno, če hočemo prebrati datoteko
//ki je označena samo za branje (npr. iz CD-ja)
FileMode := 0;
//Odpremo obstoječo datoteko za branje
Reset(Vhodna);
//Preberemo velikost izvorne datoteke
Velikost := FileSize(Vhodna);
repeat
//S pomočjo dveh array-ov omogočimo da se istočasno, ko se podatki iz izvorne
//datoteke prenašajo v en array, podatki zi drugega array-a zapisujejo v končno
//datoteko in sicer z uporabo druge niti.
if SecondBuffer then
begin
BlockRead(Vhodna, Buffer0, SizeOf(TBuffer),NumRead);
end
else begin
BlockRead(Vhodna, Buffer1, SizeOf(TBuffer),NumRead);
end;
//Počakamo, da zapisovalna nit zapiše vse podatke, šele nato spremenimo
//vsebino zapisovalnega bufferja na na vsebin, ki smo jo prej prebrali iz
//izvorne datoteke
WaitForSingleObject(EZapisano,Infinite);
if SecondBuffer then
begin
SecondBuffer := False;
BuffZapisovanje.Buffer := Buffer0;
BuffZapisovanje.NumRead := NumRead;
end
else begin
SecondBuffer := True;
BuffZapisovanje.Buffer := Buffer1;
BuffZapisovanje.NumRead := NumRead;
end;
//Sprožimo event, s katerim sporočimo zapisovalni niti, da je naslednji blok
//podatkov za zapisovanje pripravljen
SetEvent(EPrebrano);
//Prekinemo izvajanje zanke, kadar je št prebranih podatkov 0 oz. kadar
//zapisovanje prekličemo prekličemo.
until (NumRead = 0) or (Delaj = False);
//Zaoremo vhodno datoteko
CloseFile(Vhodna);
end;
procedure TZapisovanje.Execute;
begin
//Skranimo čas začetka kopiranja
Zacetek := Now;
//Omogočimo timer, s pomočjo katerega prikazujemo napredek kopiranja
Form1.Timer1.Enabled := True;
//Dodelimo izhodni datoteki ime fizične datoteke na disku
AssignFile(Izhodna, FFileName);
//Odpremo datoteko za zapisovanje
Rewrite(Izhodna);
repeat
//Počakamo, da bralna nit prebere prvi blok podatkov
WaitForSingleObject(EPrebrano,Infinite);
//Zapišemo blok podatkov, ki smo ga prej prebrali v bralni niti
BlockWrite(Izhodna, BuffZapisovanje.Buffer, BuffZapisovanje.NumRead, NumWrite);
//Povečamo spremenljivko Zapisano za št. zapisanih podatkov trenutnega bloka
//s pomočjo katere spremljamo napredek
Zapisano := Zapisano + NumWrite;
//Povečamo spremenljivko Hitrost za št. zapisanih podatkov trenutnegs bloka
Hitrost := Hitrost + NumWrite;
//Sporočimo bralni niti, da smo končali zapisali trenuten blok podatkov
SetEvent(EZapisano);
//Zanko prekinemo, če je bilo št podatkov v trenutnem bloku 0 oz. če je bilo
//kopiranje preklicano
until (NumWrite = 0) or (Delaj = False);
//Zapremo izhodno datoteko
CloseFile(Izhodna);
//Ugasnemo timer, ker ga več ne potrebujemo
Form1.Timer1.Enabled := False;
//Izračunamo porabljen čas kopiranja in ga prikašemo s pomočjo TLabel-a
Form1.Label1.Caption := 'Končano v '+IntToStr(SecondsBetween(Now, Zacetek))+' sekundah';
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
//Kreiramo dva eventa, s pomočjo katerih momo usklajevali delovanje naših niti
EPrebrano := CreateEvent(nil,False,False,nil);
EZapisano := CreateEvent(nil,False,False,nil);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
//Ob unučenju forme prekinemo trenutno kopiranje
Delaj := False;
//Zapremo handle od eventov
CloseHandle(EPrebrano);
CloseHandle(EZapisano);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
//Za SaveDialog1.FileNAme določimo golo ime izvorne datoteke brez poti in s
//tem omogočimo lažje kopiranje datoteke, brez spreminjanja njenega imena
SaveDialog1.FileName := ExtractFileNAme(OpenDialog1.FileName);
if SaveDialog1.Execute then
begin
Delaj := True;
//Kreiramo bralno nit in ji hkrati tudi določimo ime vhodne datoteke
Branje := TBranje.Create(False, OpenDialog1.FileName);
//Kreiramo zapisovalno nit in ji hlkrati tudi določimo ime izhodne datoteke
Zapisovanje := TZapisovanje.Create(False, SaveDialog1.FileName);
//Sporočimo bralni niti, da lahko začne z branjem
SetEvent(EZapisano);
end;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
//Nastavimo maksimalno vresnot prograssbar-ja na velikost datoteke
ProgressBar1.Max := Round(Velikost);
//Za pozicijo progressbarja preberemo spremenljivko v kateri imamo zapisano,
//koliko smo že prebrali
ProgressBar1.Position := Round(Zapisano);
//Izračunamo pribljižno hitros prenosa v prejšnji sekundi
Hitrost := Zapisano - ZapisanoPrej;
//V sprem,enljivko zapisano prej shranimo trenutni napredek, in si s tem
//omogočimo izračun za naslednjo sekundo
ZapisanoPrej := Zapisano;
//Prikažemo pribljižno hitrost prenosa v B/s
Form1.Caption := Format('Hitrost prenosa je %.n B/s', [Hitrost]);
end;
end.
unit MemMapFile;
interface
uses
{$IFDEF MSWINDOWS}
Winapi.Windows,
{$ENDIF}
{$IF Defined(NEXTGEN) AND Defined(POSIX)}
Posix.Unistd,
{$ENDIF}
System.Classes, System.SysUtils;
type
TMMFStream = class(TStream)
private
FileHandle : THandle;
{$IFDEF MSWINDOWS}
MapHandle : THandle;
{$ENDIF}
FMemory : Pointer;
FSize : Int64;
FOffset : Integer;
FFileName : String;
public
constructor Create(_FileName : String);
destructor Destroy; override;
function Read(var Buffer; Count : Longint) : Longint; override;
function Write(const Buffer; Count : Longint) : Longint; override;
function Seek(Offset : Longint; Origin : Word) : Longint; override;
function Offset(Offset : Longint) : Pointer;
property Memory : Pointer read FMemory;
property Size : Int64 read FSize;
property FileName : String read FFileName;
end;
implementation
{$IFDEF MSWINDOWS}
procedure RaiseKnownWin32Error(RetVal : Integer);
var
Error : EOSError;
begin
if RetVal <> ERROR_SUCCESS then
Error := EOSError.CreateFmt('Win 32 Error %d:%s', [RetVal,
SysErrorMessage(RetVal)])
else
Error := EOSError.Create('Unknown Win 32 error');
Error.ErrorCode := RetVal;
raise Error;
end;
function Win32CheckKnown(Error : Integer) : Integer;
begin
if Error <> ERROR_SUCCESS then RaiseKnownWin32Error(Error);
Result := Error;
end;
{$ENDIF}
function FileSizeByName(const AFilename: String): Int64;
begin
Result := -1;
if (not FileExists(AFilename)) then
Exit;
// the other cases simply return -1 on error, so make sure to do the same here
try
with TFileStream.Create(AFilename,fmOpenRead or fmShareDenyNone) do
try
Result := Size;
finally
Free;
end;
except
end;
end;
constructor TMMFStream.Create(_FileName : String);
begin
inherited Create;
FMemory := nil;
{$IFDEF MSWINDOWS}
MapHandle := 0;
{$ENDIF}
FileHandle := INVALID_HANDLE_VALUE;
FFileName := _FileName;
FSize := FileSizeByName(_FileName);
if FSize <= 0 then Exit;
{$IFDEF MSWINDOWS}
// Open the file
FileHandle := CreateFile(
PChar(FileName), // File name
GENERIC_READ, // Access (0, GENERIC_READ, GENERIC_WRITE)
FILE_SHARE_READ, // Sharing (0, FILE_SHARE_READ, FILE_SHARE_WRITE)
Nil, // Security settings
OPEN_EXISTING, // How to create
FILE_FLAG_RANDOM_ACCESS, // Flags and attributes
0); // handle of file with attributes to copy
if FileHandle = INVALID_HANDLE_VALUE then Win32CheckKnown(GetLastError);
try
// Create the mapping
MapHandle := CreateFileMapping(
FileHandle,
Nil,
PAGE_READONLY,
0, Cardinal(FSize),
NIL);
if MapHandle = 0 then Win32CheckKnown(GetLastError);
try
// Map it!
FMemory := MapViewOfFile( // Ex?
MapHandle,
FILE_MAP_READ,
0, 0,
Cardinal(FSize));
if FMemory = Nil then Win32CheckKnown(GetLastError);
//raise Exception.Create('Could not map a view of the file');
except
CloseHandle(MapHandle);
MapHandle := 0;
raise;
end;
except
CloseHandle(FileHandle);
FileHandle := INVALID_HANDLE_VALUE;
raise;
end;
{$ELSEIF DEF POSIX}}
// Open the file
FileHandle := Fileopen(_FileName, fmOpenRead or fmShareDenyNone );
if FileHandle = INVALID_HANDLE_VALUE then RaiseLastOSError;
// Map it!
FMemory := mmap(nil,FSize,PROT_READ, MAP_SHARED,FileHandle,0);
if FMemory = Nil then RaiseLastOSError;
{$ELSE}
ShowMessageMultiplatform('MMF not supported on your platform!');
{$ENDIF}
end;
destructor TMMFStream.Destroy;
begin
{$IFDEF MSWINDOWS}
if FMemory <> Nil then
UnmapViewOfFile(FMemory);
if MapHandle <> 0 then CloseHandle(MapHandle);
{$ELSEIF DEF POSIX}}
if FMemory <> Nil then
if munmap(FMemory, FSize) <> 0 then
RaiseLastOSError;
{$ENDIF}
if FileHandle <> INVALID_HANDLE_VALUE then FileClose(FileHandle);
inherited Destroy;
end;
function TMMFStream.Read(var Buffer; Count : Longint) : Longint;
begin
if FOffset + Count > FSize then
Count := FSize - FOffset;
Move(PByte(FMemory)[FOffset], Buffer, Count);
Inc(FOffset, Count);
Result := Count;
end;
function TMMFStream.Write(const Buffer; Count : Longint) : Longint;
begin
Result := 0;
if FOffset + Count > FSize then
Exit;
Move(Buffer, PByte(FMemory)[FOffset], Count);
Inc(FOffset, Count);
Result := Count;
end;
function TMMFStream.Seek(Offset : Longint; Origin : Word) : Longint;
begin
case Origin of
soFromBeginning: FOffset := Offset;
soFromCurrent: FOffset := FOffset + Offset;
soFromEnd: FOffset := FSize - Offset;
end;
Result := FOffset;
end;
function TMMFStream.Offset(Offset : Integer) : Pointer;
begin
if (Offset < 0) or (Offset >= FSize) then
Result := nil
else
Result := @PByte(FMemory)[Offset];
end;
end.
type
HugeByteArray = array[0..High(Integer) div SizeOf(Byte) - 1] of Byte;
HugeWordArray = array[0..High(Integer) div SizeOf(Word) - 1] of Word;
HugeCardinalArray = array[0..High(Integer) div SizeOf(Cardinal) - 1] of Cardinal;
HugeNativeUIntArray = array[0..High(Integer) div SizeOf(NativeUInt) - 1] of NativeUInt;
PMemoryItems = ^TMemoryItems;
TMemoryItems = packed record
case Integer of
0: (Bytes: HugeByteArray);
1: (Words: HugeWordArray);
2: (Cardinals: HugeCardinalArray);
3: (NativeUInts: HugeNativeUIntArray);
4: (A1: array[1..1] of Byte;
case Integer of
0: (Words1: HugeWordArray);
1: (Cardinals1: HugeCardinalArray);
2: (NativeUInts1: HugeNativeUIntArray);
);
5: (A2: array[1..2] of Byte;
case Integer of
0: (Cardinals2: HugeCardinalArray);
1: (NativeUInts2: HugeNativeUIntArray);
);
6: (A3: array[1..3] of Byte;
case Integer of
0: (Cardinals3: HugeCardinalArray);
1: (NativeUInts3: HugeNativeUIntArray);
);
{$ifdef LARGEINT}
7: (A4: array[1..4] of Byte; NativeUInts4: HugeNativeUIntArray);
8: (A5: array[1..5] of Byte; NativeUInts5: HugeNativeUIntArray);
9: (A6: array[1..6] of Byte; NativeUInts6: HugeNativeUIntArray);
10: (A7: array[1..7] of Byte; NativeUInts7: HugeNativeUIntArray);
{$endif}
end;
function IsReservedWord(const Name: string): Boolean;
label
none;
var
Len, i, X: Integer;
S: PChar;
Buffer: array[0..13] of Byte;
begin
Len := Length(Name);
if (Len > 14) then goto none;
S := Pointer(Name);
for i := 0 to Len - 1 do
begin
X := Ord(S[i]);
if (X > $7f) then goto none;
X := X or $20;
Buffer[i] := X;
end;
// byte ascii
Result := True;
with PMemoryItems(@Buffer)^ do
if (Len >= 2) then
case (Bytes[0]) of // "absolute", "abstract", "and", "application", "array", "as", ...
$61: case Len of // "as", "and", "asm", "array", "absolute", "abstract", "assembler", ...
2: if (Bytes[1] = $73) then Exit; // "as"
3: case (Words1[0]) of // "and", "asm"
$646E: Exit; // "and"
$6D73: Exit; // "asm"
end;
5: if (Cardinals1[0] = $79617272) then Exit; // "array"
8: if (Words1[0] = $7362) then
case (Cardinals3[0]) of // "absolute", "abstract"
$74756C6F: if (Bytes[7] = $65) then Exit; // "absolute"
$63617274: if (Bytes[7] = $74) then Exit; // "abstract"
end;
9: case (Cardinals1[0]) of // "assembler", "automated"
$6D657373: if (Cardinals1[1] = $72656C62) then Exit; // "assembler"
$6D6F7475: if (Cardinals1[1] = $64657461) then Exit; // "automated"
end;
11: if (Cardinals1[0] = $696C7070) and (Cardinals1[1] = $69746163) and
(Words1[4] = $6E6F) then Exit; // "application"
end;
$62: case Len of // "byte", "begin", "boolean"
4: if (Cardinals[0] shr 8 = $657479) then Exit; // "byte"
5: if (Cardinals1[0] = $6E696765) then Exit; // "begin"
7: if (Cardinals1[0] = $656C6F6F) and (Words1[2] = $6E61) then Exit; // "boolean"
end;
$63: case Len of // "case", "cdecl", "class", "const", "cardinal", "contains", "constructor"
4: if (Cardinals[0] shr 8 = $657361) then Exit; // "case"
5: case (Cardinals1[0]) of // "cdecl", "class", "const"
$6C636564: Exit; // "cdecl"
$7373616C: Exit; // "class"
$74736E6F: Exit; // "const"
end;
8: case (Cardinals1[0]) of // "cardinal", "contains"
$69647261: if (Cardinals[1] shr 8 = $6C616E) then Exit; // "cardinal"
$61746E6F: if (Cardinals[1] shr 8 = $736E69) then Exit; // "contains"
end;
11: if (Cardinals1[0] = $74736E6F) and (Cardinals1[1] = $74637572) and
(Words1[4] = $726F) then Exit; // "constructor"
end;
$64: case (Bytes[1]) of // "default", "deprecated", "destructor", "dispid", ...
$65: case Len of // "default", "deprecated", "destructor"
7: if (Cardinals2[0] = $6C756166) and (Bytes[6] = $74) then Exit; // "default"
10: case (Cardinals2[0]) of // "deprecated", "destructor"
$63657270: if (Cardinals2[1] = $64657461) then Exit; // "deprecated"
$75727473: if (Cardinals2[1] = $726F7463) then Exit; // "destructor"
end;
end;
$69: case Len of // "div", "dispid", "dispinterface"
3: if (Bytes[2] = $76) then Exit; // "div"
6: if (Cardinals2[0] = $64697073) then Exit; // "dispid"
13: if (Cardinals2[0] = $6E697073) and (Cardinals2[1] = $66726574) and
(Cardinals1[2] shr 8 = $656361) then Exit; // "dispinterface"
end;
$6F: case Len of // "do", "double", "downto"
2: Exit; // "do"
6: case (Cardinals2[0]) of // "double", "downto"
$656C6275: Exit; // "double"
$6F746E77: Exit; // "downto"
end;
end;
$79: if (Len = 7) and (Cardinals2[0] = $696D616E) and (Bytes[6] = $63) then
Exit; // "dynamic"
end;
$65: case (Bytes[1]) of // "else", "end", "except", "export", "exports", "external"
$6C: if (Len = 4) and (Words[1] = $6573) then Exit; // "else"
$6E: if (Len = 3) and (Bytes[2] = $64) then Exit; // "end"
$78: case Len of // "except", "export", "exports", "external"
6: case (Cardinals2[0]) of // "except", "export"
$74706563: Exit; // "except"
$74726F70: Exit; // "export"
end;
7: if (Cardinals2[0] = $74726F70) and (Bytes[6] = $73) then Exit; // "exports"
8: if (Cardinals2[0] = $6E726574) and (Words[3] = $6C61) then Exit; // "external"
end;
end;
$66: case Len of // "far", "for", "file", "finally", "forward", "function", "finalization"
3: case (Words1[0]) of // "far", "for"
$7261: Exit; // "far"
$726F: Exit; // "for"
end;
4: if (Cardinals[0] shr 8 = $656C69) then Exit; // "file"
7: case (Cardinals1[0]) of // "finally", "forward"
$6C616E69: if (Words1[2] = $796C) then Exit; // "finally"
$6177726F: if (Words1[2] = $6472) then Exit; // "forward"
end;
8: if (Cardinals1[0] = $74636E75) and (Cardinals[1] shr 8 = $6E6F69) then
Exit; // "function"
12: if (Cardinals1[0] = $6C616E69) and (Cardinals1[1] = $74617A69) and
(Cardinals[2] shr 8 = $6E6F69) then Exit; // "finalization"
end;
$67: if (Len = 4) and (Cardinals[0] shr 8 = $6F746F) then Exit; // "goto"
$68: if (Len = 4) and (Cardinals[0] shr 8 = $686769) then Exit; // "high"
$69: case (Bytes[1]) of // "if", "implementation", "implements", "in", "index", ...
$66: if (Len = 2) then Exit; // "if"
$6D: if (Len >= 9) and (Cardinals2[0] = $6D656C70) and
(Cardinals1[1] shr 8 = $746E65) then
case Len of // "implements", "implementation"
10: if (Bytes[9] = $73) then Exit; // "implements"
14: if (Cardinals1[2] = $6F697461) and (Bytes[13] = $6E) then
Exit; // "implementation"
end;
$6E: case Len of // "in", "index", "int64", "inline", "integer", "inherited", ...
2: Exit; // "in"
5: case (Cardinals1[0] shr 8) of // "index", "int64"
$786564: Exit; // "index"
$343674: Exit; // "int64"
end;
6: if (Cardinals2[0] = $656E696C) then Exit; // "inline"
7: if (Cardinals2[0] = $65676574) and (Bytes[6] = $72) then Exit; // "integer"
9: case (Cardinals2[0]) of // "inherited", "interface"
$69726568: if (Cardinals1[1] shr 8 = $646574) then Exit; // "inherited"
$66726574: if (Cardinals1[1] shr 8 = $656361) then Exit; // "interface"
end;
14: if (Cardinals2[0] = $61697469) and (Cardinals2[1] = $617A696C) and
(Cardinals2[2] = $6E6F6974) then Exit; // "initialization"
end;
$73: if (Len = 2) then Exit; // "is"
end;
$6C: case Len of // "low", "label", "local", "library", "longword"
3: if (Words1[0] = $776F) then Exit; // "low"
5: case (Cardinals1[0]) of // "label", "local"
$6C656261: Exit; // "label"
$6C61636F: Exit; // "local"
end;
7: if (Cardinals1[0] = $61726269) and (Words1[2] = $7972) then Exit; // "library"
8: if (Cardinals1[0] = $77676E6F) and (Cardinals[1] shr 8 = $64726F) then
Exit; // "longword"
end;
$6D: case Len of // "mod", "message"
3: if (Words1[0] = $646F) then Exit; // "mod"
7: if (Cardinals1[0] = $61737365) and (Words1[2] = $6567) then Exit; // "message"
end;
$6E: case Len of // "nil", "not", "name", "near", "nodefault"
3: case (Words1[0]) of // "nil", "not"
$6C69: Exit; // "nil"
$746F: Exit; // "not"
end;
4: case (Cardinals[0] shr 8) of // "name", "near"
$656D61: Exit; // "name"
$726165: Exit; // "near"
end;
9: if (Cardinals1[0] = $6665646F) and (Cardinals1[1] = $746C7561) then
Exit; // "nodefault"
end;
$6F: case Len of // "of", "on", "or", "out", "object", "overload", "override"
2: case (Bytes[1]) of // "of", "on", "or"
$66: Exit; // "of"
$6E: Exit; // "on"
$72: Exit; // "or"
end;
3: if (Words1[0] = $7475) then Exit; // "out"
6: if (Cardinals1[0] = $63656A62) and (Bytes[5] = $74) then Exit; // "object"
8: if (Cardinals[0] shr 8 = $726576) then
case (Cardinals[1]) of // "overload", "override"
$64616F6C: Exit; // "overload"
$65646972: Exit; // "override"
end;
end;
$70: case (Bytes[1]) of // "package", "packed", "pascal", "platform", "private", ...
$61: case Len of // "packed", "pascal", "package"
6: case (Cardinals2[0]) of // "packed", "pascal"
$64656B63: Exit; // "packed"
$6C616373: Exit; // "pascal"
end;
7: if (Cardinals2[0] = $67616B63) and (Bytes[6] = $65) then Exit; // "package"
end;
$6C: if (Len = 8) and (Cardinals2[0] = $6F667461) and (Words[3] = $6D72) then
Exit; // "platform"
$72: if (Len >= 7) then
case (Bytes[2]) of // "private", "procedure", "program", "property", "protected"
$69: if (Len = 7) and (Cardinals3[0] = $65746176) then Exit; // "private"
$6F: case Len of // "program", "property", "procedure", "protected"
7: if (Cardinals3[0] = $6D617267) then Exit; // "program"
8: if (Cardinals3[0] = $74726570) and (Bytes[7] = $79) then
Exit; // "property"
9: case (Cardinals3[0]) of // "procedure", "protected"
$75646563: if (Words1[3] = $6572) then Exit; // "procedure"
$74636574: if (Words1[3] = $6465) then Exit; // "protected"
end;
end;
end;
$75: if (Len >= 5) and (Cardinals1[0] shr 8 = $696C62) then
case Len of // "public", "published"
6: if (Bytes[5] = $63) then Exit; // "public"
9: if (Cardinals1[1] = $64656873) then Exit; // "published"
end;
end;
$72: case (Bytes[1]) of // "raise", "read", "readonly", "record", "register", ...
$61: if (Len = 5) and (Cardinals1[0] shr 8 = $657369) then Exit; // "raise"
$65: case Len of // "read", "record", "repeat", "readonly", "register", ...
4: if (Words[1] = $6461) then Exit; // "read"
6: case (Cardinals2[0]) of // "record", "repeat"
$64726F63: Exit; // "record"
$74616570: Exit; // "repeat"
end;
8: case (Cardinals2[0]) of // "readonly", "register", "requires", "resident"
$6E6F6461: if (Words[3] = $796C) then Exit; // "readonly"
$74736967: if (Words[3] = $7265) then Exit; // "register"
$72697571: if (Words[3] = $7365) then Exit; // "requires"
$65646973: if (Words[3] = $746E) then Exit; // "resident"
end;
11: if (Cardinals2[0] = $72746E69) and (Cardinals2[1] = $6375646F) and
(Bytes[10] = $65) then Exit; // "reintroduce"
14: if (Cardinals2[0] = $72756F73) and (Cardinals2[1] = $74736563) and
(Cardinals2[2] = $676E6972) then Exit; // "resourcestring"
end;
end;
$73: case Len of // "set", "shl", "shr", "single", "stored", "string", "stdcall", ...
3: case (Bytes[1]) of // "set", "shl", "shr"
$65: if (Bytes[2] = $74) then Exit; // "set"
$68: case (Bytes[2]) of // "shl", "shr"
$6C: Exit; // "shl"
$72: Exit; // "shr"
end;
end;
6: case (Cardinals1[0]) of // "single", "stored", "string"
$6C676E69: if (Bytes[5] = $65) then Exit; // "single"
$65726F74: if (Bytes[5] = $64) then Exit; // "stored"
$6E697274: if (Bytes[5] = $67) then Exit; // "string"
end;
7: if (Cardinals1[0] = $61636474) and (Words1[2] = $6C6C) then Exit; // "stdcall"
8: case (Cardinals1[0]) of // "safecall", "shortint", "smallint"
$63656661: if (Cardinals[1] shr 8 = $6C6C61) then Exit; // "safecall"
$74726F68: if (Cardinals[1] shr 8 = $746E69) then Exit; // "shortint"
$6C6C616D: if (Cardinals[1] shr 8 = $746E69) then Exit; // "smallint"
end;
end;
$74: case Len of // "to", "try", "then", "type", "threadvar"
2: if (Bytes[1] = $6F) then Exit; // "to"
3: if (Words1[0] = $7972) then Exit; // "try"
4: case (Cardinals[0] shr 8) of // "then", "type"
$6E6568: Exit; // "then"
$657079: Exit; // "type"
end;
9: if (Cardinals1[0] = $61657268) and (Cardinals1[1] = $72617664) then
Exit; // "threadvar"
end;
$75: case Len of // "unit", "uses", "until"
4: case (Cardinals[0] shr 8) of // "unit", "uses"
$74696E: Exit; // "unit"
$736573: Exit; // "uses"
end;
5: if (Cardinals1[0] = $6C69746E) then Exit; // "until"
end;
$76: case Len of // "var", "varargs", "virtual"
3: if (Words1[0] = $7261) then Exit; // "var"
7: case (Cardinals1[0]) of // "varargs", "virtual"
$72617261: if (Words1[2] = $7367) then Exit; // "varargs"
$75747269: if (Words1[2] = $6C61) then Exit; // "virtual"
end;
end;
$77: case Len of // "with", "word", "while", "write", "writeonly", "widestring"
4: case (Cardinals[0] shr 8) of // "with", "word"
$687469: Exit; // "with"
$64726F: Exit; // "word"
end;
5: case (Cardinals1[0]) of // "while", "write"
$656C6968: Exit; // "while"
$65746972: Exit; // "write"
end;
9: if (Cardinals1[0] = $65746972) and (Cardinals1[1] = $796C6E6F) then
Exit; // "writeonly"
10: if (Cardinals1[0] = $73656469) and (Cardinals1[1] = $6E697274) and
(Bytes[9] = $67) then Exit; // "widestring"
end;
$78: if (Len = 3) and (Words1[0] = $726F) then Exit; // "xor"
end;
none:
Result := False;
end;
type HugeByteArray = array[0..High(Integer) div SizeOf(Byte) - 1] of Byte; HugeWordArray = array[0..High(Integer) div SizeOf(Word) - 1] of Word; HugeCardinalArray = array[0..High(Integer) div SizeOf(Cardinal) - 1] of Cardinal; HugeNativeUIntArray = array[0..High(Integer) div SizeOf(NativeUInt) - 1] of NativeUInt; PMemoryItems = ^TMemoryItems; TMemoryItems = packed record case Integer of 0: (Bytes: HugeByteArray); 1: (Words: HugeWordArray); 2: (Cardinals: HugeCardinalArray); 3: (NativeUInts: HugeNativeUIntArray); 4: (A1: array[1..1] of Byte; case Integer of 0: (Words1: HugeWordArray); 1: (Cardinals1: HugeCardinalArray); 2: (NativeUInts1: HugeNativeUIntArray); ); 5: (A2: array[1..2] of Byte; case Integer of 0: (Cardinals2: HugeCardinalArray); 1: (NativeUInts2: HugeNativeUIntArray); ); 6: (A3: array[1..3] of Byte; case Integer of 0: (Cardinals3: HugeCardinalArray); 1: (NativeUInts3: HugeNativeUIntArray); ); {$ifdef LARGEINT} 7: (A4: array[1..4] of Byte; NativeUInts4: HugeNativeUIntArray); 8: (A5: array[1..5] of Byte; NativeUInts5: HugeNativeUIntArray); 9: (A6: array[1..6] of Byte; NativeUInts6: HugeNativeUIntArray); 10: (A7: array[1..7] of Byte; NativeUInts7: HugeNativeUIntArray); {$endif} end; function IsReservedWord(const Name: string): Boolean; label none; var Len, i, X: Integer; S: PChar; Buffer: array[0..13] of Byte; begin Len := Length(Name); if (Len > 14) then goto none; S := Pointer(Name); for i := 0 to Len - 1 do begin X := Ord(S[i]); if (X > $7f) then goto none; X := X or $20; Buffer[i] := X; end; // byte ascii Result := True; with PMemoryItems(@Buffer)^ do if (Len >= 2) then case (Bytes[0]) of // "absolute", "abstract", "and", "application", "array", "as", ... $61: case Len of // "as", "and", "asm", "array", "absolute", "abstract", "assembler", ... 2: if (Bytes[1] = $73) then Exit; // "as" 3: case (Words1[0]) of // "and", "asm" $646E: Exit; // "and" $6D73: Exit; // "asm" end; 5: if (Cardinals1[0] = $79617272) then Exit; // "array" 8: if (Words1[0] = $7362) then case (Cardinals3[0]) of // "absolute", "abstract" $74756C6F: if (Bytes[7] = $65) then Exit; // "absolute" $63617274: if (Bytes[7] = $74) then Exit; // "abstract" end; 9: case (Cardinals1[0]) of // "assembler", "automated" $6D657373: if (Cardinals1[1] = $72656C62) then Exit; // "assembler" $6D6F7475: if (Cardinals1[1] = $64657461) then Exit; // "automated" end; 11: if (Cardinals1[0] = $696C7070) and (Cardinals1[1] = $69746163) and (Words1[4] = $6E6F) then Exit; // "application" end; $62: case Len of // "byte", "begin", "boolean" 4: if (Cardinals[0] shr 8 = $657479) then Exit; // "byte" 5: if (Cardinals1[0] = $6E696765) then Exit; // "begin" 7: if (Cardinals1[0] = $656C6F6F) and (Words1[2] = $6E61) then Exit; // "boolean" end; $63: case Len of // "case", "cdecl", "class", "const", "cardinal", "contains", "constructor" 4: if (Cardinals[0] shr 8 = $657361) then Exit; // "case" 5: case (Cardinals1[0]) of // "cdecl", "class", "const" $6C636564: Exit; // "cdecl" $7373616C: Exit; // "class" $74736E6F: Exit; // "const" end; 8: case (Cardinals1[0]) of // "cardinal", "contains" $69647261: if (Cardinals[1] shr 8 = $6C616E) then Exit; // "cardinal" $61746E6F: if (Cardinals[1] shr 8 = $736E69) then Exit; // "contains" end; 11: if (Cardinals1[0] = $74736E6F) and (Cardinals1[1] = $74637572) and (Words1[4] = $726F) then Exit; // "constructor" end; $64: case (Bytes[1]) of // "default", "deprecated", "destructor", "dispid", ... $65: case Len of // "default", "deprecated", "destructor" 7: if (Cardinals2[0] = $6C756166) and (Bytes[6] = $74) then Exit; // "default" 10: case (Cardinals2[0]) of // "deprecated", "destructor" $63657270: if (Cardinals2[1] = $64657461) then Exit; // "deprecated" $75727473: if (Cardinals2[1] = $726F7463) then Exit; // "destructor" end; end; $69: case Len of // "div", "dispid", "dispinterface" 3: if (Bytes[2] = $76) then Exit; // "div" 6: if (Cardinals2[0] = $64697073) then Exit; // "dispid" 13: if (Cardinals2[0] = $6E697073) and (Cardinals2[1] = $66726574) and (Cardinals1[2] shr 8 = $656361) then Exit; // "dispinterface" end; $6F: case Len of // "do", "double", "downto" 2: Exit; // "do" 6: case (Cardinals2[0]) of // "double", "downto" $656C6275: Exit; // "double" $6F746E77: Exit; // "downto" end; end; $79: if (Len = 7) and (Cardinals2[0] = $696D616E) and (Bytes[6] = $63) then Exit; // "dynamic" end; $65: case (Bytes[1]) of // "else", "end", "except", "export", "exports", "external" $6C: if (Len = 4) and (Words[1] = $6573) then Exit; // "else" $6E: if (Len = 3) and (Bytes[2] = $64) then Exit; // "end" $78: case Len of // "except", "export", "exports", "external" 6: case (Cardinals2[0]) of // "except", "export" $74706563: Exit; // "except" $74726F70: Exit; // "export" end; 7: if (Cardinals2[0] = $74726F70) and (Bytes[6] = $73) then Exit; // "exports" 8: if (Cardinals2[0] = $6E726574) and (Words[3] = $6C61) then Exit; // "external" end; end; $66: case Len of // "far", "for", "file", "finally", "forward", "function", "finalization" 3: case (Words1[0]) of // "far", "for" $7261: Exit; // "far" $726F: Exit; // "for" end; 4: if (Cardinals[0] shr 8 = $656C69) then Exit; // "file" 7: case (Cardinals1[0]) of // "finally", "forward" $6C616E69: if (Words1[2] = $796C) then Exit; // "finally" $6177726F: if (Words1[2] = $6472) then Exit; // "forward" end; 8: if (Cardinals1[0] = $74636E75) and (Cardinals[1] shr 8 = $6E6F69) then Exit; // "function" 12: if (Cardinals1[0] = $6C616E69) and (Cardinals1[1] = $74617A69) and (Cardinals[2] shr 8 = $6E6F69) then Exit; // "finalization" end; $67: if (Len = 4) and (Cardinals[0] shr 8 = $6F746F) then Exit; // "goto" $68: if (Len = 4) and (Cardinals[0] shr 8 = $686769) then Exit; // "high" $69: case (Bytes[1]) of // "if", "implementation", "implements", "in", "index", ... $66: if (Len = 2) then Exit; // "if" $6D: if (Len >= 9) and (Cardinals2[0] = $6D656C70) and (Cardinals1[1] shr 8 = $746E65) then case Len of // "implements", "implementation" 10: if (Bytes[9] = $73) then Exit; // "implements" 14: if (Cardinals1[2] = $6F697461) and (Bytes[13] = $6E) then Exit; // "implementation" end; $6E: case Len of // "in", "index", "int64", "inline", "integer", "inherited", ... 2: Exit; // "in" 5: case (Cardinals1[0] shr 8) of // "index", "int64" $786564: Exit; // "index" $343674: Exit; // "int64" end; 6: if (Cardinals2[0] = $656E696C) then Exit; // "inline" 7: if (Cardinals2[0] = $65676574) and (Bytes[6] = $72) then Exit; // "integer" 9: case (Cardinals2[0]) of // "inherited", "interface" $69726568: if (Cardinals1[1] shr 8 = $646574) then Exit; // "inherited" $66726574: if (Cardinals1[1] shr 8 = $656361) then Exit; // "interface" end; 14: if (Cardinals2[0] = $61697469) and (Cardinals2[1] = $617A696C) and (Cardinals2[2] = $6E6F6974) then Exit; // "initialization" end; $73: if (Len = 2) then Exit; // "is" end; $6C: case Len of // "low", "label", "local", "library", "longword" 3: if (Words1[0] = $776F) then Exit; // "low" 5: case (Cardinals1[0]) of // "label", "local" $6C656261: Exit; // "label" $6C61636F: Exit; // "local" end; 7: if (Cardinals1[0] = $61726269) and (Words1[2] = $7972) then Exit; // "library" 8: if (Cardinals1[0] = $77676E6F) and (Cardinals[1] shr 8 = $64726F) then Exit; // "longword" end; $6D: case Len of // "mod", "message" 3: if (Words1[0] = $646F) then Exit; // "mod" 7: if (Cardinals1[0] = $61737365) and (Words1[2] = $6567) then Exit; // "message" end; $6E: case Len of // "nil", "not", "name", "near", "nodefault" 3: case (Words1[0]) of // "nil", "not" $6C69: Exit; // "nil" $746F: Exit; // "not" end; 4: case (Cardinals[0] shr 8) of // "name", "near" $656D61: Exit; // "name" $726165: Exit; // "near" end; 9: if (Cardinals1[0] = $6665646F) and (Cardinals1[1] = $746C7561) then Exit; // "nodefault" end; $6F: case Len of // "of", "on", "or", "out", "object", "overload", "override" 2: case (Bytes[1]) of // "of", "on", "or" $66: Exit; // "of" $6E: Exit; // "on" $72: Exit; // "or" end; 3: if (Words1[0] = $7475) then Exit; // "out" 6: if (Cardinals1[0] = $63656A62) and (Bytes[5] = $74) then Exit; // "object" 8: if (Cardinals[0] shr 8 = $726576) then case (Cardinals[1]) of // "overload", "override" $64616F6C: Exit; // "overload" $65646972: Exit; // "override" end; end; $70: case (Bytes[1]) of // "package", "packed", "pascal", "platform", "private", ... $61: case Len of // "packed", "pascal", "package" 6: case (Cardinals2[0]) of // "packed", "pascal" $64656B63: Exit; // "packed" $6C616373: Exit; // "pascal" end; 7: if (Cardinals2[0] = $67616B63) and (Bytes[6] = $65) then Exit; // "package" end; $6C: if (Len = 8) and (Cardinals2[0] = $6F667461) and (Words[3] = $6D72) then Exit; // "platform" $72: if (Len >= 7) then case (Bytes[2]) of // "private", "procedure", "program", "property", "protected" $69: if (Len = 7) and (Cardinals3[0] = $65746176) then Exit; // "private" $6F: case Len of // "program", "property", "procedure", "protected" 7: if (Cardinals3[0] = $6D617267) then Exit; // "program" 8: if (Cardinals3[0] = $74726570) and (Bytes[7] = $79) then Exit; // "property" 9: case (Cardinals3[0]) of // "procedure", "protected" $75646563: if (Words1[3] = $6572) then Exit; // "procedure" $74636574: if (Words1[3] = $6465) then Exit; // "protected" end; end; end; $75: if (Len >= 5) and (Cardinals1[0] shr 8 = $696C62) then case Len of // "public", "published" 6: if (Bytes[5] = $63) then Exit; // "public" 9: if (Cardinals1[1] = $64656873) then Exit; // "published" end; end; $72: case (Bytes[1]) of // "raise", "read", "readonly", "record", "register", ... $61: if (Len = 5) and (Cardinals1[0] shr 8 = $657369) then Exit; // "raise" $65: case Len of // "read", "record", "repeat", "readonly", "register", ... 4: if (Words[1] = $6461) then Exit; // "read" 6: case (Cardinals2[0]) of // "record", "repeat" $64726F63: Exit; // "record" $74616570: Exit; // "repeat" end; 8: case (Cardinals2[0]) of // "readonly", "register", "requires", "resident" $6E6F6461: if (Words[3] = $796C) then Exit; // "readonly" $74736967: if (Words[3] = $7265) then Exit; // "register" $72697571: if (Words[3] = $7365) then Exit; // "requires" $65646973: if (Words[3] = $746E) then Exit; // "resident" end; 11: if (Cardinals2[0] = $72746E69) and (Cardinals2[1] = $6375646F) and (Bytes[10] = $65) then Exit; // "reintroduce" 14: if (Cardinals2[0] = $72756F73) and (Cardinals2[1] = $74736563) and (Cardinals2[2] = $676E6972) then Exit; // "resourcestring" end; end; $73: case Len of // "set", "shl", "shr", "single", "stored", "string", "stdcall", ... 3: case (Bytes[1]) of // "set", "shl", "shr" $65: if (Bytes[2] = $74) then Exit; // "set" $68: case (Bytes[2]) of // "shl", "shr" $6C: Exit; // "shl" $72: Exit; // "shr" end; end; 6: case (Cardinals1[0]) of // "single", "stored", "string" $6C676E69: if (Bytes[5] = $65) then Exit; // "single" $65726F74: if (Bytes[5] = $64) then Exit; // "stored" $6E697274: if (Bytes[5] = $67) then Exit; // "string" end; 7: if (Cardinals1[0] = $61636474) and (Words1[2] = $6C6C) then Exit; // "stdcall" 8: case (Cardinals1[0]) of // "safecall", "shortint", "smallint" $63656661: if (Cardinals[1] shr 8 = $6C6C61) then Exit; // "safecall" $74726F68: if (Cardinals[1] shr 8 = $746E69) then Exit; // "shortint" $6C6C616D: if (Cardinals[1] shr 8 = $746E69) then Exit; // "smallint" end; end; $74: case Len of // "to", "try", "then", "type", "threadvar" 2: if (Bytes[1] = $6F) then Exit; // "to" 3: if (Words1[0] = $7972) then Exit; // "try" 4: case (Cardinals[0] shr 8) of // "then", "type" $6E6568: Exit; // "then" $657079: Exit; // "type" end; 9: if (Cardinals1[0] = $61657268) and (Cardinals1[1] = $72617664) then Exit; // "threadvar" end; $75: case Len of // "unit", "uses", "until" 4: case (Cardinals[0] shr 8) of // "unit", "uses" $74696E: Exit; // "unit" $736573: Exit; // "uses" end; 5: if (Cardinals1[0] = $6C69746E) then Exit; // "until" end; $76: case Len of // "var", "varargs", "virtual" 3: if (Words1[0] = $7261) then Exit; // "var" 7: case (Cardinals1[0]) of // "varargs", "virtual" $72617261: if (Words1[2] = $7367) then Exit; // "varargs" $75747269: if (Words1[2] = $6C61) then Exit; // "virtual" end; end; $77: case Len of // "with", "word", "while", "write", "writeonly", "widestring" 4: case (Cardinals[0] shr 8) of // "with", "word" $687469: Exit; // "with" $64726F: Exit; // "word" end; 5: case (Cardinals1[0]) of // "while", "write" $656C6968: Exit; // "while" $65746972: Exit; // "write" end; 9: if (Cardinals1[0] = $65746972) and (Cardinals1[1] = $796C6E6F) then Exit; // "writeonly" 10: if (Cardinals1[0] = $73656469) and (Cardinals1[1] = $6E697274) and (Bytes[9] = $67) then Exit; // "widestring" end; $78: if (Len = 3) and (Words1[0] = $726F) then Exit; // "xor" end; none: Result := False; end;
program Hello; uses Windows; Type TData = array[0..200000000] of Real; PData = ^Tdata; procedure T(); var p:PData; begin p:=VirtualAlloc(nil,4*200000000,MEM_COMMIT ,PAGE_READWRITE); p^[200000]:=10; p^[200001]:=30; p^[200002]:=p^[200001]+p^[200000]; writeln(p^[200002]); VirtualFree(p,0,MEM_RELEASE); end; begin writeln ('Hello, world.') ; T(); readln(); end.
class function InterfaceDefaults.Equals_UStr(Inst: Pointer; Left, Right: PByte): Boolean; label cmp_natives, cmp0, cmp1, cmp2, cmp3, cmp4, cmp5, cmp6, cmp7, cmp8, {$ifdef SMALLINT}cmp9, cmp10, cmp11, cmp12, cmp13, cmp14, cmp15, cmp16,{$endif} done; var Count: NativeUInt; begin if (Left = nil) or (Right = nil) or (Left = Right) then goto done; Dec(Left, SizeOf(Integer)); Dec(Right, SizeOf(Integer)); Count := PInteger(Left)^; if (Integer(Count) <> PInteger(Right)^) then goto done; Count := Count * 2 + 2; Inc(Left, SizeOf(Integer)); Inc(Right, SizeOf(Integer)); {$ifdef LARGEINT} if (Count and 4 <> 0) then begin Count := Count and -4; Inc(Left, Count); Inc(Right, Count); if (PCardinal(Left)^ <> PCardinal(Right)^) then goto done; Dec(Left, Count); Dec(Right, Count); end; {$endif} // natives comparison Count := Count shr {$ifdef LARGEINT}3{$else}2{$endif}; cmp_natives: case Count of {$ifdef SMALLINT} 15: goto cmp15; 14: goto cmp14; 13: goto cmp13; 12: goto cmp12; 11: goto cmp11; 10: goto cmp10; 9: goto cmp9; 8: goto cmp8; {$endif} 7: goto cmp7; 6: goto cmp6; 5: goto cmp5; 4: goto cmp4; 3: goto cmp3; 2: goto cmp2; 1: goto cmp1; 0: goto cmp0; else {$ifdef SMALLINT} cmp16: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp15: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp14: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp13: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp12: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp11: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp10: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp9: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); {$endif} cmp8: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp7: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp6: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp5: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp4: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp3: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp2: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); cmp1: if (PNativeUInt(Left)^ <> PNativeUInt(Right)^) then goto done; Dec(Count); Inc(Left, SizeOf(NativeUInt)); Inc(Right, SizeOf(NativeUInt)); if (Count <> 0) then goto cmp_natives; cmp0: end; // Result := True Left := nil; Right := nil; done: Result := (Left = Right); end;
class function InterfaceDefaults.Equals_UStr(Inst: Pointer; Left, Right: PByte): Boolean; label cmp_natives, cmp0, cmp1, cmp2, cmp3, cmp4, cmp5, cmp6, cmp7, cmp8, {$ifdef SMALLINT}cmp9, cmp10, cmp11, cmp12, cmp13, cmp14, cmp15, cmp16,{$endif} done; const SIZE_LIMIT = 64; NATIVE_LIMIT = SIZE_LIMIT div SizeOf(NativeUInt); var Count, Size: NativeUInt; L, R: PNativeUInt; begin L := Pointer(Left); R := Pointer(Right); if (L = nil) or (R = nil) or (L = R) then goto done; Dec(NativeUInt(L), SizeOf(Integer)); Dec(NativeUInt(R), SizeOf(Integer)); Count := PInteger(L)^; if (Integer(Count) <> PInteger(R)^) then goto done; Count := Count * 2 + 2; Inc(NativeUInt(L), SizeOf(Integer)); Inc(NativeUInt(R), SizeOf(Integer)); {$ifdef LARGEINT} if (Count and 4 <> 0) then begin Count := Count and -4; Inc(NativeUInt(L), Count); Inc(NativeUInt(R), Count); if (PCardinal(L)^ <> PCardinal(R)^) then goto done; Dec(NativeUInt(L), Count); Dec(NativeUInt(R), Count); end; {$endif} // gap natives comparison if (Count < SizeOf(NativeUInt)) then goto cmp0; Size := Count and ((SIZE_LIMIT - 1) and (-SizeOf(NativeUInt))); Count := Count shr {$ifdef LARGEINT}3{$else}2{$endif}; Inc(NativeUInt(L), Size); Inc(NativeUInt(R), Size); case Count and (NATIVE_LIMIT - 1) of {$ifdef SMALLINT} 15: goto cmp15; 14: goto cmp14; 13: goto cmp13; 12: goto cmp12; 11: goto cmp11; 10: goto cmp10; 9: goto cmp9; 8: goto cmp8; {$endif} 7: goto cmp7; 6: goto cmp6; 5: goto cmp5; 4: goto cmp4; 3: goto cmp3; 2: goto cmp2; 1: goto cmp1; 0: goto cmp_natives; else // natives comparison cmp_natives: Inc(NativeUInt(L), SIZE_LIMIT); Inc(NativeUInt(R), SIZE_LIMIT); Dec(Count, NATIVE_LIMIT); {$ifdef SMALLINT} cmp16: if (L[-16] <> R[-16]) then goto done; cmp15: if (L[-15] <> R[-15]) then goto done; cmp14: if (L[-14] <> R[-14]) then goto done; cmp13: if (L[-13] <> R[-13]) then goto done; cmp12: if (L[-12] <> R[-12]) then goto done; cmp11: if (L[-11] <> R[-11]) then goto done; cmp10: if (L[-10] <> R[-10]) then goto done; cmp9: if (L[-9] <> R[-9]) then goto done; {$endif} cmp8: if (L[-8] <> R[-8]) then goto done; cmp7: if (L[-7] <> R[-7]) then goto done; cmp6: if (L[-6] <> R[-6]) then goto done; cmp5: if (L[-5] <> R[-5]) then goto done; cmp4: if (L[-4] <> R[-4]) then goto done; cmp3: if (L[-3] <> R[-3]) then goto done; cmp2: if (L[-2] <> R[-2]) then goto done; cmp1: if (L[-1] <> R[-1]) then goto done; if (Count > NATIVE_LIMIT) then goto cmp_natives; cmp0: end; // Result := True L := nil; R := nil; done: Result := (L = R); end;
function eq(const str, str2: string): Boolean; var len: Cardinal; A, B: PInt64; begin if (str = '') or (str2 = '') then begin if (str = '') and (str2 = '') then Exit(True); Exit(False); end; len := PInteger(PByte(str2) - 4)^; if PInteger(PByte(str) - 4)^ <> len then Exit; len := len * SizeOf(WideChar); A := Pointer(str); B := Pointer(str2); while len >= 8 do begin if A[0] <> B[0] then Exit; Inc(A); Inc(B); Dec(len, 8); end; Result := True; case len of 2: if PWord(A)[0] <> PWord(B)[0] then Result := False; 4: if PInteger(A)[0] <> PInteger(B)[0] then Result := False; 6: begin if PInteger(A)[0] = PInteger(B)[0] then begin Inc(PInteger(A)); Inc(PInteger(B)); if PWord(A)[0] <> PWord(B)[0] then Result := False; end else Result := False; end; end; end;
var A, B: string; i: Cardinal; StartTime: Int64; begin try A := StringOfChar('#', 150); B := Copy(A, 1); if ZStartTime(StartTime) then begin for i := 0 to 10000000 do begin if CompareStr(A, B) < 0 then raise Exception.Create('Упс'); end; Writeln(ZStopTime(StartTime)); end; Readln; except on E: Exception do Writeln(E.ClassName, ': ', E.Message); end; end.
var A, B: string; i: Cardinal; StartTime: Int64; begin try A := StringOfChar('#', 150); B := Copy(A, 1); if ZStartTime(StartTime) then begin for i := 0 to 10000000 do begin if not Equals_UStr2(Pointer(NativeInt(A)), Pointer(NativeInt(B))) then raise Exception.Create('Упс'); end; Writeln(ZStopTime(StartTime)); end; Readln; except on E: Exception do Writeln(E.ClassName, ': ', E.Message); end;
class function InterfaceDefaults.Equals_UStr(Inst: Pointer; Left, Right: PByte): Boolean; label start, differs, equals; var Count: NativeUInt; L, R: PNativeUInt; begin if (Left = Right) then goto equals; if (Left = nil) or (Right = nil) then goto differs; L := Pointer(Left); R := Pointer(Right); Count := {$ifdef SMALLINT}L{$else .LARGEINT}PCardinal(L){$endif}[-1]; if (Cardinal(Count) = {$ifdef SMALLINT}R{$else .LARGEINT}PCardinal(R){$endif}[-1]) then begin start: case {$ifdef SMALLINT}Count{$else}(Count + 1) shr 1{$endif} of 0: begin goto equals; end; {$ifdef SMALLINT}1, 2{$else}1{$endif}: begin if (PCardinal(L)[0] <> PCardinal(R)[0]) then goto differs; goto equals; end; {$ifdef SMALLINT}3, 4{$else}2{$endif}: begin {$ifdef SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; {$else .LARGEINT} if (L[0] <> R[0]) then goto differs; {$endif} goto equals; end; {$ifdef SMALLINT}5, 6{$else}3{$endif}: begin {$ifdef SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; {$else .LARGEINT} if (L[0] <> R[0]) then goto differs; {$endif} if (PCardinal(L)[2] <> PCardinal(R)[2]) then goto differs; goto equals; end; {$ifdef SMALLINT}7, 8{$else}4{$endif}: begin {$ifdef SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; {$else .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; {$endif} goto equals; end; {$ifdef SMALLINT}9, 10{$else}5{$endif}: begin {$ifdef SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; {$else .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; {$endif} if (PCardinal(L)[4] <> PCardinal(R)[4]) then goto differs; goto equals; end; {$ifdef SMALLINT}11, 12{$else}6{$endif}: begin {$ifdef SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; if (L[4] <> R[4]) then goto differs; if (L[5] <> R[5]) then goto differs; {$else .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; {$endif} goto equals; end; {$ifdef SMALLINT}13, 14{$else}7{$endif}: begin {$ifdef SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; if (L[4] <> R[4]) then goto differs; if (L[5] <> R[5]) then goto differs; {$else .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; {$endif} if (PCardinal(L)[6] <> PCardinal(R)[6]) then goto differs; goto equals; end; end; repeat Dec(Count, 16); {$ifdef SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; if (L[4] <> R[4]) then goto differs; if (L[5] <> R[5]) then goto differs; if (L[6] <> R[6]) then goto differs; if (L[7] <> R[7]) then goto differs; {$else .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; {$endif} Inc(NativeUInt(L), 32); Inc(NativeUInt(R), 32); until (NativeInt(Count) < 16); if (NativeInt(Count) > 0) then goto start; end else begin differs: Result := False; Exit; end; equals: Result := True; end;
function GetLabelAddress:UINT; asm mov eax,[esp] end; procedure GotoLabel(const Address:UINT); asm add esp,4 jmp eax end; procedure TForm1.FormCreate(Sender: TObject); var s : WideString; inited : Boolean; l1,l2,l3 : UINT; label Start,MyLabel1,MyLabel2,MyLabel3; begin inited := False; goto MyLabel1; Start: inited := True; case Random(2) of 0: GotoLabel(l1); 1: GotoLabel(l2); 2: GotoLabel(l3); else Exit; end; MyLabel1: l1 := GetLabelAddress; if not inited then goto MyLabel2; s := IntToStr(1); Exit; MyLabel2: l2 := GetLabelAddress; if not inited then goto MyLabel3; s := IntToStr(2); Exit; MyLabel3: l2 := GetLabelAddress; if not inited then goto Start; s := IntToStr(3); Exit; end;
unit Test; interface const { SSE4.2 PCMPxSTRx instructions' programmable control byte } { Bits } //1:0 PCMPxSTRx_UNSIGNED_BYTES = $00; //0000 0000 PCMPxSTRx_UNSIGNED_WORDS = $01; //0000 0001 PCMPxSTRx_SIGNED_BYTES = $02; //0000 0010 PCMPxSTRx_SIGNED_WORDS = $03; //0000 0011 //3:2 PCMPxSTRx_EQUAL_ANY = $00; //0000 0000 PCMPxSTRx_RANGES = $04; //0000 0100 PCMPxSTRx_EQUAL_EACH = $08; //0000 1000 PCMPxSTRx_EQUAL_ORDERED = $0C; //0000 1100 //5:4 PCMPxSTRx_POSITIVE_POLARITY = $00; //0000 0000 PCMPxSTRx_NEGATIVE_POLARITY = $10; //0001 0000 PCMPxSTRx_MASKED_PLUS = $20; //0010 0000 PCMPxSTRx_MASKED_MINUS = $30; //0011 0000 //6 PCMPxSTRi_LEAST_INDEX = $00; //0000 0000 PCMPxSTRi_MOST_INDEX = $40; //0100 0000 PCMPxSTRm_BIT_MASK = $00; //0000 0000 PCMPxSTRm_EXPAND_MASK = $40; //0100 0000 { PCMPISTRx treats #0 as a break. Useful for automation when #0 is not acceptable. PCMPESTRx treats #0 as a normal character. Use when #0 is an acceptable/possible char. } implementation //strings are(?) 16 bytes capable (edge-case, depends on a memory manager). Seems OK. procedure _UStrCmpEx; asm xor eax,eax cmp rcx,rdx je @@exit test rcx,rcx jz @@nullL test rdx,rdx jz @@nullR mov r8,rcx mov r9,rdx mov eax,[rcx-04] mov edx,[rdx-04] mov r11d,eax sub r11d,edx cmp eax,edx cmovg eax,edx mov edx,eax @@next: movdqu xmm1,[r8] pcmpestri xmm1,[r9],PCMPxSTRx_UNSIGNED_WORDS or PCMPxSTRx_EQUAL_EACH or PCMPxSTRx_NEGATIVE_POLARITY jb @@fail add r8,16 add r9,16 sub edx,8 sub eax,8 jg @@next mov eax,r11d ret @@fail: movsx eax,word ptr [r8+rcx*2] movsx ecx,word ptr [r9+rcx*2] sub eax,ecx ret @@nullL: sub eax,[rdx-04] ret @@nullR: mov eax,[rcx-04] @@exit: end; //Winapi structures are not 16 bytes capable storages. Welcome back to the time of 64 MB RAM. procedure _UStrFromArrayEx; asm test r8d,r8d jle System.@UStrFromPCharLen mov r10,rcx mov rax,rdx cmp r8d,16 jl @@tail mov r9d,r8d shr r9d,4 pxor xmm0,xmm0 @@next: pcmpistri xmm0,[rax],PCMPxSTRx_UNSIGNED_BYTES or PCMPxSTRx_EQUAL_EACH lea rax,[rax+rcx] jz @@exit dec r9d jg @@next mov r9d,r8d and r9d,-16 sub r8d,r9d jz @@exit .ALIGN 16 @@tail: cmp byte ptr [rax],$00 je @@exit add rax,1 dec r8d jg @@tail @@exit: sub rax,rdx mov r8d,eax mov rcx,r10 jmp System.@UStrFromPCharLen end; procedure Hook(const Target,Proc:Pointer); var OldHook : Pointer absolute Target; OldProtect : Cardinal; begin if VirtualProtect(OldHook,5,PAGE_EXECUTE_READWRITE,OldProtect) then begin PByte(OldHook)^ := $E9; PUINT(NativeUInt(OldHook)+1)^ := UINT(NativeUInt(Proc)-NativeUInt(OldHook)-5); VirtualProtect(OldHook,5,OldProtect,OldProtect); end; end; initialization Hook(_UStrCmp,@_UStrCmpEx); Hook(_UStrFromArray,@_UStrFromArrayEx);
program Project1; {$APPTYPE CONSOLE} {$R *.res} uses windows, System.SysUtils; function memcmp(ptr1: PAnsiChar; ptr2: PAnsiChar; num: DWORD): Integer; cdecl; external 'Ntdll.dll' name 'memcmp'; function sprintf(S: PAnsiChar; const Format: PAnsiChar): Integer; cdecl; varargs; external 'msvcrt.dll'; {$POINTERMATH ON} function Equals_UStr(Left, Right: PByte): Boolean; label start, differs, equals; var Count: NativeUInt; L, R: PNativeUInt; begin if (Left = Right) then goto equals; if (Left = nil) or (Right = nil) then goto differs; L := Pointer(Left); R := Pointer(Right); Count := {$IFDEF SMALLINT}L{$ELSE .LARGEINT}PCardinal(L){$ENDIF}[-1]; if (Cardinal(Count) = {$IFDEF SMALLINT}R{$ELSE .LARGEINT}PCardinal(R){$ENDIF}[-1]) then begin start: case {$IFDEF SMALLINT}Count{$ELSE}(Count + 1) shr 1{$ENDIF} of 0: begin goto equals; end; {$IFDEF SMALLINT}1, 2{$ELSE}1{$ENDIF}: begin if (PCardinal(L)[0] <> PCardinal(R)[0]) then goto differs; goto equals; end; {$IFDEF SMALLINT}3, 4{$ELSE}2{$ENDIF}: begin {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; {$ENDIF} goto equals; end; {$IFDEF SMALLINT}5, 6{$ELSE}3{$ENDIF}: begin {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; {$ENDIF} if (PCardinal(L)[2] <> PCardinal(R)[2]) then goto differs; goto equals; end; {$IFDEF SMALLINT}7, 8{$ELSE}4{$ENDIF}: begin {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; {$ENDIF} goto equals; end; {$IFDEF SMALLINT}9, 10{$ELSE}5{$ENDIF}: begin {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; {$ENDIF} if (PCardinal(L)[4] <> PCardinal(R)[4]) then goto differs; goto equals; end; {$IFDEF SMALLINT}11, 12{$ELSE}6{$ENDIF}: begin {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; if (L[4] <> R[4]) then goto differs; if (L[5] <> R[5]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; {$ENDIF} goto equals; end; {$IFDEF SMALLINT}13, 14{$ELSE}7{$ENDIF}: begin {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; if (L[4] <> R[4]) then goto differs; if (L[5] <> R[5]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; {$ENDIF} if (PCardinal(L)[6] <> PCardinal(R)[6]) then goto differs; goto equals; end; end; repeat Dec(Count, 16); {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; if (L[4] <> R[4]) then goto differs; if (L[5] <> R[5]) then goto differs; if (L[6] <> R[6]) then goto differs; if (L[7] <> R[7]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; {$ENDIF} Inc(NativeUInt(L), 32); Inc(NativeUInt(R), 32); until (NativeInt(Count) < 16); if (NativeInt(Count) > 0) then goto start; end else begin differs: Result := False; Exit; end; equals: Result := True; end; function ZStartTime(var StartTime: Int64): Boolean; begin Result := QueryPerformanceCounter(StartTime); end; function ZStopTime(const StartTime: Int64): AnsiString; var iCounterPerSec, StopTime: Int64; time: Single; begin if QueryPerformanceCounter(StopTime) then begin if QueryPerformanceFrequency(iCounterPerSec) then begin time := (0 - StartTime + StopTime) / iCounterPerSec; Result := ''; SetLength(Result, 25); SetLength(Result, sprintf(PAnsiChar(Result), 'Result: %f sec.', time)); end else Result := 'Error[ZStopTime(QueryPerformanceFrequency)]'; end else Result := 'Error[ZStopTime(QueryPerformanceCounter)]'; end; var A, B: string; i: Cardinal; StartTime: Int64; L: DWORD; begin try A := StringOfChar('#', 150); B := Copy(A, 1); L := Length(B) * SizeOf(widechar); if ZStartTime(StartTime) then begin for i := 0 to 10000000 do begin // if not Equals_UStr(Pointer(NativeInt(A)), Pointer(NativeInt(B))) then if memcmp(Pointer(A), Pointer(B), L) <> 0 then raise Exception.Create('Упс'); end; Writeln(ZStopTime(StartTime)); end; Readln; except on E: Exception do Writeln(E.ClassName, ': ', E.Message); end; end.
j := AList.FCount; repeat i := 0; if H = PUINT(P)^ then Break; Inc(i); if H = PUINT(NativeUInt(P)+16)^ then Break; Inc(i); if H = PUINT(NativeUInt(P)+32)^ then Break; Inc(i); if H = PUINT(NativeUInt(P)+48)^ then Break; Inc(i); if H = PUINT(NativeUInt(P)+64)^ then Break; Inc(i); if H = PUINT(NativeUInt(P)+80)^ then Break; Inc(i); if H = PUINT(NativeUInt(P)+96)^ then Break; Inc(i); if H = PUINT(NativeUInt(P)+112)^ then Break; P := Pointer(NativeUInt(P)+128); Dec(j,8); until j<=0;
40: // ( case WideToLower[PWord(StrCode + 1)^] of 32: begin { hack } inc(StrCode); while (StrCode^ <> #0) and (StrCode^ = #32) do inc(StrCode); case WideToLower[PWord(StrCode)^] of 0: begin inc(StrCode); CurrentToken := T_PARENTHESES_OPEN; end; 97: // a begin dec(StrCode); goto _Sb10; end; 98: // b begin dec(StrCode); goto _Sb20; end; 100: // d begin dec(StrCode); goto _Sb30; end; 102: // f begin dec(StrCode); goto _Sb40; end; 105: // i begin dec(StrCode); goto _Sb50; end; 111: // o begin dec(StrCode); goto _Sb60; end; 115: // s begin dec(StrCode); goto _Sb70; end; 117: // u begin dec(StrCode); goto _Sb80; end; 112: // p begin dec(StrCode); goto _Sb90; end; 101: // e begin dec(StrCode); goto _Sb91; end; 99: // c begin dec(StrCode); goto _Sb92; end; 114: // r begin dec(StrCode); goto _Sb93; end; else begin CurrentToken := T_PARENTHESES_OPEN; end; end; end; 97: // a _Sb10: case WideToLower[PWord(StrCode + 2)^] of 114: // r case WideToLower[PWord(StrCode + 3)^] of 114: // r case WideToLower[PWord(StrCode + 4)^] of 97: // a case WideToLower[PWord(StrCode + 5)^] of 121: // y case Byte(EngineType(StrCode + 6)^) of 32: begin i := 6; inc(StrCode, 6); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_ARRAY_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_ARRAY_CAST; inc(StrCode, 7); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 98: // b _Sb20: case WideToLower[PWord(StrCode + 2)^] of 105: // i case CharPosLowe(StrCode, 3) of 110: // n case CharPosLowe(StrCode, 4) of 97: // a case CharPosLowe(StrCode, 5) of 114: // r case CharPosLowe(StrCode, 6) of 121: // y case CharPosLowe(StrCode, 7) of 32: begin i := 7; inc(StrCode, 7); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_BINARY_CAST; end else begin dec(StrCode, i); CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 41: // ) begin CurrentToken := T_BINARY_CAST; inc(StrCode, 8); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 111: // o case WideToLower[PWord(StrCode + 3)^] of 111: // o case WideToLower[PWord(StrCode + 4)^] of 108: // l case WideToLower[PWord(StrCode + 5)^] of 32: begin i := 5; inc(StrCode, 5); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_BOOL_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_BOOL_CAST; inc(StrCode, 6); end; 101: // e case WideToLower[PWord(StrCode + 6)^] of 97: // a case WideToLower[PWord(StrCode + 7)^] of 110: // n case WideToLower[PWord(StrCode + 8)^] of 32: begin i := 8; inc(StrCode, 8); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_BOOL_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_BOOL_CAST; inc(StrCode, 9); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 100: // d _Sb30: case WideToLower[PWord(StrCode + 2)^] of 111: // o case WideToLower[PWord(StrCode + 3)^] of 117: // u case WideToLower[PWord(StrCode + 4)^] of 98: // b case WideToLower[PWord(StrCode + 5)^] of 108: // l case WideToLower[PWord(StrCode + 6)^] of 101: // e case Byte(EngineType(StrCode + 7)^) of 32: begin i := 7; inc(StrCode, 7); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_DOUBLE_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_DOUBLE_CAST; inc(StrCode, 8); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 102: // f _Sb40: case WideToLower[PWord(StrCode + 2)^] of 108: // l case WideToLower[PWord(StrCode + 3)^] of 111: // o case WideToLower[PWord(StrCode + 4)^] of 97: // a case WideToLower[PWord(StrCode + 5)^] of 116: // t case Byte(EngineType(StrCode + 6)^) of 32: begin i := 6; inc(StrCode, 6); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_FLOAT_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_FLOAT_CAST; inc(StrCode, 7); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 105: // i _Sb50: case WideToLower[PWord(StrCode + 2)^] of 110: // n case WideToLower[PWord(StrCode + 3)^] of 116: // t case WideToLower[PWord(StrCode + 4)^] of 54: // 6 case WideToLower[PWord(StrCode + 5)^] of 52: // 4 begin case WideToLower[PWord(StrCode + 6)^] of 32: begin i := 6; inc(StrCode, 6); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_INT64_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_INT64_CAST; inc(StrCode, 7); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 32: begin i := 4; inc(StrCode, 4); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_INT_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_INT_CAST; inc(StrCode, 5); end; 101: // e case WideToLower[PWord(StrCode + 5)^] of 103: // g case WideToLower[PWord(StrCode + 6)^] of 101: // e case WideToLower[PWord(StrCode + 7)^] of 114: // r case Byte(EngineType(StrCode + 8)^) of 32: begin i := 8; inc(StrCode, 8); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_INT_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_INT_CAST; inc(StrCode, 9); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 111: // o _Sb60: case WideToLower[PWord(StrCode + 2)^] of 98: // b case WideToLower[PWord(StrCode + 3)^] of 106: // j case WideToLower[PWord(StrCode + 4)^] of 101: // e case WideToLower[PWord(StrCode + 5)^] of 99: // c case WideToLower[PWord(StrCode + 6)^] of 116: // t case Byte(EngineType(StrCode + 7)^) of 32: begin i := 7; inc(StrCode, 7); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_OBJECT_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_OBJECT_CAST; inc(StrCode, 8); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 115: // s _Sb70: case WideToLower[PWord(StrCode + 2)^] of 116: // t case WideToLower[PWord(StrCode + 3)^] of 114: // r case WideToLower[PWord(StrCode + 4)^] of 105: // i case WideToLower[PWord(StrCode + 5)^] of 110: // n case WideToLower[PWord(StrCode + 6)^] of 103: // g case Byte(EngineType(StrCode + 7)^) of 32: begin i := 7; inc(StrCode, 7); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_STRING_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_STRING_CAST; inc(StrCode, 8); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 99: // c _Sb92: case WideToLower[PWord(StrCode + 2)^] of 117: // u case WideToLower[PWord(StrCode + 3)^] of 114: // r case WideToLower[PWord(StrCode + 4)^] of 114: // r case WideToLower[PWord(StrCode + 5)^] of 101: // e case WideToLower[PWord(StrCode + 6)^] of 110: // n case WideToLower[PWord(StrCode + 7)^] of 99: // c case WideToLower[PWord(StrCode + 8)^] of 121: // y case WideToLower[PWord(StrCode + 9)^] of 32: begin i := 9; inc(StrCode, 9); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_CURRENCY_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_CURRENCY_CAST; inc(StrCode, 10); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 101: // e _Sb91: case WideToLower[PWord(StrCode + 2)^] of 120: // x case WideToLower[PWord(StrCode + 3)^] of 116: // t case WideToLower[PWord(StrCode + 4)^] of 101: // e case WideToLower[PWord(StrCode + 5)^] of 110: // n case WideToLower[PWord(StrCode + 6)^] of 100: // d case WideToLower[PWord(StrCode + 7)^] of 101: // e case WideToLower[PWord(StrCode + 8)^] of 100: // d case WideToLower[PWord(StrCode + 9)^] of 32: begin i := 9; inc(StrCode, 9); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_EXTENDED_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_EXTENDED_CAST; inc(StrCode, 10); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 117: // u _Sb80: case WideToLower[PWord(StrCode + 2)^] of 105: // i case WideToLower[PWord(StrCode + 3)^] of 110: // n case WideToLower[PWord(StrCode + 4)^] of 116: // t case WideToLower[PWord(StrCode + 5)^] of 54: // 6 case WideToLower[PWord(StrCode + 6)^] of 52: // 4 case WideToLower[PWord(StrCode + 7)^] of 32: begin i := 7; inc(StrCode, 7); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_UINT64_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_UINT64_CAST; inc(StrCode, 8); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 110: // n case WideToLower[PWord(StrCode + 3)^] of 115: // s case WideToLower[PWord(StrCode + 4)^] of 101: // e case WideToLower[PWord(StrCode + 5)^] of 116: // t case Byte(EngineType(StrCode + 6)^) of 32: begin i := 6; inc(StrCode, 6); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_UNSET_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_UNSET_CAST; inc(StrCode, 7); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 112: // p _Sb90: case WideToLower[PWord(StrCode + 2)^] of 97: // a case WideToLower[PWord(StrCode + 3)^] of 110: // n case WideToLower[PWord(StrCode + 4)^] of 115: // s case WideToLower[PWord(StrCode + 5)^] of 105: // i case WideToLower[PWord(StrCode + 6)^] of 99: // c case WideToLower[PWord(StrCode + 7)^] of 104: // h case WideToLower[PWord(StrCode + 8)^] of 97: // a case WideToLower[PWord(StrCode + 9)^] of 114: // r case WideToLower [PWord(StrCode + 10)^] of 32: begin i := 10; inc(StrCode, 10); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_PANSICHAR_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_PANSICHAR_CAST; inc(StrCode, 11); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 119: // w case WideToLower[PWord(StrCode + 3)^] of 105: // i case WideToLower[PWord(StrCode + 4)^] of 100: // d case WideToLower[PWord(StrCode + 5)^] of 101: // e case WideToLower[PWord(StrCode + 6)^] of 99: // c case WideToLower[PWord(StrCode + 7)^] of 104: // h case WideToLower[PWord(StrCode + 8)^] of 97: // a case WideToLower[PWord(StrCode + 9)^] of 114: // r case WideToLower [PWord(StrCode + 10)^] of 32: begin i := 10; inc(StrCode, 10); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_PWIDECHAR_CAST; end else begin dec(StrCode, i); begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; end; 41: // ) begin CurrentToken := T_PWIDECHAR_CAST; inc(StrCode, 11); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 114: // r _Sb93: case CharPosLowe(StrCode, 2) of 101: // e case CharPosLowe(StrCode, 3) of 97: // a case CharPosLowe(StrCode, 4) of 108: // l case CharPosLowe(StrCode, 5) of 32: begin i := 5; inc(StrCode, 5); while (StrCode^ <> #0) and (StrCode^ = #32) do begin inc(StrCode); inc(i); end; if StrCode^ = ')' then begin inc(StrCode); CurrentToken := T_REAL_CAST; end else begin dec(StrCode, i); CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 41: // ) begin CurrentToken := T_REAL_CAST; inc(StrCode, 6); end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; else begin CurrentToken := T_PARENTHESES_OPEN; inc(StrCode); end; end; 41: // ) begin CurrentToken := T_PARENTHESES_CLOSE; inc(StrCode); end;
function TPhpLexer.Next(var Token: TPhpToken): Boolean; label not_defined; var S: PAnsiChar; X: NativeUInt; Kind: Integer; begin // пределяем тип текущего символа // пропускаем пробелы, в случае чего детектим перевод каретки и окончание файла S := FCurrent; repeat X := CHAR_MODES[S^]; Inc(S); if (X < CHAR_SPACE) then Break; if (X > CHAR_SPACE) then begin Dec(S); if (X = CHAR_CRLF) then begin // перевод каретки: #13, #10, #1310 Inc(S, Byte(PWord(S)^ = (10 shl 8) + 13)); Inc(S); // записываем новое значение линии X := Self.FLine; Inc(X); Self.FLine := X; if (X < Self.FLinesCapacity) then begin Self.FLines[X] := S; end else begin GrowAddLine(S); end; end else begin // CHAR_FINISH: #0 - заканчиваем парсинг FCurrent := S; Result := False; Exit; end; end; until (False); Dec(S); // сохраняем позицию токена Token.Line := Self.Line; Token.Start := S; // в зависимости от первого символа определяем предполагаемый токен // по умолчанию T_STRING Kind := Ord(T_STRING); with PMemoryItems(S)^ do case (X) of CHAR_LETTER: ; CHAR_A: // "as", "and", "array", "abstract" begin case (Bytes[1] or $20) of $73: Kind := Ord(T_AS); // "as" $6E: if (Bytes[2] or $20 = $64) then Kind := Ord(T_LOGICAL_AND); // "and" $72: if (Cardinals1[0] or $20202020 = $79617272) then Kind := Ord(T_ARRAY); // "array" $62: if (Cardinals1[0] or $20202020 = $72747362) and (Cardinals[1] shr 8 or $202020 = $746361) then Kind := Ord(T_ABSTRACT); // "abstract" end; end; CHAR_B: // "break" begin if (Cardinals1[0] or $20202020 = $6B616572) then Kind := Ord(T_BREAK); // "break" end; CHAR_C: // "callable", "case", "catch", "class", "clone", "const", "continue" begin end; CHAR_D: // "do", "die", "declare", "default" begin end; CHAR_E: // "echo", "else", "elseif", "empty", "enddeclare", "endfor", "endforeach", "endif", // "endfor", "endwhile", "endswitch", "enddeclare", "endforeach", "enum", "eval", "exit", "extends" begin end; CHAR_F: // "for", "final", "finally", "foreach", "function" begin end; CHAR_G: // "goto", "global" begin case (Cardinals[0] or $20202020) of $6F746F67: Kind := Ord(T_GOTO); // "goto" $626F6C67: if (Words[3] or $2020 = $6C61) then Kind := Ord(T_GLOBAL); // "global" end; end; CHAR_I: // "if", "implements", "include", "insteadof", "interface", "instanceof", "include_once", // "isset" begin end; CHAR_L: // "list" begin if (Cardinals[0] or $20202020 = $7473696C) then Kind := Ord(T_LIST); // "list" end; CHAR_N: // "new", "namespace" begin end; CHAR_O: // "or" begin if (Bytes[1] or $20 = $72) then Kind := Ord(T_LOGICAL_OR); // "or" end; CHAR_P: // "print", "private", "protected", "public" begin end; CHAR_R: // "return", "require", "require_once" begin end; CHAR_S: // "static", "struct", "switch" begin case (Cardinals1[0] or $20202020) of $69746174: if (Bytes[5] or $20 = $63) then Kind := Ord(T_STATIC); $63757274: if (Bytes[5] or $20 = $74) then Kind := Ord(T_STRUCT); $63746977: if (Bytes[5] or $20 = $68) then Kind := Ord(T_SWITCH); end; end; CHAR_T: // "try", "throw", "trait", "typedef" begin end; CHAR_U: // "use", "union", "unset" begin end; CHAR_V: // "var" begin if (Words1[0] or $2020 = $7261) then Kind := Ord(T_VAR); end; CHAR_W: // "while" begin if (Cardinals1[0] or $20202020 = $656C6968) then Kind := Ord(T_WHILE); // "while" end; CHAR_X: // "xor" begin if (Words1[0] or $2020 = $726F) then Kind := Ord(T_LOGICAL_XOR); // "xor" end; CHAR_UNDER: // "__DIR__", "__FILE__", "__LINE__", "__CLASS__", "__TRAIT__", // "__METHOD__", "__FUNCTION__", "__NAMESPACE__", "__halt_compiler" begin end; CHAR_DIGIT: ; // "0".."9" CHAR_MINUS: // "-", "--", "-=", "->" begin end; CHAR_EXCLAM: // "!", "!=", "!==" begin Kind := Ord(T_NOT); // "!" if (Bytes[1] = $3D) then begin Kind := Ord(T_IS_NOT_EQUAL); // "!=" if (Bytes[2] = $3D) then Kind := Ord(T_IS_NOT_IDENTICAL); // "!==" end; end; CHAR_DOLLAR: // "$" begin Kind := Ord(T_DOLLAR); // "$" end; CHAR_PERSENT: // "%", "%=" begin Kind := Ord(T_PROCENT); // "%" if (Bytes[1] = $3D) then Kind := Ord(T_MOD_EQUAL); // "%=" end; CHAR_AND: // "&", "&&", "&=" begin Kind := Ord(T_AND); // "&" case (Bytes[1]) of // "&&", "&=" $26: Kind := Ord(T_BOOLEAN_AND); // "&&" $3D: Kind := Ord(T_AND_EQUAL); // "&=" end; end; CHAR_OPEN: // "(", "(int)", "(bool)", "(array)", "(float)", "(unset)", "(double)", "(object)", "(string)" begin Kind := Ord(T_PARENTHESES_OPEN); // "(" // ... end; CHAR_CLOSE: // ")" begin Kind := Ord(T_PARENTHESES_CLOSE); // "(" end; CHAR_STAR: // "*", "**", "*=", "**=" begin Kind := Ord(T_MUL); // "*" case (Bytes[1]) of $2A: begin Kind := Ord(T_POW); // "**" if (Bytes[2] = $3D) then Kind := Ord(T_POW_EQUAL); // "**=" end; $3D: Kind := Ord(T_MUL_EQUAL); // "*=" end; end; CHAR_PLUS: // "+", "++", "+=" begin Kind := Ord(T_PLUS); // "+" case (Bytes[1]) of // "++", "+=" $2B: Kind := Ord(T_INC); // "++" $3D: Kind := Ord(T_PLUS_EQUAL); // "+=" end; end; CHAR_COMMA: // "," begin Kind := Ord(T_COMMA); // "," end; CHAR_DOT: // ".", ".=", "..." begin Kind := Ord(T_DOT); // "." if (Bytes[1] = $3D) then Kind := Ord(T_CONCAT_EQUAL); // ".=" if (Words1[0] = $2E2E) then Kind := Ord(T_ELLIPSIS); // "..." end; CHAR_DIV: // "/", "/=" begin Kind := Ord(T_DIV); // "/" if (Bytes[1] = $3D) then Kind := Ord(T_DIV_EQUAL); // "/=" end; CHAR_COLON: // ":", "::" begin Kind := Ord(T_COLON); // ":" if (Bytes[1] = $3A) then Kind := Ord(T_DOUBLE_COLON); // "::" end; CHAR_SEMICOLON: // ";" begin Kind := Ord(T_END_LINE); // "; end; CHAR_LESS: // "<<", "<<=", "<=", "<=>", "<>", "<?", "<?=", "<?php", "<?sphp" begin Kind := Ord(T_LESS); case (Bytes[1]) of $3C: begin Kind := Ord(T_SL); // "<<" if (Bytes[2] = $3D) then Kind := Ord(T_SL_EQUAL); // "<<=" end; $3D: begin Kind := Ord(T_IS_SMALLER_OR_EQUAL); // "<=" if (Bytes[2] = $3E) then Kind := Ord(T_SPACESHIP); // "<=>" end; $3E: Kind := Ord(T_IS_NOT_EQUAL); // "<>" $3F: begin Kind := Ord(T_OPEN_TAG); // "<?" if (Bytes[2] = $3D) then Kind := Ord(T_OPEN_TAG_WITH_ECHO) // "<?=" else if (Cardinals1[0] shr 8 or $202020 = $706870) then Kind := Ord(T_OPEN_TAG) // "<?php" else if (Cardinals2[0] or $20202020 = $70687073) then Kind := Ord(T_OPEN_TAG); // "<?sphp" end; end; end; CHAR_EQUAL: // "=", "==", "=>", "===" begin Kind := Ord(T_ASSIGN); // "=" case (Bytes[1]) of // "==", "=>" $3D: begin Kind := Ord(T_IS_EQUAL); // "==" if (Bytes[2] = $3D) then Kind := Ord(T_IS_IDENTICAL); // "===" end; $3E: Kind := Ord(T_DOUBLE_ARROW); // "=>" end; end; CHAR_GREATER: // ">", ">=", ">>", ">>=" begin Kind := Ord(T_GREATER); // ">" case (Bytes[1]) of // ">=", ">>" $3D: Kind := Ord(T_IS_GREATER_OR_EQUAL); // ">=" $3E: begin Kind := Ord(T_SR); // ">>" if (Bytes[2] = $3D) then Kind := Ord(T_SR_EQUAL); // ">>=" end; end; end; CHAR_QUESTION: // "?", "?>", "??" begin Kind := Ord(T_QUESTION); // "?" case (Bytes[1]) of // "?>", "??" $3E: Kind := Ord(T_CLOSE_TAG); // "?>" $3F: Kind := Ord(T_COALESCE); // "??" end; end; CHAR_AT: // "@" begin Kind := Ord(T_AT); // "@" end; CHAR_S_OPEN: // "[" begin Kind := Ord(T_SBRACKET_OPEN); // "[" end; CHAR_SEPARATOR: // "" begin Kind := Ord(T_NS_SEPARATOR); // "" end; CHAR_S_CLOSE: // "]" begin Kind := Ord(T_SBRACKET_CLOSE); // "]" end; CHAR_BITWISE_XOR: // "^", "^=" begin Kind := Ord(T_BITWISE_XOR); // "^" if (Bytes[1] = $3D) then Kind := Ord(T_XOR_EQUAL); // "^=" end; CHAR_C_OPEN: // "{", "{$" begin Kind := Ord(T_BRACKET_OPEN); // "{" if (Bytes[1] = $24) then Kind := Ord(T_CURLY_OPEN); // "{$" end; CHAR_BITWISE_OR: // "|", "|=", "||" begin Kind := Ord(T_BITWISE_OR); // "|" case (Bytes[1]) of $3D: Kind := Ord(T_OR_EQUAL); // "|=" $7C: Kind := Ord(T_BOOLEAN_OR); // "||" end; end; CHAR_C_CLOSE: // "}" begin Kind := Ord(T_BRACKET_CLOSE); // "}" end; CHAR_NOT: // "~" begin Kind := Ord(T_BITWISE_NOT); // "~" end; end; // если задетектили токен, то проверяем символ на конце if (Kind <> Ord(T_STRING)) then begin Byte(Token.Kind) := Kind; Inc(S, TOKEN_LENGTH[Kind]); if (CHAR_MODES[S^] < CHAR_MINUS) then goto not_defined; end else begin not_defined: Token.Kind := T_STRING; repeat Inc(S); until (CHAR_MODES[S^] >= CHAR_MINUS); end; // результат Self.FCurrent := S; Token.Length := NativeInt(S) - NativeInt(Token.Start); Result := True; end;
function TPhpLexer.Next(var Token: TPhpToken): Boolean; label done; var S: PAnsiChar; X: NativeUInt; Kind: Integer; begin // определяем тип текущего символа // пропускаем пробелы, в случае чего детектим перевод каретки и окончание файла S := FCurrent; Inc(S, Byte(PByte(S)^ = 32)); repeat X := CHAR_MODES[S^]; Inc(S); if (X < CHAR_SPACE) then Break; if (X > CHAR_SPACE) then begin Dec(S); if (X = CHAR_CRLF) then begin // перевод каретки: #13, #10, #1310 Inc(S, Byte(PWord(S)^ = (10 shl 8) + 13)); Inc(S); // записываем новое значение линии X := Self.FLine; Inc(X); Self.FLine := X; if (X < Self.FLinesCapacity) then begin Self.FLines[X] := S; end else begin GrowAddLine(S); end; end else begin // CHAR_FINISH: #0 - заканчиваем парсинг FCurrent := S; Result := False; Exit; end; end; until (False); Dec(S); // сохраняем позицию токена Token.Line := Self.Line; Token.Start := S; // в зависимости от первого символа определяем предполагаемый токен // по умолчанию T_STRING if (X <> CHAR_LETTER) then begin Kind := Ord(T_UNKNOWN); with PMemoryItems(S)^ do case (X) of CHAR_EXCLAM: // "!", "!=", "!==" begin Inc(Kind, Ord(T_NOT)); // "!" if (Bytes[1] = $3D) then begin Inc(Kind, Ord(T_IS_NOT_EQUAL) - Ord(T_NOT)); // "!=" if (Bytes[2] = $3D) then Inc(Kind, Ord(T_IS_NOT_IDENTICAL) - Ord(T_NOT)); // "!==" end; end; CHAR_DOLLAR: // "$" begin Inc(Kind, Ord(T_DOLLAR)); // "$" end; CHAR_PERSENT: // "%", "%=" begin Inc(Kind, Ord(T_PROCENT)); // "%" if (Bytes[1] = $3D) then Inc(Kind, Ord(T_MOD_EQUAL) - Ord(T_PROCENT)); // "%=" end; CHAR_AND: // "&", "&&", "&=" begin Inc(Kind, Ord(T_AND)); // "&" case (Bytes[1]) of // "&&", "&=" $26: Inc(Kind, Ord(T_BOOLEAN_AND) - Ord(T_AND)); // "&&" $3D: Inc(Kind, Ord(T_AND_EQUAL) - Ord(T_AND)); // "&=" end; end; CHAR_OPEN: // "(", "(int)", "(bool)", "(array)", "(float)", "(unset)", "(double)", "(object)", "(string)" begin Inc(Kind, Ord(T_PARENTHESES_OPEN)); // "(" case (Bytes[1] or $20) of $69: if (Cardinals1[0] or $00202020 = $29746E69) then Inc(Kind, Ord(T_INT_CAST) - Ord(T_PARENTHESES_OPEN)); // "(int)" $62: if (Cardinals2[0] or $00202020 = $296C6F6F) then Inc(Kind, Ord(T_BOOL_CAST) - Ord(T_PARENTHESES_OPEN)); // "(bool)" else case (Cardinals1[0] or $20202020) of $61727261: if (Words1[2] or $0020 = $2979) then Inc(Kind, Ord(T_ARRAY_CAST) - Ord(T_PARENTHESES_OPEN)); // "(array)" $616F6C66: if (Words1[2] or $0020 = $2974) then Inc(Kind, Ord(T_DOUBLE_CAST) - Ord(T_PARENTHESES_OPEN)); // "(float)" $65736E75: if (Words1[2] or $0020 = $2974) then Inc(Kind, Ord(T_UNSET_CAST) - Ord(T_PARENTHESES_OPEN)); // "(unset)" $62756F64: if (Cardinals[1] shr 8 or $002020 = $29656C) then Inc(Kind, Ord(T_DOUBLE_CAST) - Ord(T_PARENTHESES_OPEN)); // "(double)" $656A626F: if (Cardinals[1] shr 8 or $002020 = $297463) then Inc(Kind, Ord(T_OBJECT_CAST) - Ord(T_PARENTHESES_OPEN)); // "(object)" $69727473: if (Cardinals[1] shr 8 or $002020 = $29676E) then Inc(Kind, Ord(T_STRING_CAST) - Ord(T_PARENTHESES_OPEN)); // "(string)" $65746E69: if (Cardinals1[1] or $00202020 = $29726567) then Inc(Kind, Ord(T_INT_CAST) - Ord(T_PARENTHESES_OPEN)); // "(integer)" end; end; end; CHAR_CLOSE: // ")" begin Inc(Kind, Ord(T_PARENTHESES_CLOSE)); // "(" end; CHAR_STAR: // "*", "**", "*=", "**=" begin Inc(Kind, Ord(T_MUL)); // "*" case (Bytes[1]) of $2A: begin Inc(Kind, Ord(T_POW) - Ord(T_MUL)); // "**" if (Bytes[2] = $3D) then Inc(Kind, Ord(T_POW_EQUAL) - Ord(T_POW)); // "**=" end; $3D: Inc(Kind, Ord(T_MUL_EQUAL) - Ord(T_MUL)); // "*=" end; end; CHAR_PLUS: // "+", "++", "+=" begin Inc(Kind, Ord(T_PLUS)); // "+" case (Bytes[1]) of // "++", "+=" $2B: Inc(Kind, Ord(T_INC) - Ord(T_PLUS)); // "++" $3D: Inc(Kind, Ord(T_PLUS_EQUAL) - Ord(T_PLUS)); // "+=" end; end; CHAR_COMMA: // "," begin Inc(Kind, Ord(T_COMMA)); // "," end; CHAR_DOT: // ".", ".=", "..." begin Inc(Kind, Ord(T_DOT)); // "." if (Bytes[1] = $3D) then Inc(Kind, Ord(T_CONCAT_EQUAL) - Ord(T_DOT)); // ".=" if (Words1[0] = $2E2E) then Inc(Kind, Ord(T_ELLIPSIS) - Ord(T_DOT)); // "..." end; CHAR_DIV: // "/", "/=" begin Inc(Kind, Ord(T_DIV)); // "/" if (Bytes[1] = $3D) then Inc(Kind, Ord(T_DIV_EQUAL) - Ord(T_DIV)); // "/=" end; CHAR_COLON: // ":", "::" begin Inc(Kind, Ord(T_COLON)); // ":" if (Bytes[1] = $3A) then Inc(Kind, Ord(T_DOUBLE_COLON) - Ord(T_COLON)); // "::" end; CHAR_SEMICOLON: // ";" begin Inc(Kind, Ord(T_END_LINE)); // "; end; CHAR_LESS: // "<<", "<<=", "<=", "<=>", "<>", "<?", "<?=", "<?php", "<?sphp" begin Inc(Kind, Ord(T_LESS)); // "<" case (Bytes[1]) of $3C: begin Inc(Kind, Ord(T_SL) - Ord(T_LESS)); // "<<" if (Bytes[2] = $3D) then Inc(Kind, Ord(T_SL_EQUAL) - Ord(T_SL)); // "<<=" end; $3D: begin Inc(Kind, Ord(T_IS_SMALLER_OR_EQUAL) - Ord(T_LESS)); // "<=" if (Bytes[2] = $3E) then Inc(Kind, Ord(T_SPACESHIP) - Ord(T_IS_SMALLER_OR_EQUAL)); // "<=>" end; $3E: Inc(Kind, Ord(T_IS_NOT_EQUAL) - Ord(T_LESS)); // "<>" $3F: begin Inc(Kind, Ord(T_OPEN_TAG) - Ord(T_LESS)); // "<?" if (Bytes[2] = $3D) then Inc(Kind, Ord(T_OPEN_TAG_WITH_ECHO) - Ord(T_OPEN_TAG)) // "<?=" else if (Cardinals1[0] shr 8 or $202020 = $706870) then Inc(Kind, Ord(T_OPEN_TAG) - Ord(T_OPEN_TAG)) // "<?php" else if (Cardinals2[0] or $20202020 = $70687073) then Inc(Kind, Ord(T_OPEN_TAG) - Ord(T_OPEN_TAG)); // "<?sphp" end; end; end; CHAR_EQUAL: // "=", "==", "=>", "===" begin Inc(Kind, Ord(T_ASSIGN)); // "=" case (Bytes[1]) of // "==", "=>" $3D: begin Inc(Kind, Ord(T_IS_EQUAL) - Ord(T_ASSIGN)); // "==" if (Bytes[2] = $3D) then Inc(Kind, Ord(T_IS_IDENTICAL) - Ord(T_IS_EQUAL)); // "===" end; $3E: Inc(Kind, Ord(T_DOUBLE_ARROW) - Ord(T_ASSIGN)); // "=>" end; end; CHAR_GREATER: // ">", ">=", ">>", ">>=" begin Inc(Kind, Ord(T_GREATER)); // ">" case (Bytes[1]) of // ">=", ">>" $3D: Inc(Kind, Ord(T_IS_GREATER_OR_EQUAL) - Ord(T_GREATER)); // ">=" $3E: begin Inc(Kind, Ord(T_SR) - Ord(T_GREATER)); // ">>" if (Bytes[2] = $3D) then Inc(Kind, Ord(T_SR_EQUAL) - Ord(T_SR)); // ">>=" end; end; end; CHAR_QUESTION: // "?", "?>", "??" begin Inc(Kind, Ord(T_QUESTION)); // "?" case (Bytes[1]) of // "?>", "??" $3E: Inc(Kind, Ord(T_CLOSE_TAG) - Ord(T_QUESTION)); // "?>" $3F: Inc(Kind, Ord(T_COALESCE) - Ord(T_QUESTION)); // "??" end; end; CHAR_AT: // "@" begin Inc(Kind, Ord(T_AT)); // "@" end; CHAR_S_OPEN: // "[" begin Inc(Kind, Ord(T_SBRACKET_OPEN)); // "[" end; CHAR_SEPARATOR: // "" begin Inc(Kind, Ord(T_NS_SEPARATOR)); // "" end; CHAR_S_CLOSE: // "]" begin Inc(Kind, Ord(T_SBRACKET_CLOSE)); // "]" end; CHAR_BITWISE_XOR: // "^", "^=" begin Inc(Kind, Ord(T_BITWISE_XOR)); // "^" if (Bytes[1] = $3D) then Inc(Kind, Ord(T_XOR_EQUAL) - Ord(T_BITWISE_XOR)); // "^=" end; CHAR_C_OPEN: // "{", "{$" begin Inc(Kind, Ord(T_BRACKET_OPEN)); // "{" if (Bytes[1] = $24) then Inc(Kind, Ord(T_CURLY_OPEN) - Ord(T_BRACKET_OPEN)); // "{$" end; CHAR_BITWISE_OR: // "|", "|=", "||" begin Inc(Kind, Ord(T_BITWISE_OR)); // "|" case (Bytes[1]) of $3D: Inc(Kind, Ord(T_OR_EQUAL) - Ord(T_BITWISE_OR)); // "|=" $7C: Inc(Kind, Ord(T_BOOLEAN_OR) - Ord(T_BITWISE_OR)); // "||" end; end; CHAR_C_CLOSE: // "}" begin Inc(Kind, Ord(T_BRACKET_CLOSE)); // "}" end; CHAR_NOT: // "~" begin Inc(Kind, Ord(T_BITWISE_NOT)); // "~" end; CHAR_MINUS: // "-", "--", "-=", "->" begin Inc(Kind, Ord(T_SUB)); // "-" case (Bytes[1]) of // "--", "-=", "->" $2D: Inc(Kind, Ord(T_DEC) - Ord(T_SUB)); // "--" $3D: Inc(Kind, Ord(T_MINUS_EQUAL) - Ord(T_SUB)); // "-=" $3E: Inc(Kind, Ord(T_OBJECT_OPERATOR) - Ord(T_SUB)); // "->" end; end; CHAR_PREPS: begin // лексема начинается с другого знака препинания: T_UNKNOWN repeat Inc(S); until (CHAR_MODES[S^] <> CHAR_PREPS); end else // CHAR_DIGIT: // "0".."9" // по идее здесь должны обрабатываться числовые токены, пока делаем T_UNKNOWN repeat Inc(S); until (CHAR_MODES[S^] <> CHAR_DIGIT); end; // пишем рассчитанный вариант // для T_UNKNOWN указатель уже в конце, а длина равна нулю Byte(Token.Kind) := Kind; Inc(S, TOKEN_LENGTH[Kind]); Self.FCurrent := S; Token.Length := NativeInt(S) - NativeInt(Token.Start); end else begin // буквенная+числовая последовательность символов repeat Inc(S); X := CHAR_MODES[S^]; until (NativeUInt(X - CHAR_DIGIT) >= 2); Self.FCurrent := S; X := NativeUInt(S) - NativeUInt(Token.Start); Token.Kind := T_STRING; Token.Length := X; S := Token.Start; with PMemoryItems(S)^ do if (Bytes[0] <> Ord('_')) then begin if (X >= 2) then case (Bytes[0] or $20) of // "abstract", "and", "array", "as", "break", "callable", ... $61: case X of // "as", "and", "array", "abstract" 2: if (Bytes[1] or $20 = $73) then Token.Kind := T_AS; // "as" 3: if (Words1[0] or $2020 = $646E) then Token.Kind := T_LOGICAL_AND; // "and" 5: if (Cardinals1[0] or $20202020 = $79617272) then Token.Kind := T_ARRAY; // "array" 8: if (Cardinals1[0] or $20202020 = $72747362) and (Cardinals[1] shr 8 or $202020 = $746361) then Token.Kind := T_ABSTRACT; // "abstract" end; $62: if (X = 5) and (Cardinals1[0] or $20202020 = $6B616572) then Token.Kind := T_BREAK; // "break" $63: case (Bytes[1] or $20) of // "callable", "case", "catch", "class", "clone", ... $61: case X of // "case", "catch", "callable" 4: if (Words[1] or $2020 = $6573) then Token.Kind := T_CASE; // "case" 5: if (Cardinals1[0] shr 8 or $202020 = $686374) then Token.Kind := T_CATCH; // "catch" 8: if (Cardinals2[0] or $20202020 = $62616C6C) and (Words[3] or $2020 = $656C) then Token.Kind := T_CALLABLE; // "callable" end; $6C: if (X = 5) then case (Cardinals1[0] shr 8 or $202020) of // "class", "clone" $737361: Token.Kind := T_CLASS; // "class" $656E6F: Token.Kind := T_CLONE; // "clone" end; $6F: if (X >= 3) and (Bytes[2] or $20 = $6E) then case X of // "const", "continue" 5: if (Words1[1] or $2020 = $7473) then Token.Kind := T_CONST; // "const" 8: if (Cardinals3[0] or $20202020 = $756E6974) and (Bytes[7] or $20 = $65) then Token.Kind := T_CONTINUE; // "continue" end; end; $64: case X of // "do", "die", "declare", "default" 2: if (Bytes[1] or $20 = $6F) then Token.Kind := T_DO; // "do" 3: if (Words1[0] or $2020 = $6569) then Token.Kind := T_EXIT; // "die" 7: if (Bytes[1] or $20 = $65) then case (Cardinals2[0] or $20202020) of // "declare", "default" $72616C63: if (Bytes[6] or $20 = $65) then Token.Kind := T_DECLARE; // "declare" $6C756166: if (Bytes[6] or $20 = $74) then Token.Kind := T_DEFAULT; // "default" end; end; $65: case (Bytes[1] or $20) of // "echo", "else", "elseif", "empty", "enddeclare", ... $63: if (X = 4) and (Words[1] or $2020 = $6F68) then Token.Kind := T_ECHO; // "echo" $6C: if (X >= 4) and (Words[1] or $2020 = $6573) then case X of // "else", "elseif" 4: Token.Kind := T_ELSE; // "else" 6: if (Words[2] or $2020 = $6669) then Token.Kind := T_ELSEIF; // "elseif" end; $6D: if (X = 5) and (Cardinals1[0] shr 8 or $202020 = $797470) then Token.Kind := T_EMPTY; // "empty" $6E: if (X >= 4) then case (Bytes[2] or $20) of // "enddeclare", "endfor", "endforeach", ... $64: case X of // "endif", "endfor", "endwhile", "endswitch", ... 5: if (Words1[1] or $2020 = $6669) then Token.Kind := T_ENDIF; // "endif" 6: if (Cardinals2[0] shr 8 or $202020 = $726F66) then Token.Kind := T_ENDFOR; // "endfor" 8: if (Cardinals3[0] or $20202020 = $6C696877) and (Bytes[7] or $20 = $65) then Token.Kind := T_ENDWHILE; // "endwhile" 9: if (Cardinals3[0] or $20202020 = $74697773) and (Words1[3] or $2020 = $6863) then Token.Kind := T_ENDSWITCH; // "endswitch" 10: case (Cardinals3[0] or $20202020) of // "enddeclare", "endforeach" $6C636564: if (Cardinals2[1] shr 8 or $202020 = $657261) then Token.Kind := T_ENDDECLARE; // "enddeclare" $65726F66: if (Cardinals2[1] shr 8 or $202020 = $686361) then Token.Kind := T_ENDFOREACH; // "endforeach" end; end; $75: if (X = 4) and (Bytes[3] or $20 = $6D) then Token.Kind := T_ENUM; // "enum" end; $76: if (X = 4) and (Words[1] or $2020 = $6C61) then Token.Kind := T_EVAL; // "eval" $78: case X of // "exit", "extends" 4: if (Words[1] or $2020 = $7469) then Token.Kind := T_EXIT; // "exit" 7: if (Cardinals2[0] or $20202020 = $646E6574) and (Bytes[6] or $20 = $73) then Token.Kind := T_EXTENDS; // "extends" end; end; $66: case X of // "for", "final", "finally", "foreach", "function" 3: if (Words1[0] or $2020 = $726F) then Token.Kind := T_FOR; // "for" 5: if (Cardinals1[0] or $20202020 = $6C616E69) then Token.Kind := T_FINAL; // "final" 7: case (Cardinals1[0] or $20202020) of // "finally", "foreach" $6C616E69: if (Words1[2] or $2020 = $796C) then Token.Kind := T_FINALLY; // "finally" $6165726F: if (Words1[2] or $2020 = $6863) then Token.Kind := T_FOREACH; // "foreach" end; 8: if (Cardinals1[0] or $20202020 = $74636E75) and (Cardinals[1] shr 8 or $202020 = $6E6F69) then Token.Kind := T_FUNCTION; // "function" end; $67: case X of // "goto", "global" 4: if (Cardinals[0] shr 8 or $202020 = $6F746F) then Token.Kind := T_GOTO; // "goto" 6: if (Cardinals1[0] or $20202020 = $61626F6C) and (Bytes[5] or $20 = $6C) then Token.Kind := T_GLOBAL; // "global" end; $69: case (Bytes[1] or $20) of // "if", "implements", "include", "include_once", ... $66: if (X = 2) then Token.Kind := T_IF; // "if" $6D: if (X = 10) and (Cardinals2[0] or $20202020 = $6D656C70) and (Cardinals2[1] or $20202020 = $73746E65) then Token.Kind := T_IMPLEMENTS; // "implements" $6E: case X of // "include", "insteadof", "interface", "instanceof", "include_once" 7: if (Cardinals2[0] or $20202020 = $64756C63) and (Bytes[6] or $20 = $65) then Token.Kind := T_INCLUDE; // "include" 9: case (Cardinals2[0] or $20202020) of // "insteadof", "interface" $61657473: if (Cardinals1[1] shr 8 or $202020 = $666F64) then Token.Kind := T_INSTEADOF; // "insteadof" $66726574: if (Cardinals1[1] shr 8 or $202020 = $656361) then Token.Kind := T_INTERFACE; // "interface" end; 10: if (Cardinals2[0] or $20202020 = $6E617473) and (Cardinals2[1] or $20202020 = $666F6563) then Token.Kind := T_INSTANCEOF; // "instanceof" 12: if (Cardinals2[0] or $20202020 = $64756C63) and (Cardinals2[1] or $20200020 = $6E6F5F65) and (Words[5] or $2020 = $6563) then Token.Kind := T_INCLUDE_ONCE; // "include_once" end; $73: if (X = 5) and (Cardinals1[0] shr 8 or $202020 = $746573) then Token.Kind := T_ISSET; // "isset" end; $6C: if (X = 4) and (Cardinals[0] shr 8 or $202020 = $747369) then Token.Kind := T_LIST; // "list" $6E: case X of // "new", "namespace" 3: if (Words1[0] or $2020 = $7765) then Token.Kind := T_NEW; // "new" 9: if (Cardinals1[0] or $20202020 = $73656D61) and (Cardinals1[1] or $20202020 = $65636170) then Token.Kind := T_NAMESPACE; // "namespace" end; $6F: if (X = 2) and (Bytes[1] or $20 = $72) then Token.Kind := T_LOGICAL_OR; // "or" $70: case (Bytes[1] or $20) of // "print", "private", "protected", "public" $72: case X of // "print", "private", "protected" 5: if (Cardinals1[0] shr 8 or $202020 = $746E69) then Token.Kind := T_PRINT; // "print" 7: if (Cardinals2[0] or $20202020 = $74617669) and (Bytes[6] or $20 = $65) then Token.Kind := T_PRIVATE; // "private" 9: if (Cardinals2[0] or $20202020 = $6365746F) and (Cardinals1[1] shr 8 or $202020 = $646574) then Token.Kind := T_PROTECTED; // "protected" end; $75: if (X = 6) and (Cardinals2[0] or $20202020 = $63696C62) then Token.Kind := T_PUBLIC; // "public" end; $72: if (Bytes[1] or $20 = $65) then case X of // "return", "require", "require_once" 6: if (Cardinals2[0] or $20202020 = $6E727574) then Token.Kind := T_RETURN; // "return" 7: if (Cardinals2[0] or $20202020 = $72697571) and (Bytes[6] or $20 = $65) then Token.Kind := T_REQUIRE; // "require" 12: if (Cardinals2[0] or $20202020 = $72697571) and (Cardinals2[1] or $20200020 = $6E6F5F65) and (Words[5] or $2020 = $6563) then Token.Kind := T_REQUIRE_ONCE; // "require_once" end; $73: if (X = 6) then case (Cardinals1[0] or $20202020) of // "static", "struct", "switch" $69746174: if (Bytes[5] or $20 = $63) then Token.Kind := T_STATIC; // "static" $63757274: if (Bytes[5] or $20 = $74) then Token.Kind := T_STRUCT; // "struct" $63746977: if (Bytes[5] or $20 = $68) then Token.Kind := T_SWITCH; // "switch" end; $74: case X of // "try", "throw", "trait", "typedef" 3: if (Words1[0] or $2020 = $7972) then Token.Kind := T_TRY; // "try" 5: case (Cardinals1[0] or $20202020) of // "throw", "trait" $776F7268: Token.Kind := T_THROW; // "throw" $74696172: Token.Kind := T_TRAIT; // "trait" end; 7: if (Cardinals1[0] or $20202020 = $64657079) and (Words1[2] or $2020 = $6665) then Token.Kind := T_TYPEDEF; // "typedef" end; $75: case X of // "use", "union", "unset" 3: if (Words1[0] or $2020 = $6573) then Token.Kind := T_USE; // "use" 5: if (Bytes[1] or $20 = $6E) then case (Cardinals1[0] shr 8 or $202020) of // "union", "unset" $6E6F69: Token.Kind := T_UNION; // "union" $746573: Token.Kind := T_UNSET; // "unset" end; end; $76: if (X = 3) and (Words1[0] or $2020 = $7261) then Token.Kind := T_VAR; // "var" $77: if (X = 5) and (Cardinals1[0] or $20202020 = $656C6968) then Token.Kind := T_WHILE; // "while" $78: if (X = 3) and (Words1[0] or $2020 = $726F) then Token.Kind := T_LOGICAL_XOR; // "xor" end; end else begin if (X >= 2) and (Words[0] = $5F5F) then case X of 7: if (Cardinals2[0] or $00202020 = $5F726964) and (Bytes[6] = $5F) then Token.Kind := T_DIR; // "__DIR__" 8: case (Cardinals2[0] or $20202020) of // "__FILE__", "__LINE__" $656C6966: if (Words[3] = $5F5F) then Token.Kind := T_FILE; // "__FILE__" $656E696C: if (Words[3] = $5F5F) then Token.Kind := T_LINE; // "__LINE__" end; 9: case (Cardinals2[0] or $20202020) of // "__CLASS__", "__TRAIT__" $73616C63: if (Cardinals1[1] shr 8 or $000020 = $5F5F73) then Token.Kind := T_CLASS_C; // "__CLASS__" $69617274: if (Cardinals1[1] shr 8 or $000020 = $5F5F74) then Token.Kind := T_TRAIT_C; // "__TRAIT__" end; 10: if (Cardinals2[0] or $20202020 = $6874656D) and (Cardinals2[1] or $00002020 = $5F5F646F) then Token.Kind := T_METHOD_C; // "__METHOD__" 12: if (Cardinals2[0] or $20202020 = $636E7566) and (Cardinals2[1] or $20202020 = $6E6F6974) and (Words[5] = $5F5F) then Token.Kind := T_FUNC_C; // "__FUNCTION__" 13: if (Cardinals2[0] or $20202020 = $656D616E) and (Cardinals2[1] or $20202020 = $63617073) and (Cardinals1[2] shr 8 or $000020 = $5F5F65) then Token.Kind := T_NS_C; // "__NAMESPACE__" 15: if (Cardinals2[0] or $20202020 = $746C6168) and (Cardinals2[1] or $20202000 = $6D6F635F) and (Cardinals2[2] or $20202020 = $656C6970) and (Bytes[14] or $20 = $72) then Token.Kind := T_HALT_COMPILER; // "__halt_compiler" end; end; end; // результат Result := True; end;
begin try if ZStartTime(startTime) then begin str1 := 'hv45zvhvRTHzvhvhv45zvhvRTHzvhvzvhv45zvhvRTHzvhvzvzvhv45zvhvRTHzvhvzv15'; str2 := 'hv45zvhvRTHzvhvhv45zvhvRTHzvhvzvhv45zvhvRTHzvhvzvzvhv45zvhvRTHzvhvzv15'; for i := 0 to 10000000 do begin if not IsEquals4Byte(Pointer(str1), Pointer(str2)) then // if not Equals_UStr(PByte(str1), PByte(str2)) then begin Writeln('Oops!'); end; end; Writeln(ZStopTime(startTime)); end; except on E: Exception do Writeln(E.ClassName, ': ', E.Message); end; Readln; end.
function memcmp(ptr1: Pointer; ptr2: Pointer; num: Cardinal): Integer; cdecl; external 'Ntdll.dll' name 'memcmp'; function IsEquals4Byte(L, R: PCardinal): Boolean; {$POINTERMATH ON} var Len: Cardinal; begin {$IF Defined(CPUX64) or Defined(CPUARM64)} Result := memcmp(L, R, L[-1] * sizeof(WideChar)) = 0; {$ELSE} Len := L[-1]; if Len <> R[-1] then exit(false); while (Len > 4) and ((L[0] = R[0]) and (L[1] = R[1])) do begin L := Pointer(Cardinal(L) + (sizeof(Cardinal) * 2)); R := Pointer(Cardinal(R) + (sizeof(Cardinal) * 2)); dec(Len, 4); end; case Len of 3, 4: Result := ((L[0] = R[0]) and (L[1] = R[1])); 1, 2: Result := L[0] = R[0]; else Result := true; end; {$ENDIF} end;
function IsEquals4Byte(L, R: PCardinal): Boolean; {$POINTERMATH ON} var Len: Cardinal; begin {$IF Defined(CPUX64) or Defined(CPUARM64)} Result := memcmp(L, R, L[-1] * sizeof(WideChar)) = 0; {$ELSE} Len := L[-1]; if Len <> R[-1] then exit(false); while (Len > 4) and ((L[0] = R[0]) and (L[1] = R[1])) do begin L := Pointer(Cardinal(L) + (sizeof(Cardinal) * 2)); R := Pointer(Cardinal(R) + (sizeof(Cardinal) * 2)); dec(Len, 4); end; case Len of 3, 4: Result := ((L[0] = R[0]) and (L[1] = R[1])); 1, 2: Result := L[0] = R[0]; else Result := false; end; {$ENDIF} end;
program Project1; {$APPTYPE CONSOLE} {$R *.res} uses windows, SysUtils; function sprintf(S: PAnsiChar; const Format: PAnsiChar): Integer; cdecl; varargs; external 'msvcrt.dll'; function ZStartTime(var StartTime: Int64): Boolean; begin Result := QueryPerformanceCounter(StartTime); end; function ZStopTime(const StartTime: Int64): AnsiString; var iCounterPerSec, StopTime: Int64; time: Single; begin if QueryPerformanceCounter(StopTime) then begin if QueryPerformanceFrequency(iCounterPerSec) then begin time := (0 - StartTime + StopTime) / iCounterPerSec; Result := ''; SetLength(Result, 25); SetLength(Result, sprintf(PAnsiChar(Result), 'Result: %f sec.', time)); end else Result := 'Error[ZStopTime(QueryPerformanceFrequency)]'; end else Result := 'Error[ZStopTime(QueryPerformanceCounter)]'; end; // --------- function IsEquals4Byte(L, R: PCardinal): Boolean; {$POINTERMATH ON} var Len: Cardinal; begin Len := L[-1]; if Len <> R[-1] then exit(false); while (Len > 4) and ((L[0] = R[0]) and (L[1] = R[1])) do begin L := Pointer(Cardinal(L) + (sizeof(Cardinal) * 2)); R := Pointer(Cardinal(R) + (sizeof(Cardinal) * 2)); dec(Len, 4); end; case Len of 3, 4: Result := ((L[0] = R[0]) and (L[1] = R[1])); 1, 2: Result := L[0] = R[0]; else Result := false; end; end; function Equals_UStr(Left, Right: PByte): Boolean; {$POINTERMATH ON} {$IF Defined(CPUX64) or Defined(CPUARM64)} {$DEFINE LARGEINT} {$ELSE} {$DEFINE SMALLINT} {$IFEND} label start, differs, equals; var Count: NativeUInt; L, R: PNativeUInt; begin if (Left = Right) then goto equals; if (Left = nil) or (Right = nil) then goto differs; L := Pointer(Left); R := Pointer(Right); Count := {$IFDEF SMALLINT}L{$ELSE .LARGEINT}PCardinal(L){$ENDIF}[-1]; if (Cardinal(Count) = {$IFDEF SMALLINT}R{$ELSE .LARGEINT}PCardinal(R){$ENDIF}[-1]) then begin start: case {$IFDEF SMALLINT}Count{$ELSE}(Count + 1) shr 1{$ENDIF} of 0: begin goto equals; end; {$IFDEF SMALLINT}1, 2{$ELSE}1{$ENDIF}: begin if (PCardinal(L)[0] <> PCardinal(R)[0]) then goto differs; goto equals; end; {$IFDEF SMALLINT}3, 4{$ELSE}2{$ENDIF}: begin {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; {$ENDIF} goto equals; end; {$IFDEF SMALLINT}5, 6{$ELSE}3{$ENDIF}: begin {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; {$ENDIF} if (PCardinal(L)[2] <> PCardinal(R)[2]) then goto differs; goto equals; end; {$IFDEF SMALLINT}7, 8{$ELSE}4{$ENDIF}: begin {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; {$ENDIF} goto equals; end; {$IFDEF SMALLINT}9, 10{$ELSE}5{$ENDIF}: begin {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; {$ENDIF} if (PCardinal(L)[4] <> PCardinal(R)[4]) then goto differs; goto equals; end; {$IFDEF SMALLINT}11, 12{$ELSE}6{$ENDIF}: begin {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; if (L[4] <> R[4]) then goto differs; if (L[5] <> R[5]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; {$ENDIF} goto equals; end; {$IFDEF SMALLINT}13, 14{$ELSE}7{$ENDIF}: begin {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; if (L[4] <> R[4]) then goto differs; if (L[5] <> R[5]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; {$ENDIF} if (PCardinal(L)[6] <> PCardinal(R)[6]) then goto differs; goto equals; end; end; repeat dec(Count, 16); {$IFDEF SMALLINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; if (L[4] <> R[4]) then goto differs; if (L[5] <> R[5]) then goto differs; if (L[6] <> R[6]) then goto differs; if (L[7] <> R[7]) then goto differs; {$ELSE .LARGEINT} if (L[0] <> R[0]) then goto differs; if (L[1] <> R[1]) then goto differs; if (L[2] <> R[2]) then goto differs; if (L[3] <> R[3]) then goto differs; {$ENDIF} Inc(NativeUInt(L), 32); Inc(NativeUInt(R), 32); until (NativeInt(Count) < 16); if (NativeInt(Count) > 0) then goto start; end else begin differs: Result := false; exit; end; equals: Result := True; end; var StartTime: Int64; i: Cardinal; str1, str2: string; x, y, z, R: Single; begin try str1 := 'hv45zvhvRTHzvhvhv45zvhvRTHzvhvhv45zvhvRTHzvhvhv45zvhvRTHzvhvzvhv45zvhvRTHzvhvzvzvhv45zvhvRTHzvhvzv15zvhv45zvhvRTHzvhvzvzvhv45zvhvRTHzvhvzv15'; str2 := 'hv45zvhvRTHzvhvhv45zvhvRTHzvhvhv45zvhvRTHzvhvhv45zvhvRTHzvhvzvhv45zvhvRTHzvhvzvzvhv45zvhvRTHzvhvzv15zvhv45zvhvRTHzvhvzvzvhv45zvhvRTHzvhvzv15'; if ZStartTime(StartTime) then begin for i := 0 to 10000000 do begin if not IsEquals4Byte(Pointer(str1), Pointer(str2)) then Writeln('Oops!'); end; Writeln(ZStopTime(StartTime)); end; if ZStartTime(StartTime) then begin for i := 0 to 10000000 do begin if not Equals_UStr(Pointer(str1), Pointer(str2)) then Writeln('Oops!'); end; Writeln(ZStopTime(StartTime)); end; except on E: Exception do Writeln(E.ClassName, ': ', E.Message); end; Readln; end.