david
47aaf11578
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.DevExpressVCL@38 05c56307-c608-d34a-929d-697000501d7a
4449 lines
139 KiB
ObjectPascal
4449 lines
139 KiB
ObjectPascal
{
|
|
The execute part of the script engine
|
|
}
|
|
unit ifps3;
|
|
{$I ifps3_def.inc}
|
|
{
|
|
|
|
Innerfuse Pascal Script III
|
|
Copyright (C) 2000-2002 by Carlo Kok (ck@carlo-kok.com)
|
|
|
|
}
|
|
interface
|
|
uses
|
|
SysUtils, ifps3utl, ifps3common;
|
|
|
|
type
|
|
TIFPSExec = class;
|
|
{ TIFError contains all possible errors }
|
|
TIFError = (ErNoError, erCannotImport, erInvalidType, ErInternalError,
|
|
erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc,
|
|
erOutOfGlobalVarsRange, erOutOfProcRange, ErOutOfRange, erOutOfStackRange,
|
|
ErTypeMismatch, erUnexpectedEof, erVersionError, ErDivideByZero, ErMathError,
|
|
erCouldNotCallProc, erOutofRecordRange, erOutOfMemory, erException,
|
|
erNullPointerException, erNullVariantError, erCustomError);
|
|
{ The current status of the script }
|
|
TIFStatus = (isNotLoaded, isLoaded, isRunning, isPaused);
|
|
{Pointer to array of bytes}
|
|
PByteArray = ^TByteArray;
|
|
{Array of bytes}
|
|
TByteArray = array[0..1023] of Byte;
|
|
{Pointer to array of words}
|
|
PDWordArray = ^TDWordArray;
|
|
{Array of dwords}
|
|
TDWordArray = array[0..1023] of Cardinal;
|
|
{ Pointer to @link(TIFTypeRec)}
|
|
PIFTypeRec = ^TIFTypeRec;
|
|
{TIFTypeRec is used to store all types inside the script}
|
|
TIFTypeRec = record
|
|
{Ext is used in a typecopy or array to store more information}
|
|
Ext: Pointer;
|
|
BaseType: TIFPSBaseType;
|
|
ExportName: string;
|
|
ExportNameHash: Longint;
|
|
end;
|
|
{TIFArrayType is a pointer to an other type}
|
|
TIFArrayType = PIFTypeRec;
|
|
{PIFRecordType is a pointer to record information}
|
|
PIFRecordType = ^TIFRecordType;
|
|
{TIFRecordType is used to store information about records}
|
|
TIFRecordType = record
|
|
Data: string;
|
|
end;
|
|
{@link(TProcRec)
|
|
PProcRec is pointer to a TProcRec record}
|
|
PProcRec = ^TProcRec;
|
|
{@link(TIFProcRec)
|
|
PIFProcRec is a pointer to a TIProcRec record}
|
|
PIFProcRec = ^TIFProcRec;
|
|
{
|
|
@link(TIFPSExec)
|
|
@link(PIFProcRec)
|
|
@link(TIfList)
|
|
TIFProc is is the procedure definition of all external functions
|
|
}
|
|
TIFProc = function(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
|
|
{
|
|
@link(PProcRec)
|
|
FreeProc is called when a PProcRec is freed}
|
|
TIFFreeProc = procedure (Caller: TIFPSExec; p: PProcRec);
|
|
{TIFProcRec contains a currently used internal or external function}
|
|
TIFProcRec = record
|
|
{True means the procedure is external}
|
|
ExternalProc: Boolean;
|
|
{The exportname/decl used to identify the procedure}
|
|
ExportName, ExportDecl: string;
|
|
{ExportNameHash is used to quickly find an ExportName}
|
|
ExportNameHash: Longint;
|
|
case Boolean of
|
|
False: (Data: PByteArray; Length: Cardinal);
|
|
True: (ProcPtr: TIFProc; Name: ShortString; Ext1, Ext2: Pointer);
|
|
// ExportDecl will contain Params in case of importing with Flags := 3;
|
|
end;
|
|
{TProcrec is used to store an external function that could be used by the script executer}
|
|
TProcRec = record
|
|
Name: ShortString;
|
|
Hash: Longint;
|
|
ProcPtr: TIFProc;
|
|
FreeProc: TIFFreeProc;
|
|
Ext1, Ext2: Pointer;
|
|
end;
|
|
{@link(TBTReturnAddress)
|
|
PBTReturnAddress is a pointer to an TBTReturnAddress record}
|
|
PBTReturnAddress = ^TBTReturnAddress;
|
|
{TBTReturnAddress is a record used to store return information}
|
|
TBTReturnAddress = record
|
|
ProcNo: PIFProcRec;
|
|
Position, StackBase: Cardinal;
|
|
end;
|
|
{@link(PIFVariant)
|
|
PPIFVariant is a pointer to a PIFVariant}
|
|
PPIFVariant = ^PIfVariant;
|
|
{@link(TIFVariant)
|
|
PIFVariant is a pointer to a TIFVariant}
|
|
PIFVariant = ^TIfVariant;
|
|
{@link(TVariantResourceFreeProc)
|
|
TVRMode is used to when the scriptengine needs to free or duplicate a resourcepointer}
|
|
TVRFMode = (vrfFree, vrfDuplicate);
|
|
{@link(TVRMode)
|
|
TVariantResourceFreeProc is used when the scriptengine needs to free or duplicate a resourcepointer}
|
|
TVariantResourceFreeProc = function (FMode: TVRFMode; P, IntoP: PIFVariant): Boolean;
|
|
{PBTRecord is a pointer to a @link(TbtRecord) record}
|
|
pbtrecord = ^TbtRecord;
|
|
{TIFvariant is variant used for storing all variables used by the script engine}
|
|
TIFVariant = packed record
|
|
{The type of the variant}
|
|
FType: PIFTypeRec;
|
|
{The number of pointers referencing this variant}
|
|
RefCount: Cardinal; // 0 = Freeable
|
|
case Byte of
|
|
1: (tu8: TbtU8);
|
|
2: (tS8: TbtS8);
|
|
3: (tu16: TbtU16);
|
|
4: (ts16: TbtS16);
|
|
5: (tu32: TbtU32);
|
|
6: (ts32: TbtS32);
|
|
7: (tsingle: TbtSingle);
|
|
8: (tdouble: TbtDouble);
|
|
9: (textended: TbtExtended);
|
|
10: (tstring: Pointer);
|
|
11: (treturnaddress: TBTReturnAddress);
|
|
12: (trecord: pbtrecord);
|
|
13: (tArray: pbtrecord);
|
|
14: (tPointer: PIfVariant);
|
|
15: (tResourceP1, tResourceP2: Pointer; tResourceFreeProc: TVariantResourceFreeProc);
|
|
16: (tvariant: PIFVariant);
|
|
{$IFNDEF NOINT64}
|
|
17: (ts64: Tbts64);
|
|
{$ENDIF}
|
|
19: (tchar: tbtChar);
|
|
{$IFNDEF NOWIDESTRING}
|
|
18: (twidestring: Pointer);
|
|
20: (twidechar: tbtwidechar);
|
|
{$ENDIF}
|
|
end;
|
|
{TbtRecord is used to store the fields in a record or array}
|
|
TbtRecord = packed record
|
|
FieldCount: Cardinal;
|
|
Fields: array[0..10000] of PIfVariant;
|
|
end;
|
|
{TIFPSResourceFreeProc is called when a resource needs to be freed}
|
|
TIFPSResourceFreeProc = procedure (Sender: TIFPSExec; P: Pointer);
|
|
{@link(TIFPSResource)
|
|
PIFPSResource is a pointer to a TIFPSResource record
|
|
}
|
|
PIFPSResource = ^TIFPSResource;
|
|
{ A resource in IFPS3 is stored as a pointer to the proc and a tag (p) }
|
|
TIFPSResource = record
|
|
Proc: Pointer;
|
|
P: Pointer;
|
|
end;
|
|
{@link(pbtrecord)
|
|
PBTRecord}
|
|
PBTArray = pbtrecord;
|
|
{@link(TbtRecord)
|
|
tbtrecord}
|
|
TBTArray = TbtRecord;
|
|
{See TIFPSExec.OnRunLine}
|
|
TIFPSOnLineEvent = procedure(Sender: TIFPSExec);
|
|
{See TIFPSExec.AddSpecialProcImport}
|
|
TIFPSOnSpecialProcImport = function (Sender: TIFPSExec; p: PIFProcRec; Tag: Pointer): Boolean;
|
|
{TIFPSExec is the core of the script engine executer}
|
|
TIFPSExec = class(TObject)
|
|
Private
|
|
FId: Pointer;
|
|
FJumpFlag: Boolean;
|
|
FCallCleanup: Boolean;
|
|
function ReadData(var Data; Len: Cardinal): Boolean;
|
|
function ReadByte(var b: Cardinal): Boolean;
|
|
function ReadLong(var b: Cardinal): Boolean;
|
|
function DoCalc(var1, Var2: PIfVariant; CalcType: Cardinal): Boolean;
|
|
function DoBooleanCalc(var1, Var2: PIfVariant; Into: PIfVariant; Cmd: Cardinal): Boolean;
|
|
function SetVariantValue(dest, Src: PIfVariant): Boolean;
|
|
function ReadVariable(var NeedToFree: LongBool; UsePointer: LongBool): PIfVariant;
|
|
procedure DoBooleanNot(Vd: PIfVariant);
|
|
procedure DoMinus(Vd: PIfVariant);
|
|
procedure DoIntegerNot(Vd: PIfVariant);
|
|
function BuildArray(Dest, Src: PIFVariant): boolean;
|
|
Protected
|
|
{MM is the memory manager used internally. It's needed to create and destroy variants}
|
|
{$IFNDEF NOSMARTMM}MM: Pointer;
|
|
{$ENDIF}
|
|
{The exception stack}
|
|
FExceptionStack: TIFList;
|
|
{The list of resources}
|
|
FResources: TIFList;
|
|
{The list of exported variables}
|
|
FExportedVars: TIfList;
|
|
{FTypes contains all types used by the script}
|
|
FTypes: TIfList;
|
|
{FProcs contains all script procedures}
|
|
FProcs: TIfList;
|
|
{FGlobalVars contains the global variables of the current script}
|
|
FGlobalVars: TIfList;
|
|
{The current stack}
|
|
FStack: TIfList;
|
|
{The main proc no or -1 (no main proc)}
|
|
FMainProc: Cardinal;
|
|
{The current status of the script engine}
|
|
FStatus: TIFStatus;
|
|
{The current proc}
|
|
FCurrProc: PIFProcRec;
|
|
{The current position in the current proc}
|
|
FCurrentPosition: Cardinal;
|
|
{Current stack base}
|
|
FCurrStackBase: Cardinal;
|
|
{FOnRunLine event}
|
|
FOnRunLine: TIFPSOnLineEvent;
|
|
{List of SpecialProcs; See TIFPSExec.AddSpecialProc}
|
|
FSpecialProcList: TIfList;
|
|
{List of all registered external functions}
|
|
FRegProcs: TIfList;
|
|
{The proc where the last error occured}
|
|
ExProc: Cardinal;
|
|
{The position of the last error}
|
|
ExPos: Cardinal;
|
|
{The error code}
|
|
ExEx: TIFError;
|
|
{The optional parameter for the error}
|
|
ExParam: string;
|
|
{RunLine function}
|
|
procedure RunLine; virtual;
|
|
{ImportProc is called when the script needs to import an external function}
|
|
function ImportProc(const Name: ShortString; var proc: TIFProcRec): Boolean; Virtual;
|
|
{ExceptionProc is called when an error occurs}
|
|
procedure ExceptionProc(proc, Position: Cardinal; Ex: TIFError; const s: string); Virtual;
|
|
Public
|
|
{Call CMD_Err to cause an error and stop the script}
|
|
procedure CMD_Err(EC: TIFError);
|
|
{Call CMD_Err2 to cause an error and stop the script}
|
|
procedure CMD_Err2(EC: TIFError; const Param: string);
|
|
{Optional tag of the script engine}
|
|
property Id: Pointer read FID write FID;
|
|
{The MemoryManager used when calling CreateVariant/DestroyVariant}
|
|
{$IFNDEF NOSMARTMM}property MemoryManager: Pointer Read MM;{$ENDIF}
|
|
{This function will return about information}
|
|
class function About: string;
|
|
{Use RunProc to call a script function. The Params will not be freed after the call}
|
|
function RunProc(Params: TIfList; ProcNo: Cardinal): Boolean;
|
|
{Search for a type (l is the starting position)}
|
|
function FindType(StartAt: Cardinal; BaseType: TIFPSBaseType; var l: Cardinal): PIFTypeRec;
|
|
{Search for a type}
|
|
function FindType2(BaseType: TIFPSBaseType): PIFTypeRec;
|
|
{Return type no L}
|
|
function GetTypeNo(l: Cardinal): PIFTypeRec;
|
|
{Create an integer variant}
|
|
function CreateIntegerVariant(FType: PIFTypeRec; Value: Longint): PIfVariant;
|
|
{create a string variant}
|
|
function CreateStringVariant(FType: PIFTypeRec; const Value: string): PIfVariant;
|
|
{Create a float variant}
|
|
function CreateFloatVariant(FType: PIFTypeRec; Value: Extended): PIfVariant;
|
|
|
|
{Get Type that has been compiled with a name}
|
|
function GetType(const Name: string): Cardinal;
|
|
{Get function that has been compiled with a name}
|
|
function GetProc(const Name: string): Cardinal;
|
|
{Get variable that has been compiled with a name}
|
|
function GetVar(const Name: string): Cardinal;
|
|
{Get variable compiled with a name as a variant}
|
|
function GetVar2(const Name: string): PIFVariant;
|
|
{Get variable no (C)}
|
|
function GetVarNo(C: Cardinal): PIFVariant;
|
|
{Get Proc no (C)}
|
|
function GetProcNo(C: Cardinal): PIFProcRec;
|
|
|
|
{Create an instance of the executer}
|
|
constructor Create;
|
|
{Destroy this instance of the executer}
|
|
destructor Destroy; Override;
|
|
|
|
{Run the current script}
|
|
function RunScript: Boolean;
|
|
|
|
{Load data into the script engine}
|
|
function LoadData(const s: string): Boolean; virtual;
|
|
{Clear the currently loaded script}
|
|
procedure Clear; Virtual;
|
|
{Reset all variables in the script to zero}
|
|
procedure Cleanup; Virtual;
|
|
{Stop the script engine}
|
|
procedure Stop; Virtual;
|
|
{Pause the script engine}
|
|
procedure Pause; Virtual;
|
|
{Set CallCleanup to false when you don't want the script engine to cleanup all variables after RunScript}
|
|
property CallCleanup: Boolean read FCallCleanup write FCallCleanup;
|
|
{Status contains the current status of the scriptengine}
|
|
property Status: TIFStatus Read FStatus;
|
|
{The OnRunLine event is called after each executed script line}
|
|
property OnRunLine: TIFPSOnLineEvent Read FOnRunLine Write FOnRunLine;
|
|
{Add a special proc import; this is used for the dll and class library}
|
|
procedure AddSpecialProcImport(const FName: string; P: TIFPSOnSpecialProcImport; Tag: Pointer);
|
|
{Register a function by name}
|
|
function RegisterFunctionName(const Name: ShortString; ProcPtr: TIFProc;
|
|
Ext1, Ext2: Pointer): PProcRec;
|
|
{Clear the function list}
|
|
procedure ClearFunctionList;
|
|
{Contains the last error proc}
|
|
property ExceptionProcNo: Cardinal Read ExProc;
|
|
{Contains the last error position}
|
|
property ExceptionPos: Cardinal Read ExPos;
|
|
{Contains the last error code}
|
|
property ExceptionCode: TIFError Read ExEx;
|
|
{Contains the last error string}
|
|
property ExceptionString: string read ExParam;
|
|
|
|
{Add a resource}
|
|
procedure AddResource(Proc, P: Pointer);
|
|
{Check if P is a valid resource for Proc}
|
|
function IsValidResource(Proc, P: Pointer): Boolean;
|
|
{Delete a resource}
|
|
procedure DeleteResource(P: Pointer);
|
|
{Find a resource}
|
|
function FindProcResource(Proc: Pointer): Pointer;
|
|
{Find a resource}
|
|
function FindProcResource2(Proc: Pointer; var StartAt: Longint): Pointer;
|
|
end;
|
|
{Decrease the variant's refcount and free it if it's 0}
|
|
procedure DisposeVariant({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}p: PIfVariant);
|
|
{Create a variant}
|
|
function CreateVariant({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}n: PIFTypeRec): PIfVariant;
|
|
{Convert an error to a string}
|
|
function TIFErrorToString(x: TIFError; const Param: string): string;
|
|
{Get the value of a variant (as Cardinal/Longword)}
|
|
function GetUInt(Src: PIfVariant; var s: Boolean): Cardinal;
|
|
{Get the value of a variant (as Longint)}
|
|
function GetInt(Src: PIfVariant; var s: Boolean): Longint;
|
|
{Get the value of a variant (as Extended)}
|
|
function GetReal(Src: PIfVariant; var s: Boolean): Extended;
|
|
{Get the value of a variant (as String)}
|
|
function GetString(Src: PIfVariant; var s: Boolean): string;
|
|
{Set the value of an Integer variant in a list}
|
|
procedure LSetInt(List: TIfList; Pos: Cardinal; Val: Longint);
|
|
{Set the value of an unsigned integer variant in a list}
|
|
procedure LSetUInt(List: TIfList; Pos: Cardinal; Val: Cardinal);
|
|
{Get the value of an Integer variant in a list}
|
|
function LGetInt(List: TIfList; Pos: Cardinal): Longint;
|
|
{Get the value of an unsigned integer variant in a list}
|
|
function LGetUInt(List: TIfList; Pos: Cardinal): Cardinal;
|
|
{Set the value of a string variant in a list}
|
|
procedure LSetStr(List: TIfList; Pos: Cardinal; const s: string);
|
|
{Get the value of a string variant in a list}
|
|
function LGetStr(List: TIfList; Pos: Cardinal): string;
|
|
{Set the value of a real variant in a list}
|
|
procedure LSetReal(List: TIfList; Pos: Cardinal; const Val: Extended);
|
|
{Get the value of a real variant in a list}
|
|
function LGetReal(List: TIfList; Pos: Cardinal): Extended;
|
|
{Get the length of a variant array}
|
|
function GetIFPSArrayLength(SE: TIFPSExec; p: PIfVariant): Cardinal;
|
|
{Set the length of a variant array}
|
|
function SetIFPSArrayLength(SE: TIFPSExec; p: PIfVariant; NewLength: Cardinal): Boolean;
|
|
|
|
{Convert a variant to a string}
|
|
function IFPSVariantToString(p: PIfVariant): string;
|
|
{Free a list of variants and also the list}
|
|
procedure FreePIFVariantList({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}List: TIfList);
|
|
|
|
function VGetString(P: PIFVariant): string;
|
|
function VGetFloat(P: PIFVariant): Extended;
|
|
function VGetInt(P: PIFVariant): Longint;
|
|
{$IFNDEF NOINT64}
|
|
function VGetInt64(P: PIFVariant): Int64;
|
|
{$ENDIF}
|
|
|
|
procedure VSetString(P: PIFVariant; const d: string);
|
|
procedure VSetFloat(P: PIFVariant; const d: Extended);
|
|
procedure VSetInt(P: PIFVariant; const d: Longint);
|
|
{$IFNDEF NOINT64}
|
|
procedure VSetInt64(P: PIFVariant; const d: Int64);
|
|
{$ENDIF}
|
|
|
|
function RP(P: PIFVariant): PIFVariant;
|
|
// Makes sure that P is not a pointer.
|
|
|
|
const
|
|
ENoError = ERNoError;
|
|
ecCustomError = erCustomError;
|
|
|
|
|
|
procedure ChangeVariantType({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}p: PIFVariant; n: PIFTypeRec);
|
|
|
|
implementation
|
|
|
|
function RP(P: PIFVariant): PIFVariant;
|
|
begin
|
|
if (p <> nil) and (p^.FType^.BaseType = btPointer) then
|
|
Result:= p^.tPointer
|
|
else
|
|
Result := p;
|
|
end;
|
|
|
|
function VGetString(P: PIFVariant): string;
|
|
begin
|
|
p := RP(p);
|
|
if p = nil then begin Result := ''; exit; end;
|
|
case p^.FType^.BaseType of
|
|
btString: Result := TbtString(p^.tstring);
|
|
btChar: Result := p.tchar;
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWideString: Result := tbtWideString(p^.twidestring);
|
|
btWideChar: Result := tbtWideChar(p^.twidechar);
|
|
{$ENDIF}
|
|
else Result := '';
|
|
end;
|
|
end;
|
|
|
|
function VGetFloat(P: PIFVariant): Extended;
|
|
begin
|
|
p := RP(p);
|
|
if p = nil then begin Result := 0; exit; end;
|
|
case p^.FType^.BaseType of
|
|
btSingle: Result := p^.tsingle;
|
|
btDouble: Result := p^.tdouble;
|
|
btExtended: Result := p^.textended;
|
|
else Result := 0;
|
|
end;
|
|
end;
|
|
function VGetInt(P: PIFVariant): Longint;
|
|
begin
|
|
p := RP(p);
|
|
if p = nil then begin Result := 0; exit; end;
|
|
case p^.FType^.BaseType of
|
|
btu8: Result := p^.tu8;
|
|
bts8: Result := p^.ts8;
|
|
btu16: Result := p^.tu16;
|
|
bts16: Result := p^.ts16;
|
|
btu32, btProcPtr: Result := p^.tu32;
|
|
bts32: Result := p^.ts32;
|
|
else Result := 0;
|
|
end;
|
|
end;
|
|
{$IFNDEF NOINT64}
|
|
|
|
function VGetInt64(P: PIFVariant): Int64;
|
|
begin
|
|
p := RP(p);
|
|
if p = nil then begin Result := 0; exit; end;
|
|
case p^.FType^.BaseType of
|
|
btu8: Result := p^.tu8;
|
|
bts8: Result := p^.ts8;
|
|
btu16: Result := p^.tu16;
|
|
bts16: Result := p^.ts16;
|
|
btu32, btProcPtr: Result := p^.tu32;
|
|
bts32: Result := p^.ts32;
|
|
btS64: Result := p^.ts64;
|
|
else Result := 0;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
procedure VSetString(P: PIFVariant; const d: string);
|
|
begin
|
|
p := RP(p);
|
|
if p = nil then begin exit; end;
|
|
case p^.FType^.BaseType of
|
|
btString: TbtString(p^.tstring) := d;
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWideString: tbtWideString(p^.twidestring) := d;
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
procedure VSetFloat(P: PIFVariant; const d: Extended);
|
|
begin
|
|
p := RP(p);
|
|
if p = nil then begin exit; end;
|
|
case p^.FType^.BaseType of
|
|
btSingle: p^.tsingle := d;
|
|
btDouble: p^.tdouble := d;
|
|
btExtended: p^.textended := d;
|
|
end;
|
|
end;
|
|
procedure VSetInt(P: PIFVariant; const d: Longint);
|
|
begin
|
|
p := RP(p);
|
|
if p = nil then begin exit; end;
|
|
case p^.FType^.BaseType of
|
|
btu8: p^.tu8 := d;
|
|
bts8: p^.ts8 := d;
|
|
btu16: p^.tu16 := d;
|
|
bts16: p^.ts16 := d;
|
|
btu32, btProcPtr: p^.tu32 := d;
|
|
bts32: p^.ts32 := d;
|
|
btChar: p^.tchar:= char(d);
|
|
end;
|
|
end;
|
|
{$IFNDEF NOINT64}
|
|
procedure VSetInt64(P: PIFVariant; const d: Int64);
|
|
begin
|
|
p := RP(p);
|
|
if p = nil then begin exit; end;
|
|
case p^.FType^.BaseType of
|
|
btu8: p^.tu8 := d;
|
|
bts8: p^.ts8 := d;
|
|
btu16: p^.tu16 := d;
|
|
bts16: p^.ts16 := d;
|
|
btu32, btProcPtr: p^.tu32 := d;
|
|
bts32: p^.ts32 := d;
|
|
btS64: p^.ts64 := d;
|
|
btChar: p^.tchar := char(d);
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
{$IFNDEF NOWIDESTRING}
|
|
function MakeWString(const s: widestring): string;
|
|
var
|
|
i: Longint;
|
|
e: string;
|
|
b: boolean;
|
|
begin
|
|
Result := s;
|
|
i := 1;
|
|
b := false;
|
|
while i <= length(result) do
|
|
begin
|
|
if Result[i] = '''' then
|
|
begin
|
|
if not b then
|
|
begin
|
|
b := true;
|
|
Insert('''', Result, i);
|
|
inc(i);
|
|
end;
|
|
Insert('''', Result, i);
|
|
inc(i, 2);
|
|
end else if (Result[i] < #32) or (Result[i] > #255) then
|
|
begin
|
|
e := '#'+inttostr(ord(Result[i]));
|
|
Delete(Result, i, 1);
|
|
if b then
|
|
begin
|
|
b := false;
|
|
Insert('''', Result, i);
|
|
inc(i);
|
|
end;
|
|
Insert(e, Result, i);
|
|
inc(i, length(e));
|
|
end else begin
|
|
if not b then
|
|
begin
|
|
b := true;
|
|
Insert('''', Result, i);
|
|
inc(i, 2);
|
|
end else
|
|
inc(i);
|
|
end;
|
|
end;
|
|
if b then
|
|
begin
|
|
Result := Result + '''';
|
|
end;
|
|
if Result = '' then
|
|
Result := '''''';
|
|
end;
|
|
{$ENDIF}
|
|
function MakeString(const s: string): string;
|
|
var
|
|
i: Longint;
|
|
e: string;
|
|
b: boolean;
|
|
begin
|
|
Result := s;
|
|
i := 1;
|
|
b := false;
|
|
while i <= length(result) do
|
|
begin
|
|
if Result[i] = '''' then
|
|
begin
|
|
if not b then
|
|
begin
|
|
b := true;
|
|
Insert('''', Result, i);
|
|
inc(i);
|
|
end;
|
|
Insert('''', Result, i);
|
|
inc(i, 2);
|
|
end else if (Result[i] < #32) then
|
|
begin
|
|
e := '#'+inttostr(ord(Result[i]));
|
|
Delete(Result, i, 1);
|
|
if b then
|
|
begin
|
|
b := false;
|
|
Insert('''', Result, i);
|
|
inc(i);
|
|
end;
|
|
Insert(e, Result, i);
|
|
inc(i, length(e));
|
|
end else begin
|
|
if not b then
|
|
begin
|
|
b := true;
|
|
Insert('''', Result, i);
|
|
inc(i, 2);
|
|
end else
|
|
inc(i);
|
|
end;
|
|
end;
|
|
if b then
|
|
begin
|
|
Result := Result + '''';
|
|
end;
|
|
if Result = '' then
|
|
Result := '''''';
|
|
end;
|
|
|
|
function IFPSVariantToString(p: PIfVariant): string;
|
|
var
|
|
I: Longint;
|
|
begin
|
|
while p^.FType^.BaseType = btPointer do
|
|
begin
|
|
if p^.tPointer <> nil then p := p^.tPointer else break;
|
|
end;
|
|
if p^.FType^.BaseType = btVariant then P := p^.tvariant;
|
|
case p^.FType^.BaseType of
|
|
btProcptr: begin str(p^.tu32, Result); Result := 'Proc: '+result; end;
|
|
btU8: str(p^.tu8, Result);
|
|
btS8: str(p^.ts8, Result);
|
|
btU16: str(p^.tu16, Result);
|
|
btS16: str(p^.ts16, Result);
|
|
btU32: str(p^.tu32, Result);
|
|
btS32: str(p^.ts32, Result);
|
|
btSingle: str(p^.tsingle, Result);
|
|
btDouble: str(p^.tdouble, Result);
|
|
btExtended: str(p^.textended, Result);
|
|
btString, btPChar: Result := makestring(string(p^.tString));
|
|
btchar: Result := MakeString(p^.tchar);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btwidechar: Result := MakeWString(p^.tchar);
|
|
btWideString: Result := MakeWString(tbtwidestring(p^.tstring));
|
|
{$ENDIF}
|
|
{$IFNDEF NOINT64}btS64: str(p^.ts64, Result);{$ENDIF}
|
|
btRecord, btArray:
|
|
begin
|
|
Result := '[';
|
|
if p^.tArray <>nil then
|
|
begin
|
|
for i := 0 to pbtRecord(p^.tarray)^.FieldCount -1 do
|
|
begin
|
|
if i <> 0 then
|
|
Result := Result + ', ';
|
|
Result := Result + IFPSVariantToString(pbtRecord(p^.tarray)^.Fields[i]);
|
|
end;
|
|
end;
|
|
Result := Result + ']';
|
|
end;
|
|
btPointer: Result := 'Nil';
|
|
btResourcePointer: Result := '[ResourcePointer]';
|
|
else
|
|
Result := '[Invalid]';
|
|
end;
|
|
end;
|
|
|
|
|
|
function GetIFPSArrayLength(SE: TIFPSExec; p: PIfVariant): Cardinal;
|
|
begin
|
|
p := rp(p);
|
|
if p^.FType^.BaseType = btVariant then
|
|
begin
|
|
p := p^.tvariant;
|
|
if p^.ftype = nil then
|
|
begin
|
|
result := 0; exit;
|
|
end;
|
|
end;
|
|
if p^.FType^.BaseType <> btArray then begin
|
|
Result := 0;
|
|
exit;
|
|
end;
|
|
if p^.tArray = nil then
|
|
Result := 0
|
|
else
|
|
Result := pbtrecord(p^.tArray)^.FieldCount;
|
|
end;
|
|
|
|
function Min(const x, Y: Integer): Integer;
|
|
begin
|
|
if x < Y then Result := x else Result := Y;
|
|
end;
|
|
|
|
function SetIFPSArrayLength(SE: TIFPSExec; p: PIfVariant; NewLength: Cardinal): Boolean;
|
|
var
|
|
I, oldl: Integer;
|
|
r: pbtrecord;
|
|
begin
|
|
p := rp(p);
|
|
if p^.FType^.BaseType = btVariant then
|
|
begin
|
|
p := p^.tvariant;
|
|
if p^.ftype = nil then
|
|
begin
|
|
result := False; exit;
|
|
end;
|
|
end;
|
|
if p^.FType^.BaseType <> btArray then begin Result := False; exit;end;
|
|
if p^.tArray = nil then begin
|
|
I := NewLength;
|
|
if I > 0 then begin
|
|
try
|
|
GetMem(r, 4 + I * 4);
|
|
except
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
r^.FieldCount := I;
|
|
p^.tArray := r;
|
|
Dec(I);
|
|
while I >= 0 do begin
|
|
r^.Fields[I] := CreateVariant({$IFNDEF NOSMARTMM}SE.MemoryManager, {$ENDIF}SE.GetTypeNo(Cardinal(p^.FType^.Ext)));
|
|
if r^.Fields[I] = nil then begin
|
|
while I < Longint(NewLength) do begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}SE.MemoryManager, {$ENDIF}r.Fields[I]);
|
|
Inc(I);
|
|
end;
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
Dec(I);
|
|
end;
|
|
end;
|
|
end else begin
|
|
r := p^.tArray;
|
|
oldl := NewLength;
|
|
for I := oldl to r^.FieldCount - 1 do begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}SE.MemoryManager, {$ENDIF}r^.Fields[I]);
|
|
end;
|
|
if oldl = 0 then begin
|
|
FreeMem(r, 4 + 4 * r^.FieldCount);
|
|
p^.tArray := nil;
|
|
end else begin
|
|
I := oldl;
|
|
oldl := r^.FieldCount;
|
|
try
|
|
ReallocMem(r, 4 + 4 * I);
|
|
except
|
|
for I := 0 to Min(NewLength, oldl) - 1 do begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}SE.MemoryManager, {$ENDIF}r^.Fields[I]);
|
|
end;
|
|
FreeMem(r, 4 + 4 * NewLength);
|
|
p^.tArray := nil;
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
p^.tArray := r;
|
|
r^.FieldCount := I;
|
|
for I := r^.FieldCount - 1 downto oldl do begin
|
|
r^.Fields[I] := CreateVariant({$IFNDEF NOSMARTMM}SE.MemoryManager, {$ENDIF}SE.GetTypeNo(Cardinal(p^.FType^.Ext)));
|
|
if r^.Fields[I] = nil then begin
|
|
oldl := I;
|
|
while oldl < Longint(NewLength) do begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}SE.MemoryManager, {$ENDIF}r.Fields[oldl]);
|
|
Inc(oldl);
|
|
end;
|
|
FreeMem(r, 4 + 4 * r^.FieldCount);
|
|
p^.TArray := nil;
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
function SafeStr(const s: string): string;
|
|
var
|
|
i : Longint;
|
|
begin
|
|
Result := s;
|
|
for i := 1 to length(s) do
|
|
begin
|
|
if s[i] in [#0..#31] then
|
|
begin
|
|
Result := Copy(s, 1, i-1);
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
|
|
function TIFErrorToString(x: TIFError; const Param: string): string;
|
|
begin
|
|
case x of
|
|
ErNoError: Result := 'No Error';
|
|
erCannotImport: Result := 'Cannot Import '+Safestr(Param);
|
|
erInvalidType: Result := 'Invalid Type';
|
|
ErInternalError: Result := 'Internal error';
|
|
erInvalidHeader: Result := 'Invalid Header';
|
|
erInvalidOpcode: Result := 'Invalid Opcode';
|
|
erInvalidOpcodeParameter: Result := 'Invalid Opcode Parameter';
|
|
erNoMainProc: Result := 'no Main Proc';
|
|
erOutOfGlobalVarsRange: Result := 'Out of Global Vars range';
|
|
erOutOfProcRange: Result := 'Out of Proc Range';
|
|
ErOutOfRange: Result := 'Out Of Range';
|
|
erOutOfStackRange: Result := 'Out Of Stack Range';
|
|
ErTypeMismatch: Result := 'Type Mismatch';
|
|
erUnexpectedEof: Result := 'Unexpected End Of File';
|
|
erVersionError: Result := 'Version error';
|
|
ErDivideByZero: Result := 'divide by Zero';
|
|
erMathError: Result := 'Math error';
|
|
erCouldNotCallProc: Result := 'Could not call proc';
|
|
erOutofRecordRange: Result := 'Out of Record Fields Range';
|
|
erNullPointerException: Result := 'Null Pointer Exception';
|
|
erNullVariantError: Result := 'Null variant error';
|
|
erOutOfMemory: Result := 'Out Of Memory';
|
|
erException: Result := 'Exception: '+ Param;
|
|
erCustomError: Result := Param;
|
|
else
|
|
Result := 'Unknown error';
|
|
end;
|
|
//
|
|
end;
|
|
|
|
{$IFNDEF NOSMARTMM}
|
|
const
|
|
Count = 50;
|
|
|
|
type
|
|
TFreeIFVariant = packed record
|
|
NextFreeItem: Longint;
|
|
DummyData: array[0..SizeOf(TIfVariant) - SizeOf(Longint) - 1 +
|
|
SizeOf(Pointer)] of Byte;
|
|
end;
|
|
PPageData = ^TPageData;
|
|
TMyIFVariant = packed record
|
|
Page: PPageData;
|
|
p: TIfVariant;
|
|
end;
|
|
TPageData = packed record
|
|
ItemCount, FirstFreeItem: Longint;
|
|
PrevPage, NextPage,
|
|
PrevFreeItemsPage, NextFreeItemsPage: PPageData;
|
|
case Byte of
|
|
0: (BLOCK: array[0..Count - 1] of TMyIFVariant);
|
|
1: (FREELIST: array[0..Count - 1] of TFreeIFVariant);
|
|
end;
|
|
|
|
type
|
|
TIFVariantMemoryManager = class
|
|
Private
|
|
FFirstFreeItemsPage, FFirstPage: PPageData;
|
|
procedure CleanItem(Page: PPageData);
|
|
function AllocItem: Boolean;
|
|
Public
|
|
constructor Create;
|
|
destructor Destroy; Override;
|
|
procedure Clear;
|
|
|
|
function Alloc: PIfVariant;
|
|
procedure DisposeItem(p: PIfVariant);
|
|
end;
|
|
type
|
|
TPointingInteger = Longint; // same size as Pointer
|
|
|
|
|
|
function TIFVariantMemoryManager.Alloc: PIfVariant;
|
|
var
|
|
CB: PPageData;
|
|
I: Integer;
|
|
begin
|
|
if FFirstFreeItemsPage = nil then begin
|
|
if not AllocItem then begin
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
end;
|
|
CB := FFirstFreeItemsPage;
|
|
Inc(CB^.ItemCount);
|
|
I := CB^.FirstFreeItem;
|
|
CB^.FirstFreeItem := CB^.FREELIST[I].NextFreeItem;
|
|
Result := @CB^.BLOCK[I].p;
|
|
CB^.BLOCK[I].Page := CB;
|
|
if CB^.FirstFreeItem = -1 then begin // remove from freeitemspage list
|
|
if CB^.PrevFreeItemsPage <> nil then
|
|
CB^.PrevFreeItemsPage^.NextFreeItemsPage := CB^.NextFreeItemsPage;
|
|
if CB^.NextFreeItemsPage <> nil then
|
|
CB^.NextFreeItemsPage^.PrevFreeItemsPage := CB^.PrevFreeItemsPage;
|
|
if FFirstFreeItemsPage = CB then
|
|
FFirstFreeItemsPage := CB^.NextFreeItemsPage;
|
|
end;
|
|
end;
|
|
|
|
function TIFVariantMemoryManager.AllocItem: Boolean;
|
|
var
|
|
NewItem: PPageData;
|
|
I: Longint;
|
|
|
|
begin
|
|
try
|
|
New(NewItem);
|
|
except
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
|
|
NewItem^.ItemCount := 0;
|
|
NewItem^.FirstFreeItem := Count - 1;
|
|
NewItem^.PrevPage := nil;
|
|
NewItem^.NextPage := FFirstPage;
|
|
NewItem^.PrevFreeItemsPage := nil;
|
|
NewItem^.NextFreeItemsPage := FFirstFreeItemsPage;
|
|
|
|
for I := Count - 1 downto 0 do begin
|
|
NewItem^.FREELIST[I].NextFreeItem := I - 1;
|
|
end;
|
|
|
|
if FFirstPage <> nil then
|
|
FFirstPage^.PrevPage := NewItem;
|
|
if FFirstFreeItemsPage <> nil then
|
|
FFirstFreeItemsPage^.PrevPage := NewItem;
|
|
|
|
FFirstPage := NewItem;
|
|
FFirstFreeItemsPage := NewItem;
|
|
Result := True;
|
|
end;
|
|
|
|
procedure TIFVariantMemoryManager.CleanItem(Page: PPageData);
|
|
begin
|
|
if Page^.PrevPage <> nil then
|
|
Page^.PrevPage^.NextPage := Page^.NextPage;
|
|
if Page^.NextPage <> nil then
|
|
Page^.NextPage^.PrevPage := Page^.PrevPage;
|
|
|
|
if Page^.PrevFreeItemsPage <> nil then
|
|
Page^.PrevFreeItemsPage^.NextFreeItemsPage := Page^.NextFreeItemsPage;
|
|
if Page^.NextFreeItemsPage <> nil then
|
|
Page^.NextFreeItemsPage^.PrevFreeItemsPage := Page^.PrevFreeItemsPage;
|
|
if FFirstPage = Page then
|
|
FFirstPage := Page^.NextPage;
|
|
if FFirstFreeItemsPage = Page then
|
|
FFirstFreeItemsPage := Page^.NextFreeItemsPage;
|
|
Dispose(Page);
|
|
end;
|
|
|
|
procedure TIFVariantMemoryManager.Clear;
|
|
var
|
|
CB, NB: PPageData;
|
|
begin
|
|
CB := FFirstPage;
|
|
while CB <> nil do begin
|
|
NB := CB^.NextPage;
|
|
Dispose(CB);
|
|
CB := NB;
|
|
end;
|
|
FFirstPage := nil;
|
|
FFirstFreeItemsPage := nil;
|
|
end;
|
|
|
|
constructor TIFVariantMemoryManager.Create;
|
|
begin
|
|
inherited Create;
|
|
FFirstFreeItemsPage := nil;
|
|
FFirstPage := nil;
|
|
end;
|
|
|
|
destructor TIFVariantMemoryManager.Destroy;
|
|
begin
|
|
Clear;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
|
|
procedure TIFVariantMemoryManager.DisposeItem(p: PIfVariant);
|
|
var
|
|
Page: PPageData;
|
|
I: Longint;
|
|
begin
|
|
Page := PPageData(Pointer(TPointingInteger(p) - SizeOf(Pointer))^);
|
|
I := (TPointingInteger(p) - TPointingInteger(@Page^.BLOCK) - SizeOf(Pointer)) div SizeOf(TMyIFVariant);
|
|
Dec(Page^.ItemCount);
|
|
Page^.FREELIST[I].NextFreeItem := Page^.FirstFreeItem;
|
|
Page^.FirstFreeItem := I;
|
|
if Page^.ItemCount = 0 then begin
|
|
CleanItem(Page);
|
|
end
|
|
else if Page^.ItemCount = Count - 1 then begin // insert into list
|
|
if FFirstFreeItemsPage <> nil then
|
|
FFirstFreeItemsPage^.PrevFreeItemsPage := Page;
|
|
Page^.PrevFreeItemsPage := nil;
|
|
Page^.NextFreeItemsPage := FFirstFreeItemsPage;
|
|
FFirstFreeItemsPage := Page;
|
|
end;
|
|
end;
|
|
|
|
{$ENDIF}
|
|
|
|
const
|
|
ReturnAddressType: TIFTypeRec = (Ext: nil; BaseType: btReturnAddress);
|
|
|
|
type
|
|
PIFPSExceptionHandler =^TIFPSExceptionHandler;
|
|
TIFPSExceptionHandler = packed record
|
|
BasePtr, StackSize: Cardinal;
|
|
FinallyOffset, ExceptOffset, Finally2Offset, EndOfBlock: Cardinal;
|
|
end;
|
|
TIFPSHeader = packed record
|
|
HDR: Cardinal;
|
|
IFPSBuildNo: Cardinal;
|
|
TypeCount: Cardinal;
|
|
ProcCount: Cardinal;
|
|
VarCount: Cardinal;
|
|
MainProcNo: Cardinal;
|
|
ImportTableSize: Cardinal;
|
|
end;
|
|
|
|
TIFPSExportItem = packed record
|
|
ProcNo: Cardinal;
|
|
NameLength: Cardinal;
|
|
DeclLength: Cardinal;
|
|
end;
|
|
|
|
TIFPSType = packed record
|
|
BaseType: TIFPSBaseType;
|
|
end;
|
|
TIFPSProc = packed record
|
|
Flags: Byte;
|
|
end;
|
|
|
|
TIFPSVar = packed record
|
|
TypeNo: Cardinal;
|
|
Flags: Byte;
|
|
end;
|
|
PSpecialProc = ^TSpecialProc;
|
|
TSpecialProc = record
|
|
P: TIFPSOnSpecialProcImport;
|
|
namehash: Longint;
|
|
Name: string;
|
|
tag: pointer;
|
|
end;
|
|
|
|
procedure DisposeType(p: PIFTypeRec);
|
|
var
|
|
x: PIFRecordType;
|
|
begin
|
|
if p^.BaseType = btRecord then begin
|
|
x := p^.Ext;
|
|
x^.Data := '';
|
|
Dispose(x);
|
|
end;
|
|
Dispose(p);
|
|
end;
|
|
|
|
procedure DisposeProc(SE: TIFPSExec; p: PIFProcRec);
|
|
begin
|
|
if not p^.ExternalProc then
|
|
FreeMem(p^.Data, p^.Length);
|
|
|
|
Dispose(p);
|
|
end;
|
|
|
|
function Initrecord({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}FType:
|
|
PIFRecordType; var Rec: pbtrecord): Boolean;
|
|
var
|
|
I, J: Longint;
|
|
begin
|
|
I := (Length(FType^.Data) shr 2);
|
|
try
|
|
GetMem(Rec, 4 + 4 * I);
|
|
except
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
Rec.FieldCount := I;
|
|
for I := 0 to Rec.FieldCount - 1 do begin
|
|
Rec.Fields[I] := CreateVariant({$IFNDEF NOSMARTMM}MM,
|
|
{$ENDIF}PIFTypeRec((@FType^.Data[I shl 2 + 1])^));
|
|
if Rec.Fields[I] = nil then begin
|
|
for J := I - 1 downto 0 do begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Rec.Fields[J]);
|
|
FreeMem(Rec, 4 * 4 * (Length(FType^.Data) shr 2));
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
Result := True;
|
|
end;
|
|
|
|
procedure FreeRecord({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}Rec: pbtrecord);
|
|
var
|
|
I: Longint;
|
|
begin
|
|
if Rec <> nil then begin
|
|
for I := Rec.FieldCount - 1 downto 0 do
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Rec.Fields[I]);
|
|
FreeMem(Rec, Rec.FieldCount * 4 + 4);
|
|
end;
|
|
end;
|
|
|
|
procedure DisposeVariant({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}p: PIfVariant);
|
|
begin
|
|
if p <> nil then
|
|
if p^.RefCount = 0 then begin
|
|
if p^.FType <> nil then
|
|
begin
|
|
if (p^.FType^.BaseType = btPointer) and (p^.tPointer <> nil) then
|
|
begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}mm, {$ENDIF} p^.tPointer);
|
|
end else
|
|
if (p^.FType^.BaseType = btRecord) or (p^.FType^.BaseType = btArray) then
|
|
FreeRecord({$IFNDEF NOSMARTMM}MM, {$ENDIF}p^.trecord)
|
|
else if p^.FType^.BaseType = btString then
|
|
Finalize(TbtString((@p^.tstring)^))
|
|
{$IFNDEF NOWIDESTRING}
|
|
else if p^.FType^.BaseType = btWideString then
|
|
Finalize(TbtwideString((@p^.twidestring)^))
|
|
{$ENDIF}
|
|
else if p^.FType^.BaseType = btResourcePointer then
|
|
begin
|
|
if (@p^.tResourceFreeProc <> nil) then
|
|
begin
|
|
p^.tResourceFreeProc(vrfFree, p, nil);
|
|
end;
|
|
end else if p^.FType^.BaseType = btvariant then
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}p^.tvariant);
|
|
end;
|
|
{$IFNDEF NOSMARTMM}
|
|
TIFVariantMemoryManager(MM).DisposeItem(p);
|
|
{$ELSE}
|
|
Dispose(p);
|
|
{$ENDIF}
|
|
end
|
|
else
|
|
Dec(p^.RefCount);
|
|
end;
|
|
|
|
procedure ChangeVariantType({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}p: PIFVariant; n: PIFTypeRec);
|
|
begin
|
|
if p^.FType <> nil then
|
|
begin
|
|
if (p^.FType^.BaseType = btRecord) or (p^.FType^.BaseType = btArray) then
|
|
FreeRecord({$IFNDEF NOSMARTMM}MM, {$ENDIF}p^.trecord)
|
|
else if p^.FType^.BaseType = btString then
|
|
Finalize(TbtString((@p^.tstring)^))
|
|
{$IFNDEF NOWIDESTRING}
|
|
else if p^.FType^.BaseType = btWideString then
|
|
Finalize(TbtwideString((@p^.twidestring)^))
|
|
{$ENDIF}
|
|
else if p^.FType^.BaseType = btResourcePointer then
|
|
begin
|
|
if (@p^.tResourceFreeProc <> nil) then
|
|
begin
|
|
p^.tResourceFreeProc(vrfFree, p, nil);
|
|
end;
|
|
end else if p^.FType^.BaseType = btvariant then
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}p^.tvariant);
|
|
end;
|
|
p^.FType := n;
|
|
if n <> nil then
|
|
begin
|
|
if n^.BaseType = btVariant then
|
|
begin
|
|
{$IFDEF NOSMARTMM}
|
|
try
|
|
New(p^.tvariant);
|
|
except
|
|
p^.tvariant := nil;
|
|
exit;
|
|
end;
|
|
{$ELSE}
|
|
p^.TVariant := TIFVariantMemoryManager(MM).Alloc;
|
|
{$ENDIF}
|
|
p^.tVariant^.FType := nil;
|
|
p^.tvariant^.refcount := 0;
|
|
end else if (n^.BaseType = btRecord) then begin
|
|
p^.RefCount := 0;
|
|
if not Initrecord({$IFNDEF NOSMARTMM}MM, {$ENDIF}n^.Ext, pbtrecord(p^.trecord)) then begin
|
|
p^.trecord := nil;
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}p);
|
|
end;
|
|
end
|
|
else begin
|
|
FillChar(p^.RefCount, SizeOf(TIfVariant) - SizeOf(Pointer), 0);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function CreateVariant({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}n: PIFTypeRec): PIfVariant;
|
|
var
|
|
p: PIfVariant;
|
|
begin
|
|
if n = nil then begin
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
{$IFNDEF NOSMARTMM}
|
|
p := TIFVariantMemoryManager(MM).Alloc;
|
|
if p = nil then begin
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
{$ELSE}
|
|
try
|
|
New(p);
|
|
except
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
p^.FType := n;
|
|
if n^.BaseType = btVariant then
|
|
begin
|
|
{$IFDEF NOSMARTMM}
|
|
try
|
|
New(p^.tvariant);
|
|
except
|
|
p^.tvariant := nil;
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
{$ELSE}
|
|
p^.TVariant := TIFVariantMemoryManager(MM).Alloc;
|
|
{$ENDIF}
|
|
p^.tVariant^.FType := nil;
|
|
p^.tvariant^.RefCount := 0;
|
|
end else if (n^.BaseType = btRecord) then begin
|
|
p^.RefCount := 0;
|
|
if not Initrecord({$IFNDEF NOSMARTMM}MM, {$ENDIF}n^.Ext, pbtrecord(p^.trecord)) then begin
|
|
p^.trecord := nil;
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}p);
|
|
end;
|
|
end
|
|
else begin
|
|
FillChar(p^.RefCount, SizeOf(TIfVariant) - SizeOf(Pointer), 0);
|
|
end;
|
|
CreateVariant := p;
|
|
end;
|
|
procedure LSetReal(List: TIfList; Pos: Cardinal; const Val: Extended);
|
|
var
|
|
p: PIfVariant;
|
|
begin
|
|
p := List.GetItem(Pos);
|
|
if (p <> nil) and (p^.FType^.BaseType = btPointer) then p := p^.tPointer;
|
|
if p = nil then exit;
|
|
case p^.FType^.BaseType of
|
|
btSingle: p^.tsingle := Val;
|
|
btDouble: p^.tdouble := Val;
|
|
btExtended: p^.textended := Val;
|
|
end;
|
|
end;
|
|
|
|
function LGetReal(List: TIfList; Pos: Cardinal): Extended;
|
|
var
|
|
p: PIfVariant;
|
|
begin
|
|
p := List.GetItem(Pos);
|
|
if (p <> nil) and (p^.FType^.BaseType = btPointer) then p := p^.tPointer;
|
|
if p = nil then begin result := 0; exit; end;
|
|
case p^.FType^.BaseType of
|
|
btSingle: Result := p^.tsingle;
|
|
btDouble: Result := p^.tdouble;
|
|
btExtended: Result := p^.textended;
|
|
else
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
|
|
function LGetStr(List: TIfList; Pos: Cardinal): string;
|
|
var
|
|
p: PIfVariant;
|
|
begin
|
|
p := List.GetItem(Pos);
|
|
if (p <> nil) and (p^.FType^.BaseType = btPointer) then p := p^.tPointer;
|
|
if p = nil then begin result := ''; exit; end;
|
|
case p^.FType^.BaseType of
|
|
btString: Result := TbtString(p^.tstring);
|
|
btChar: Result := p.tchar;
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWideString: Result := tbtWideString(p^.twidestring);
|
|
btWideChar: Result := tbtWideChar(p^.twidechar);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
procedure LSetStr(List: TIfList; Pos: Cardinal; const s: string);
|
|
var
|
|
p: PIfVariant;
|
|
begin
|
|
p := List.GetItem(Pos);
|
|
if (p <> nil) and (p^.FType^.BaseType = btPointer) then p := p^.tPointer;
|
|
if p = nil then exit;
|
|
case p^.FType^.BaseType of
|
|
btstring: TbtString(p^.tstring) := s;
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWideString: tbtwidestring(p^.twidestring) := s;
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
function LGetUInt(List: TIfList; Pos: Cardinal): Cardinal;
|
|
var
|
|
p: PIfVariant;
|
|
begin
|
|
p := List.GetItem(Pos);
|
|
if (p <> nil) and (p^.FType^.BaseType = btPointer) then p := p^.tPointer;
|
|
if p = nil then begin result := 0; exit; end;
|
|
case p^.FType^.BaseType of
|
|
btU8: Result := p^.tu8;
|
|
btS8: Result := p^.tS8;
|
|
btU16: Result := p^.tu16;
|
|
btS16: Result := p^.ts16;
|
|
btU32, btProcPtr: Result := p^.tu32;
|
|
btS32: Result := p^.ts32;
|
|
{$IFNDEF NOINT64}btS64: Result := p^.ts64;{$ENDIF}
|
|
btChar: Result := ord(p^.tchar);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btwideChar: Result := ord(p^.twidechar);
|
|
btwidestring: begin
|
|
if Length(tbtwidestring(p^.twidestring)) =1 then
|
|
begin
|
|
Result := ord(tbtwidestring(p^.twidestring)[1]);
|
|
end else Result := 0;
|
|
end;
|
|
{$ENDIF}
|
|
btString: begin
|
|
if Length(tbtstring(p^.tstring)) =1 then
|
|
begin
|
|
Result := ord(tbtstring(p^.tstring)[1]);
|
|
end else Result := 0;
|
|
end;
|
|
else
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
|
|
function LGetInt(List: TIfList; Pos: Cardinal): Longint;
|
|
var
|
|
p: PIfVariant;
|
|
begin
|
|
p := List.GetItem(Pos);
|
|
if (p <> nil) and (p^.FType^.BaseType = btPointer) then p := p^.tPointer;
|
|
if p = nil then begin result := 0; exit; end;
|
|
case p^.FType^.BaseType of
|
|
btU8: Result := p^.tu8;
|
|
btS8: Result := p^.tS8;
|
|
btU16: Result := p^.tu16;
|
|
btS16: Result := p^.ts16;
|
|
btU32, btProcPtr: Result := p^.tu32;
|
|
btS32: Result := p^.ts32;
|
|
{$IFNDEF NOINT64}btS64: Result := p^.ts64;{$ENDIF}
|
|
btChar: Result := ord(p^.tchar);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btwideChar: Result := ord(p^.twidechar);
|
|
btwidestring: begin
|
|
if Length(tbtwidestring(p^.twidestring)) =1 then
|
|
begin
|
|
Result := ord(tbtwidestring(p^.twidestring)[1]);
|
|
end else Result := 0;
|
|
end;
|
|
{$ENDIF}
|
|
btString: begin
|
|
if Length(tbtstring(p^.tstring)) =1 then
|
|
begin
|
|
Result := ord(tbtstring(p^.tstring)[1]);
|
|
end else Result := 0;
|
|
end;
|
|
else
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
|
|
procedure LSetUInt(List: TIfList; Pos: Cardinal; Val: Cardinal);
|
|
var
|
|
Src: PIfVariant;
|
|
begin
|
|
Src := List.GetItem(Pos);
|
|
if (Src <> nil) and (Src^.FType^.BaseType = btPointer) then Src := SRc^.tPointer;
|
|
if Src = nil then exit;
|
|
case Src^.FType^.BaseType of
|
|
btU8: Src^.tu8 := Val;
|
|
btS8: Src^.tS8 := Val;
|
|
btU16: Src^.tu16 := Val;
|
|
btS16: Src^.ts16 := Val;
|
|
btU32, btProcPtr: Src^.tu32 := Val;
|
|
btS32: Src^.ts32 := Val;
|
|
{$IFNDEF NOINT64}btS64: src^.ts64 := Val;{$ENDIF}
|
|
btString: tbtstring(src^.tstring) := chr(Val);
|
|
btChar: src^.tchar := chr(val);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btwideChar: src^.tchar := chr(val);
|
|
btwidestring: tbtwidestring(src.twidestring) := widechar(val);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
procedure LSetInt(List: TIfList; Pos: Cardinal; Val: Longint);
|
|
var
|
|
Src: PIfVariant;
|
|
begin
|
|
Src := List.GetItem(Pos);
|
|
if (Src <> nil) and (Src^.FType^.BaseType = btPointer) then Src := SRc^.tPointer;
|
|
if Src = nil then exit;
|
|
case Src^.FType^.BaseType of
|
|
btU8: Src^.tu8 := Val;
|
|
btS8: Src^.tS8 := Val;
|
|
btU16: Src^.tu16 := Val;
|
|
btS16: Src^.ts16 := Val;
|
|
btU32, btProcPtr: Src^.tu32 := Val;
|
|
btS32: Src^.ts32 := Val;
|
|
{$IFNDEF NOINT64}btS64: src^.ts64 := Val;{$ENDIF}
|
|
btString: tbtstring(src^.tstring) := chr(Val);
|
|
btChar: src^.tchar := chr(val);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btwideChar: src^.tchar := chr(val);
|
|
btwidestring: tbtwidestrinG(src.twidestring) := widechar(val);
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
{$IFNDEF NOINT64}
|
|
function GetInt64(Src: PIfVariant; var s: Boolean): Int64;
|
|
begin
|
|
if (Src <> nil) and (Src^.FType^.BaseType = btPointer) then Src := SRc^.tPointer;
|
|
if Src = nil then begin Result := 0; exit; end;
|
|
case Src^.FType^.BaseType of
|
|
btVariant:
|
|
begin
|
|
if src^.TVariant^.FType <> nil then
|
|
Result := GetInt64(Src^.TVariant, s)
|
|
else
|
|
Result := 0;
|
|
end;
|
|
btU8: Result := Src^.tu8;
|
|
btS8: Result := Src^.tS8;
|
|
btU16: Result := Src^.tu16;
|
|
btS16: Result := Src^.ts16;
|
|
btU32, btProcPtr: Result := Src^.tu32;
|
|
btS32: Result := Src^.ts32;
|
|
btS64: Result := src^.ts64;
|
|
btChar: Result := ord(src^.tchar);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btwideChar: Result := ord(src^.twidechar);
|
|
btwidestring: begin
|
|
if Length(tbtwidestring(src^.twidestring)) =1 then
|
|
begin
|
|
Result := ord(tbtwidestring(src^.twidestring)[1]);
|
|
end else begin Result := 0; s := false; end;
|
|
end;
|
|
{$ENDIF}
|
|
btString: begin
|
|
if Length(tbtstring(src^.tstring)) =1 then
|
|
begin
|
|
Result := ord(tbtstring(src^.tstring)[1]);
|
|
end else begin Result := 0; s := False; end;
|
|
end;
|
|
else begin
|
|
s := False;
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function GetUInt(Src: PIfVariant; var s: Boolean): Cardinal;
|
|
begin
|
|
if (Src <> nil) and (Src^.FType^.BaseType = btPointer) then Src := SRc^.tPointer;
|
|
if Src = nil then begin Result := 0; exit; end;
|
|
case Src^.FType^.BaseType of
|
|
btVariant:
|
|
begin
|
|
if src^.TVariant^.FType <> nil then
|
|
Result := GetUINT(Src^.TVariant, s)
|
|
else
|
|
Result := 0;
|
|
end;
|
|
btU8: Result := Src^.tu8;
|
|
btS8: Result := Src^.tS8;
|
|
btU16: Result := Src^.tu16;
|
|
btS16: Result := Src^.ts16;
|
|
btU32, btProcPtr: Result := Src^.tu32;
|
|
btS32: Result := Src^.ts32;
|
|
{$IFNDEF NOINT64}btS64: Result := src^.ts64;{$ENDIF}
|
|
btChar: Result := ord(src^.tchar);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btwideChar: Result := ord(src^.twidechar);
|
|
btwidestring: begin
|
|
if Length(tbtwidestring(src^.twidestring)) =1 then
|
|
begin
|
|
Result := ord(tbtwidestring(src^.twidestring)[1]);
|
|
end else begin Result := 0; s:= false; end;
|
|
end;
|
|
{$ENDIF}
|
|
btString: begin
|
|
if Length(tbtstring(src^.tstring)) =1 then
|
|
begin
|
|
Result := ord(tbtstring(src^.tstring)[1]);
|
|
end else begin Result := 0; s := False; end;
|
|
end;
|
|
else begin
|
|
s := False;
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GetInt(Src: PIfVariant; var s: Boolean): Longint;
|
|
begin
|
|
if (Src <> nil) and (Src^.FType^.BaseType = btPointer) then Src := SRc^.tPointer;
|
|
if Src = nil then begin Result := 0; exit; end;
|
|
case Src^.FType^.BaseType of
|
|
btVariant:
|
|
begin
|
|
if src^.TVariant^.FType <> nil then
|
|
Result := GetInt(Src^.TVariant, s)
|
|
else
|
|
Result := 0;
|
|
end;
|
|
btU8: Result := Src^.tu8;
|
|
btS8: Result := Src^.tS8;
|
|
btU16: Result := Src^.tu16;
|
|
btS16: Result := Src^.ts16;
|
|
btU32, btProcPtr: Result := Src^.tu32;
|
|
btS32: Result := Src^.ts32;
|
|
{$IFNDEF NOINT64}btS64: Result := src^.ts64;{$ENDIF}
|
|
btChar: Result := ord(src^.tchar);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btwideChar: Result := ord(src^.twidechar);
|
|
btwidestring: begin
|
|
if Length(tbtwidestring(src^.twidestring)) =1 then
|
|
begin
|
|
Result := ord(tbtwidestring(src^.twidestring)[1]);
|
|
end else begin Result := 0; s := false; end;
|
|
end;
|
|
{$ENDIF}
|
|
btString: begin
|
|
if Length(tbtstring(src^.tstring)) =1 then
|
|
begin
|
|
Result := ord(tbtstring(src^.tstring)[1]);
|
|
end else begin Result := 0; s := False; end;
|
|
end;
|
|
else begin
|
|
s := False;
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GetReal(Src: PIfVariant; var s: Boolean): Extended;
|
|
begin
|
|
if (Src <> nil) and (Src^.FType^.BaseType = btPointer) then Src := SRc^.tPointer;
|
|
if Src = nil then begin Result := 0; exit; end;
|
|
case Src^.FType^.BaseType of
|
|
btVariant:
|
|
begin
|
|
if src^.TVariant^.FType <> nil then
|
|
Result := GetReal(Src^.TVariant, s)
|
|
else
|
|
Result := 0;
|
|
end;
|
|
btU8: Result := Src^.tu8;
|
|
btS8: Result := Src^.tS8;
|
|
btU16: Result := Src^.tu16;
|
|
btS16: Result := Src^.ts16;
|
|
btU32, btProcPtr: Result := Src^.tu32;
|
|
btS32: Result := Src^.ts32;
|
|
btSingle: Result := Src^.tsingle;
|
|
btDouble: Result := Src^.tdouble;
|
|
btExtended: Result := Src^.textended;
|
|
else begin
|
|
s := False;
|
|
Result := 0;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GetString(Src: PIfVariant; var s: Boolean): string;
|
|
begin
|
|
if (Src <> nil) and (Src^.FType^.BaseType = btPointer) then Src := SRc^.tPointer;
|
|
if Src = nil then begin Result := ''; exit; end;
|
|
case Src^.FType^.BaseType of
|
|
btVariant:
|
|
begin
|
|
if src^.TVariant^.FType <> nil then
|
|
Result := GetString(Src^.TVariant, s)
|
|
else
|
|
Result := '';
|
|
end;
|
|
btchar: Result := src^.tchar;
|
|
btPChar, btString: Result := TbtString((@Src^.tstring)^);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btwidechar: Result := src^.twidechar;
|
|
btwideString: Result := TbtwideString((@Src^.twidestring)^);
|
|
{$ENDIF}
|
|
else begin
|
|
s := False;
|
|
Result := '';
|
|
end;
|
|
end;
|
|
end;
|
|
{$IFNDEF NOWIDESTRING}
|
|
function GetWideString(Src: PIfVariant; var s: Boolean): widestring;
|
|
begin
|
|
if (Src <> nil) and (Src^.FType^.BaseType = btPointer) then Src := SRc^.tPointer;
|
|
if Src = nil then begin Result := ''; exit; end;
|
|
case Src^.FType^.BaseType of
|
|
btVariant:
|
|
begin
|
|
if src^.TVariant^.FType <> nil then
|
|
Result := GetString(Src^.TVariant, s)
|
|
else
|
|
Result := '';
|
|
end;
|
|
btchar: Result := Src^.tchar;
|
|
btPChar, btString: Result := TbtString((@Src^.tstring)^);
|
|
btwidechar: Result := src^.twidechar;
|
|
btwideString: Result := TbtwideString((@Src^.twidestring)^);
|
|
else begin
|
|
s := False;
|
|
Result := '';
|
|
end;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
function LookupProc(List: TIfList; const Name: ShortString): PProcRec;
|
|
var
|
|
h, l: Longint;
|
|
begin
|
|
h := MakeHash(Name);
|
|
for l := 0 to List.Count - 1 do begin
|
|
if (PProcRec(List.GetItem(l))^.Hash = h) and (PProcRec(List.GetItem(l))^.Name
|
|
= Name) then begin
|
|
Result := List.GetItem(l);
|
|
exit;
|
|
end;
|
|
end;
|
|
Result := nil;
|
|
end;
|
|
|
|
{ TIFPSExec }
|
|
|
|
procedure TIFPSExec.ClearFunctionList;
|
|
var
|
|
x: PProcRec;
|
|
l: Longint;
|
|
begin
|
|
for l := 0 to FRegProcs.Count - 1 do begin
|
|
x := FRegProcs.GetItem(l);
|
|
if @x^.FreeProc <> nil then x^.FreeProc(Self, x);
|
|
Dispose(x);
|
|
end;
|
|
FRegProcs.Clear;
|
|
end;
|
|
|
|
class function TIFPSExec.About: string;
|
|
begin
|
|
Result := 'Innerfuse Pascal Script III ' + IFPSCurrentversion + '. Copyright (c) 2001-2002 by Carlo Kok';
|
|
end;
|
|
|
|
procedure TIFPSExec.Cleanup;
|
|
var
|
|
I: Longint;
|
|
p: PIfVariant;
|
|
begin
|
|
if FStatus <> isLoaded then
|
|
exit;
|
|
for I := 0 to Longint(FGlobalVars.Count) - 1 do begin
|
|
p := FGlobalVars.GetItem(I);
|
|
FGlobalVars.SetItem(I, CreateVariant({$IFNDEF NOSMARTMM}MM,
|
|
{$ENDIF}p^.FType));
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}p);
|
|
end;
|
|
end;
|
|
type
|
|
PIFPSExportedVar = ^TIFPSExportedVar;
|
|
TIFPSExportedVar = record
|
|
FName: string;
|
|
FNameHash: Longint;
|
|
FVarNo: Cardinal;
|
|
end;
|
|
|
|
procedure TIFPSExec.Clear;
|
|
var
|
|
I: Longint;
|
|
temp: PIFPSResource;
|
|
Proc: TIFPSResourceFreeProc;
|
|
pp: PIFPSExceptionHandler;
|
|
begin
|
|
for i := Longint(FExceptionStack.Count) -1 downto 0 do
|
|
begin
|
|
pp := FExceptionStack.GetItem(i);
|
|
Dispose(pp);
|
|
end;
|
|
for i := Longint(FResources.Count) -1 downto 0 do
|
|
begin
|
|
Temp := FResources.GetItem(i);
|
|
Proc := Temp^.Proc;
|
|
Proc(Self, Temp^.P);
|
|
Dispose(Temp);
|
|
end;
|
|
for i := Longint(FExportedVars.Count) -1 downto 0 do
|
|
begin
|
|
Dispose(PIFPSExportedVar(FExportedVars.GetItem(I)));
|
|
end;
|
|
for I := 0 to Longint(FStack.Count) - 1 do begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FStack.GetItem(I));
|
|
end;
|
|
for I := 0 to Longint(FProcs.Count) - 1 do begin
|
|
DisposeProc(Self, FProcs.GetItem(I));
|
|
end;
|
|
for I := 0 to Longint(FGlobalVars.Count) - 1 do begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FGlobalVars.GetItem(I));
|
|
end;
|
|
for I := 0 to Longint(FTypes.Count) - 1 do begin
|
|
DisposeType(FTypes.GetItem(I));
|
|
end;
|
|
FStack.Clear;
|
|
FProcs.Clear;
|
|
FGlobalVars.Clear;
|
|
FTypes.Clear;
|
|
FStatus := isNotLoaded;
|
|
FResources.Clear;
|
|
FExportedVars.Clear;
|
|
FExceptionStack.Clear;
|
|
end;
|
|
|
|
constructor TIFPSExec.Create;
|
|
begin
|
|
inherited Create;
|
|
{$IFNDEF NOSMARTMM}MM := TIFVariantMemoryManager.Create;
|
|
{$ENDIF}
|
|
FExceptionStack := TIfList.Create;
|
|
FCallCleanup := False;
|
|
FResources := TIfList.Create;
|
|
FTypes := TIfList.Create;
|
|
FProcs := TIfList.Create;
|
|
FGlobalVars := TIfList.Create;
|
|
FStack := TIfList.Create;
|
|
FMainProc := 0;
|
|
FStatus := isNotLoaded;
|
|
FRegProcs := TIfList.Create;
|
|
FExportedVars := TIfList.create;
|
|
FSpecialProcList := TIfList.Create;
|
|
end;
|
|
|
|
destructor TIFPSExec.Destroy;
|
|
var
|
|
I: Longint;
|
|
P: PSpecialProc;
|
|
begin
|
|
Clear;
|
|
for I := FSpecialProcList.Count -1 downto 0 do
|
|
begin
|
|
P := FSpecialProcList.GetItem(I);
|
|
Dispose(p);
|
|
end;
|
|
FStack.Free;
|
|
FResources.Free;
|
|
FExportedVars.Free;
|
|
FGlobalVars.Free;
|
|
FProcs.Free;
|
|
FTypes.Free;
|
|
FSpecialProcList.Free;
|
|
ClearFunctionList;
|
|
|
|
FRegProcs.Free;
|
|
FExceptionStack.Free;
|
|
{$IFNDEF NOSMARTMM}TIFVariantMemoryManager(MM).Free;
|
|
{$ENDIF}
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TIFPSExec.ExceptionProc(proc, Position: Cardinal; Ex: TIFError; const s: string);
|
|
var
|
|
d, l: Longint;
|
|
pp: PIFPSExceptionHandler;
|
|
begin
|
|
ExProc := proc;
|
|
ExPos := Position;
|
|
ExEx := Ex;
|
|
ExParam := s;
|
|
if Ex = eNoError then Exit;
|
|
for d := FExceptionStack.Count -1 downto 0 do
|
|
begin
|
|
pp := FExceptionStack.GetItem(d);
|
|
if FStack.Count > pp^.StackSize then
|
|
begin
|
|
for l := Longint(FStack.count) -1 downto Longint(pp^.StackSize) do
|
|
begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}mm, {$ENDIF}FStack.GetItem(l));
|
|
FStack.Delete(l);
|
|
end;
|
|
end;
|
|
FCurrStackBase := pp^.BasePtr;
|
|
if pp^.FinallyOffset <> cardinal(-1) then
|
|
begin
|
|
FCurrentPosition := pp^.FinallyOffset;
|
|
pp^.FinallyOffset := cardinal(-1);
|
|
Exit;
|
|
end else if pp^.ExceptOffset <> cardinal(-1) then
|
|
begin
|
|
FCurrentPosition := pp^.ExceptOffset;
|
|
pp^.ExceptOffset := cardinal(-1);
|
|
Exit;
|
|
end else if pp^.Finally2Offset <> Cardinal(-1) then
|
|
begin
|
|
FCurrentPosition := pp^.FinallyOffset;
|
|
pp^.FinallyOffset := cardinal(-1);
|
|
Exit;
|
|
end;
|
|
Dispose(pp);
|
|
FExceptionStack.Delete(FExceptionStack.Count -1);
|
|
end;
|
|
// FStatus := isPaused;
|
|
end;
|
|
|
|
function TIFPSExec.ImportProc(const Name: ShortString; var proc: TIFProcRec): Boolean;
|
|
var
|
|
u: PProcRec;
|
|
fname: string;
|
|
I, fnh: Longint;
|
|
P: PSpecialProc;
|
|
|
|
begin
|
|
if name = '' then
|
|
begin
|
|
fname := proc.ExportDecl;
|
|
fname := copy(fname, 1, pos(':', fname)-1);
|
|
fnh := MakeHash(fname);
|
|
for I := FSpecialProcList.Count -1 downto 0 do
|
|
begin
|
|
p := FSpecialProcList.GetItem(I);
|
|
IF (p^.name = '') or ((p^.namehash = fnh) and (p^.name = fname)) then
|
|
begin
|
|
if p^.P(Self, @Proc, p^.tag) then
|
|
begin
|
|
Result := True;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
Result := FAlse;
|
|
exit;
|
|
end;
|
|
u := LookupProc(FRegProcs, Name);
|
|
if u = nil then begin
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
proc.ProcPtr := u^.ProcPtr;
|
|
proc.Ext1 := u^.Ext1;
|
|
proc.Ext2 := u^.Ext2;
|
|
Result := True;
|
|
end;
|
|
|
|
function TIFPSExec.RegisterFunctionName(const Name: ShortString; ProcPtr: TIFProc; Ext1, Ext2: Pointer): PProcRec;
|
|
var
|
|
p: PProcRec;
|
|
begin
|
|
if LookupProc(FRegProcs, Name) <> nil then begin
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
New(p);
|
|
p^.Name := Name;
|
|
p^.Hash := MakeHash(Name);
|
|
p^.ProcPtr := ProcPtr;
|
|
p^.FreeProc := nil;
|
|
p^.Ext1 := Ext1;
|
|
p^.Ext2 := Ext2;
|
|
FRegProcs.Add(p);
|
|
Result := P;
|
|
end;
|
|
|
|
function TIFPSExec.LoadData(const s: string): Boolean;
|
|
var
|
|
HDR: TIFPSHeader;
|
|
Pos: Cardinal;
|
|
|
|
function read(var Data; Len: Cardinal): Boolean;
|
|
begin
|
|
if Longint(Pos + Len) <= Length(s) then begin
|
|
Move(s[Pos + 1], Data, Len);
|
|
Pos := Pos + Len;
|
|
read := True;
|
|
end
|
|
else
|
|
read := False;
|
|
end;
|
|
{$WARNINGS OFF}
|
|
|
|
function LoadTypes: Boolean;
|
|
var
|
|
currf: TIFPSType;
|
|
Curr: PIFTypeRec;
|
|
currr: PIFRecordType;
|
|
fe: Boolean;
|
|
l: Longint;
|
|
d: Cardinal;
|
|
|
|
function resolve(var s: string): Boolean;
|
|
var
|
|
l: Longint;
|
|
p: PIFTypeRec;
|
|
begin
|
|
l := 1;
|
|
while l < Length(s) do begin
|
|
p := FTypes.GetItem(Cardinal(s[l]));
|
|
if p = nil then begin
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
PIFTypeRec((@s[l])^) := p;
|
|
if p^.BaseType = btRecord then begin
|
|
Delete(s, l, 4);
|
|
insert(PIFRecordType(p^.Ext)^.Data, s, l);
|
|
end;
|
|
l := l + 4;
|
|
end;
|
|
Result := True;
|
|
end;
|
|
begin
|
|
LoadTypes := True;
|
|
for l := 0 to HDR.TypeCount - 1 do begin
|
|
if not read(currf, SizeOf(currf)) then begin
|
|
cmd_err(erUnexpectedEof);
|
|
LoadTypes := False;
|
|
exit;
|
|
end;
|
|
if (currf.BaseType and 128) <> 0 then begin
|
|
fe := True;
|
|
currf.BaseType := currf.BaseType - 128;
|
|
end else
|
|
fe := False;
|
|
try
|
|
New(Curr);
|
|
except
|
|
CMD_Err(erOutOfMemory);
|
|
LoadTypes := False;
|
|
exit;
|
|
end;
|
|
case currf.BaseType of
|
|
{$IFNDEF NOINT64}bts64, {$ENDIF}
|
|
btU8, btS8, btU16, btS16, btU32, btS32, btProcPtr,btSingle, btDouble, btExtended, btString, btPointer, btPChar, btResourcePointer, btVariant, btChar{$IFNDEF NOWIDESTRING}, btWideString, btWideChar{$ENDIF}: begin
|
|
Curr^.BaseType := currf.BaseType;
|
|
Curr^.Ext := nil;
|
|
FTypes.Add(Curr);
|
|
end;
|
|
btArray: begin
|
|
if not read(d, 4) then begin // Read type
|
|
cmd_err(erUnexpectedEof);
|
|
LoadTypes := False;
|
|
exit;
|
|
end;
|
|
if (d >= FTypes.Count) then begin
|
|
cmd_err(erTypeMismatch);
|
|
LoadTypes := False;
|
|
exit;
|
|
end;
|
|
Curr^.BaseType := currf.BaseType;
|
|
Curr^.Ext := Pointer(d);
|
|
FTypes.Add(Curr);
|
|
end;
|
|
btRecord: begin
|
|
if not read(d, 4) or (d = 0) then begin
|
|
cmd_err(erUnexpectedEof);
|
|
LoadTypes := false;
|
|
exit;
|
|
end;
|
|
try
|
|
New(currr);
|
|
except
|
|
cmd_err(erOutOfMemory);
|
|
LoadTypes := False;
|
|
exit;
|
|
end;
|
|
SetLength(currr^.Data, d * 4);
|
|
if not read(currr^.Data[1], d * 4) then begin
|
|
currr^.Data := '';
|
|
Dispose(currr);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadTypes := False;
|
|
exit;
|
|
end;
|
|
if not resolve(currr^.Data) then begin
|
|
currr^.Data := '';
|
|
Dispose(currr);
|
|
cmd_err(erInvalidType);
|
|
LoadTypes := False;
|
|
exit;
|
|
end;
|
|
Curr^.BaseType := currf.BaseType;
|
|
Curr^.Ext := currr;
|
|
FTypes.Add(Curr);
|
|
end;
|
|
else begin
|
|
LoadTypes := False;
|
|
CMD_Err(erInvalidType);
|
|
Dispose(Curr);
|
|
exit;
|
|
end;
|
|
end;
|
|
if fe then begin
|
|
if not read(d, 4) then begin
|
|
cmd_err(erUnexpectedEof);
|
|
LoadTypes := False;
|
|
exit;
|
|
end;
|
|
if d > IFPSAddrNegativeStackStart then begin
|
|
cmd_err(erInvalidType);
|
|
LoadTypes := False;
|
|
exit;
|
|
end;
|
|
SetLength(Curr^.ExportName, d);
|
|
if not read(Curr^.ExportName[1], d) then begin
|
|
cmd_err(erUnexpectedEof);
|
|
LoadTypes := False;
|
|
exit;
|
|
end;
|
|
Curr^.ExportNameHash := MakeHash(Curr^.ExportName);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function LoadProcs: Boolean;
|
|
var
|
|
Rec: TIFPSProc;
|
|
n: string;
|
|
b: Byte;
|
|
l, L2, L3: Longint;
|
|
Curr: PIFProcRec;
|
|
begin
|
|
LoadProcs := True;
|
|
for l := 0 to HDR.ProcCount - 1 do begin
|
|
if not read(Rec, SizeOf(Rec)) then begin
|
|
cmd_err(erUnexpectedEof);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
try
|
|
New(Curr);
|
|
except
|
|
cmd_err(erOutOfMemory);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
Curr^.ExternalProc := (Rec.Flags and 1) <> 0;
|
|
if Curr^.ExternalProc then begin
|
|
if not read(b, 1) then begin
|
|
Dispose(Curr);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
SetLength(n, b);
|
|
if not read(n[1], b) then begin
|
|
Dispose(Curr);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
Curr^.Name := n;
|
|
if (Rec.Flags and 3 = 3) then
|
|
begin
|
|
if (not Read(L2, 4)) or (L2 > Length(s) - Pos) then
|
|
begin
|
|
Dispose(Curr);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
SetLength(n, L2);
|
|
Read(n[1], L2); // no check is needed
|
|
Curr^.ExportDecl := n;
|
|
end;
|
|
if not ImportProc(Curr^.Name, Curr^) then begin
|
|
if Curr^.Name <> '' then
|
|
CMD_Err2(erCannotImport, Curr^.Name)
|
|
else if Curr^.ExportDecl <> '' then
|
|
CMD_Err2(erCannotImport, curr^.ExportDecl)
|
|
else
|
|
CMD_Err2(erCannotImport, curr^.ExportName);
|
|
Dispose(Curr);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
end
|
|
else begin
|
|
if not read(L2, 4) then begin
|
|
Dispose(Curr);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
if not read(L3, 4) then begin
|
|
Dispose(Curr);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
if (L2 < 0) or (L2 >= Length(s)) or (L2 + L3 > Length(s)) or (L3 = 0) then begin
|
|
Dispose(Curr);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
GetMem(Curr^.Data, L3);
|
|
Move(s[L2 + 1], Curr^.Data^, L3);
|
|
Curr^.Length := L3;
|
|
if (Rec.Flags and 2) <> 0 then begin // exported
|
|
if not read(L3, 4) then begin
|
|
Dispose(Curr);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
if L3 > IFPSAddrNegativeStackStart then begin
|
|
Dispose(Curr);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
SetLength(Curr^.ExportName, L3);
|
|
if not read(Curr^.ExportName[1], L3) then begin
|
|
Dispose(Curr);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
if not read(L3, 4) then begin
|
|
Dispose(Curr);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
if L3 > IFPSAddrNegativeStackStart then begin
|
|
Dispose(Curr);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
SetLength(Curr^.ExportDecl, L3);
|
|
if not read(Curr^.ExportDecl[1], L3) then begin
|
|
Dispose(Curr);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadProcs := False;
|
|
exit;
|
|
end;
|
|
Curr^.ExportNameHash := MakeHash(Curr^.ExportName);
|
|
end;
|
|
end;
|
|
FProcs.Add(Curr);
|
|
end;
|
|
end;
|
|
{$WARNINGS ON}
|
|
|
|
function LoadVars: Boolean;
|
|
var
|
|
l, n: Longint;
|
|
e: PIFPSExportedVar;
|
|
Rec: TIFPSVar;
|
|
Curr: PIfVariant;
|
|
begin
|
|
LoadVars := True;
|
|
for l := 0 to HDR.VarCount - 1 do begin
|
|
if not read(Rec, SizeOf(Rec)) then begin
|
|
cmd_err(erUnexpectedEof);
|
|
LoadVars := False;
|
|
exit;
|
|
end;
|
|
if Rec.TypeNo >= HDR.TypeCount then begin
|
|
cmd_err(erInvalidType);
|
|
LoadVars := False;
|
|
exit;
|
|
end;
|
|
Curr := CreateVariant({$IFNDEF NOSMARTMM}MM,
|
|
{$ENDIF}FTypes.GetItem(Rec.TypeNo));
|
|
if Curr = nil then begin
|
|
cmd_err(erInvalidType);
|
|
LoadVars := False;
|
|
exit;
|
|
end;
|
|
if (Rec.Flags and 1) <> 0then
|
|
begin
|
|
if not read(n, 4) then begin
|
|
cmd_err(erUnexpectedEof);
|
|
LoadVars := False;
|
|
exit;
|
|
end;
|
|
new(e);
|
|
try
|
|
SetLength(e^.FName, n);
|
|
if not Read(e^.FName[1], n) then
|
|
begin
|
|
dispose(e);
|
|
cmd_err(erUnexpectedEof);
|
|
LoadVars := False;
|
|
exit;
|
|
end;
|
|
e^.FNameHash := MakeHash(e^.FName);
|
|
e^.FVarNo := FGlobalVars.Count;
|
|
FExportedVars.Add(E);
|
|
except
|
|
dispose(e);
|
|
cmd_err(erInvalidType);
|
|
LoadVars := False;
|
|
exit;
|
|
end;
|
|
end;
|
|
FGlobalVars.Add(Curr);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Clear;
|
|
Pos := 0;
|
|
LoadData := False;
|
|
if not read(HDR, SizeOf(HDR)) then
|
|
begin
|
|
CMD_Err(erInvalidHeader);
|
|
exit;
|
|
end;
|
|
if HDR.HDR <> IFPSValidHeader then
|
|
begin
|
|
CMD_Err(erInvalidHeader);
|
|
exit;
|
|
end;
|
|
if (HDR.IFPSBuildNo > IFPSCurrentBuildNo) or (HDR.IFPSBuildNo < IFPSLowBuildSupport) then begin
|
|
CMD_Err(erInvalidHeader);
|
|
exit;
|
|
end;
|
|
if not LoadTypes then
|
|
begin
|
|
Clear;
|
|
exit;
|
|
end;
|
|
if not LoadProcs then
|
|
begin
|
|
Clear;
|
|
exit;
|
|
end;
|
|
if not LoadVars then
|
|
begin
|
|
Clear;
|
|
exit;
|
|
end;
|
|
if (HDR.MainProcNo >= FProcs.Count) and (HDR.MainProcNo <> Cardinal(-1))then begin
|
|
CMD_Err(erNoMainProc);
|
|
Clear;
|
|
exit;
|
|
end;
|
|
// Load Import Table
|
|
FMainProc := HDR.MainProcNo;
|
|
FStatus := isLoaded;
|
|
Result := True;
|
|
end;
|
|
|
|
procedure TIFPSExec.Pause;
|
|
begin
|
|
if FStatus = isRunning then
|
|
FStatus := isPaused;
|
|
end;
|
|
|
|
function TIFPSExec.ReadData(var Data; Len: Cardinal): Boolean;
|
|
begin
|
|
if FCurrentPosition + Len <= FCurrProc.Length then begin
|
|
Move(FCurrProc.Data^[FCurrentPosition], Data, Len);
|
|
FCurrentPosition := FCurrentPosition + Len;
|
|
Result := True;
|
|
end
|
|
else
|
|
Result := False;
|
|
end;
|
|
|
|
procedure TIFPSExec.CMD_Err(EC: TIFError); // Error
|
|
begin
|
|
CMD_Err2(ec, '');
|
|
end;
|
|
|
|
function TIFPSExec.BuildArray(Dest, Src: PIFVariant): boolean;
|
|
var
|
|
i, j: Longint;
|
|
t: pbtrecord;
|
|
begin
|
|
if (Src^.FType^.BaseType = btVariant) and (Src^.TVariant^.FType <> nil) and (Src^.TVariant^.FType^.BaseType = btArray) then
|
|
Src := Src^.TVariant;
|
|
if (Src^.FType^.BaseType <> btArray) and (Src^.FType^.BaseType <> btRecord) then
|
|
begin
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
if Dest^.TArray <> nil then
|
|
begin
|
|
for i := 0 to pbtrecord(Dest^.Tarray)^.FieldCount -1 do
|
|
begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM ,{$ENDIF}pbtrecord(Dest^.Tarray)^.fields[i]);
|
|
end;
|
|
FreeMem(pbtrecord(Dest^.Tarray), pbtrecord(Dest^.Tarray)^.FieldCount * 4 + 4);
|
|
end;
|
|
if src^.TArray = nil then
|
|
begin
|
|
Dest^.TArray := nil;
|
|
Result := true;
|
|
exit;
|
|
end;
|
|
try
|
|
getmem(t, pbtRecord(src^.Tarray)^.FieldCount * 4 +4);
|
|
t.FieldCount := pbtRecord(src^.Tarray)^.FieldCount;
|
|
except
|
|
Dest^.TArray := nil;
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
for i := pbtRecord(src^.Tarray)^.FieldCount -1 downto 0 do
|
|
begin
|
|
t^.Fields[i] := CreateVariant({$IFNDEF NOSMARTMM}mm, {$ENDIF} pbtRecord(src^.Tarray)^.Fields[i]^.FType);
|
|
if t^.Fields[i] = nil then
|
|
begin
|
|
Freemem(t, t^.FieldCount * 4 + 4);
|
|
for j := 0 to i -1 do
|
|
begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}mm, {$ENDIF} t^.Fields[j]);
|
|
end;
|
|
Dest^.TArray := nil;
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
if not SetVariantValue(t^.Fields[i], pbtRecord(src^.Tarray)^.Fields[i]) then
|
|
begin
|
|
for j := pbtRecord(src^.Tarray)^.FieldCount -1 downto i do
|
|
begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}mm, {$ENDIF} t^.Fields[j]);
|
|
end;
|
|
Freemem(t, t^.FieldCount * 4 + 4);
|
|
Dest^.TArray := nil;
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
end;
|
|
dest^.TArray := t;
|
|
|
|
Result := True;
|
|
end;
|
|
|
|
function TIFPSExec.SetVariantValue(dest, Src: PIfVariant): Boolean;
|
|
begin
|
|
Result := True;
|
|
case dest^.FType^.BaseType of
|
|
btU8: dest^.tu8 := GetUInt(Src, Result);
|
|
btS8: dest^.tS8 := GetInt(Src, Result);
|
|
btU16: dest^.tu16 := GetUInt(Src, Result);
|
|
btS16: dest^.ts16 := GetInt(Src, Result);
|
|
btU32, btProcPtr: dest^.tu32 := GetUInt(Src, Result);
|
|
btS32: dest^.ts32 := GetInt(Src, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: dest^.ts64 := GetInt64(Src, Result);
|
|
{$ENDIF}
|
|
btSingle: dest^.tsingle := GetReal(Src, Result);
|
|
btDouble: dest^.tdouble := GetReal(Src, Result);
|
|
btExtended: dest^.textended := GetReal(Src, Result);
|
|
btPChar,btString: TbtString((@dest^.tstring)^) := GetString(Src, Result);
|
|
btChar: dest^.tchar := chr(GetUInt(Src, Result));
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWideChar: dest^.twidechar := widechar(GetUInt(Src, Result));
|
|
btWideString: tbtWideString(dest^.twidestring) := GetWideString(Src, Result);
|
|
{$ENDIF}
|
|
btArray, btRecord: Result := BuildArray(Dest, Src);
|
|
btVariant:
|
|
begin
|
|
if Src^.FType^.BaseType = btVariant then
|
|
ChangeVariantType({$IFNDEF NOSMARTMM}mm, {$ENDIF}Dest^.tVariant, src^.TVariant^.FType)
|
|
else
|
|
ChangeVariantType({$IFNDEF NOSMARTMM}mm, {$ENDIF}Dest^.tVariant, src^.FType);
|
|
if Dest^.tvariant = nil then
|
|
begin
|
|
Result := False;
|
|
end else begin
|
|
if Dest^.TVariant^.FType <> nil then
|
|
begin
|
|
if Src^.FType^.BaseType = btVariant then
|
|
Result := SetVariantValue(Dest^.TVariant, Src^.tvariant)
|
|
else
|
|
Result := SetVariantValue(Dest^.TVariant, Src);
|
|
end;
|
|
end;
|
|
end;
|
|
btResourcePointer:
|
|
begin
|
|
if src^.Ftype^.BaseType = btvariant then
|
|
begin
|
|
Src := src^.tvariant;
|
|
if src^.FType = nil then
|
|
begin
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
end;
|
|
if (Src^.FType^.BaseType <> btResourcePointer) or (Dest^.FType^.BaseType <> btResourcePointer) then
|
|
begin
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
if @Dest^.tResourceFreeProc <> nil then
|
|
begin
|
|
Dest^.tResourceFreeProc(vrfFree, dest, nil);
|
|
end;
|
|
if @Src^.tResourceFreeProc <> nil then
|
|
begin
|
|
Result := Src^.tResourceFreeProc(vrfDuplicate, Src, Dest);
|
|
end else begin
|
|
Dest^.TResourceFreeProc := nil;
|
|
Dest^.TResourceP1 := nil;
|
|
Dest^.TResourceP2 := nil;
|
|
end;
|
|
end;
|
|
else begin
|
|
Result := False;
|
|
end;
|
|
end;
|
|
if Result = False then
|
|
CMD_Err(ErTypeMismatch);
|
|
end;
|
|
|
|
function TIFPSExec.DoBooleanCalc(var1, Var2: PIfVariant; Into: PIfVariant; Cmd:
|
|
Cardinal): Boolean;
|
|
var
|
|
b: Boolean;
|
|
|
|
procedure SetBoolean(b: Boolean; var Ok: Boolean);
|
|
begin
|
|
Ok := True;
|
|
case Into^.FType^.BaseType of
|
|
btU8: Into^.tu8 := Cardinal(b);
|
|
btS8: Into^.tS8 := Longint(b);
|
|
btU16: Into^.tu16 := Cardinal(b);
|
|
btS16: Into^.ts16 := Longint(b);
|
|
btU32: Into^.tu32 := Cardinal(b);
|
|
btS32: Into^.ts32 := Longint(b);
|
|
else begin
|
|
CMD_Err(ErTypeMismatch);
|
|
Ok := False;
|
|
end;
|
|
end;
|
|
end;
|
|
begin
|
|
Result := True;
|
|
if (var1^.FType = nil) and (var1^.FType = nil) then {variants}
|
|
begin
|
|
case Cmd of
|
|
0,1,2,3: Result := False;
|
|
4: SetBoolean(False, Result); { <> }
|
|
5: SetBoolean(True, Result); { = }
|
|
else begin
|
|
Result := False;
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end else
|
|
if (var1^.FType = nil) xor (var2^.FType = nil) then {variants}
|
|
begin
|
|
case Cmd of
|
|
0,1,2,3: Result := False;
|
|
4: SetBoolean(True, Result); { <> }
|
|
5: SetBoolean(False, Result); { = }
|
|
else begin
|
|
Result := False;
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end else
|
|
case Cmd of
|
|
0: begin { >= }
|
|
case var1^.FType^.BaseType of
|
|
btU8:
|
|
if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
|
|
b := char(var1^.tu8) >= GetString(Var2, Result)
|
|
else
|
|
b := var1^.tu8 >= GetUInt(Var2, Result);
|
|
btS8: b := var1^.tS8 >= GetInt(Var2, Result);
|
|
btU16: b := var1^.tu16 >= GetUInt(Var2, Result);
|
|
btS16: b := var1^.ts16 >= GetInt(Var2, Result);
|
|
btU32, btProcPtr: b := var1^.tu32 >= GetUInt(Var2, Result);
|
|
btS32: b := var1^.ts32 >= GetInt(Var2, Result);
|
|
btSingle: b := var1^.tsingle >= GetReal(Var2, Result);
|
|
btDouble: b := var1^.tdouble >= GetReal(Var2, Result);
|
|
btExtended: b := var1^.textended >= GetReal(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: b := var1^.ts64 >= GetInt64(Var2, Result);
|
|
{$ENDIF}
|
|
btPChar,btString: b := tbtstring(var1^.tstring) >= GetString(Var2, Result);
|
|
btChar: b := Var1^.tchar >= GetString(Var2, Result);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWideChar: b := Var1^.twidechar >= GetWideString(Var2, Result);
|
|
btWideString: b := tbtwidestring(Var1^.twidestring) >= GetWideString(Var2, Result);
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(ErTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(ErTypeMismatch);
|
|
exit;
|
|
end;
|
|
SetBoolean(b, Result);
|
|
end;
|
|
1: begin { <= }
|
|
case var1^.FType^.BaseType of
|
|
btU8:
|
|
if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
|
|
b := char(var1^.tu8) <= GetString(Var2, Result)
|
|
else
|
|
b := var1^.tu8 <= GetUInt(Var2, Result);
|
|
btS8: b := var1^.tS8 <= GetInt(Var2, Result);
|
|
btU16: b := var1^.tu16 <= GetUInt(Var2, Result);
|
|
btS16: b := var1^.ts16 <= GetInt(Var2, Result);
|
|
btU32, btProcPtr: b := var1^.tu32 <= GetUInt(Var2, Result);
|
|
btS32: b := var1^.ts32 <= GetInt(Var2, Result);
|
|
btSingle: b := var1^.tsingle <= GetReal(Var2, Result);
|
|
btDouble: b := var1^.tdouble <= GetReal(Var2, Result);
|
|
btExtended: b := var1^.textended <= GetReal(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: b := var1^.ts64 <= GetInt64(Var2, Result);
|
|
{$ENDIF}
|
|
btPChar,btString: b := tbtstring(var1^.tstring) <= GetString(Var2, Result);
|
|
btChar: b := Var1^.tchar <= GetString(Var2, Result);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWideChar: b := Var1^.twidechar <= GetWideString(Var2, Result);
|
|
btWideString: b := tbtwidestring(Var1^.twidestring) <= GetWideString(Var2, Result);
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(ErTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
SetBoolean(b, Result);
|
|
end;
|
|
2: begin { > }
|
|
case var1^.FType^.BaseType of
|
|
btU8:
|
|
if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
|
|
b := char(var1^.tu8) > GetString(Var2, Result)
|
|
else
|
|
b := var1^.tu8 > GetUInt(Var2, Result);
|
|
btS8: b := var1^.tS8 > GetInt(Var2, Result);
|
|
btU16: b := var1^.tu16 > GetUInt(Var2, Result);
|
|
btS16: b := var1^.ts16 > GetInt(Var2, Result);
|
|
btU32, btProcPtr: b := var1^.tu32 > GetUInt(Var2, Result);
|
|
btS32: b := var1^.ts32 > GetInt(Var2, Result);
|
|
btSingle: b := var1^.tsingle > GetReal(Var2, Result);
|
|
btDouble: b := var1^.tdouble > GetReal(Var2, Result);
|
|
btExtended: b := var1^.textended > GetReal(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: b := var1^.ts64 > GetInt64(Var2, Result);
|
|
{$ENDIF}
|
|
btPChar,btString: b := tbtstring(var1^.tstring) > GetString(Var2, Result);
|
|
btChar: b := Var1^.tchar > GetString(Var2, Result);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWideChar: b := Var1^.twidechar > GetWideString(Var2, Result);
|
|
btWideString: b := tbtwidestring(Var1^.twidestring) > GetWideString(Var2, Result);
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
SetBoolean(b, Result);
|
|
end;
|
|
3: begin { < }
|
|
case var1^.FType^.BaseType of
|
|
btU8:
|
|
if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
|
|
b := char(var1^.tu8) < GetString(Var2, Result)
|
|
else
|
|
b := var1^.tu8 < GetUInt(Var2, Result);
|
|
btS8: b := var1^.tS8 < GetInt(Var2, Result);
|
|
btU16: b := var1^.tu16 < GetUInt(Var2, Result);
|
|
btS16: b := var1^.ts16 < GetInt(Var2, Result);
|
|
btU32, btProcPtr: b := var1^.tu32 < GetUInt(Var2, Result);
|
|
btS32: b := var1^.ts32 < GetInt(Var2, Result);
|
|
btSingle: b := var1^.tsingle < GetReal(Var2, Result);
|
|
btDouble: b := var1^.tdouble < GetReal(Var2, Result);
|
|
btExtended: b := var1^.textended < GetReal(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: b := var1^.ts64 < GetInt64(Var2, Result);
|
|
{$ENDIF}
|
|
btPChar,btString: b := tbtstring(var1^.tstring) < GetString(Var2, Result);
|
|
btChar: b := Var1^.tchar < GetString(Var2, Result);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWideChar: b := Var1^.twidechar < GetWideString(Var2, Result);
|
|
btWideString: b := tbtwidestring(Var1^.twidestring) < GetWideString(Var2, Result);
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
SetBoolean(b, Result);
|
|
end;
|
|
4: begin { <> }
|
|
case var1^.FType^.BaseType of
|
|
btU8:
|
|
if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
|
|
b := char(var1^.tu8) <> GetString(Var2, Result)
|
|
else
|
|
b := var1^.tu8 <> GetUInt(Var2, Result);
|
|
btS8: b := var1^.tS8 <> GetInt(Var2, Result);
|
|
btU16: b := var1^.tu16 <> GetUInt(Var2, Result);
|
|
btS16: b := var1^.ts16 <> GetInt(Var2, Result);
|
|
btU32, btProcPtr: b := var1^.tu32 <> GetUInt(Var2, Result);
|
|
btS32: b := var1^.ts32 <> GetInt(Var2, Result);
|
|
btSingle: b := var1^.tsingle <> GetReal(Var2, Result);
|
|
btDouble: b := var1^.tdouble <> GetReal(Var2, Result);
|
|
btExtended: b := var1^.textended <> GetReal(Var2, Result);
|
|
btPChar,btString: b := TbtString(var1^.tstring) <> GetString(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: b := var1^.ts64 <> GetInt64(Var2, Result);
|
|
{$ENDIF}
|
|
btChar: b := Var1^.tchar <> GetString(Var2, Result);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWideChar: b := Var1^.twidechar <> GetWideString(Var2, Result);
|
|
btWideString: b := tbtwidestring(Var1^.twidestring) <> GetWideString(Var2, Result);
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
SetBoolean(b, Result);
|
|
end;
|
|
5: begin { = }
|
|
case var1^.FType^.BaseType of
|
|
btU8:
|
|
if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
|
|
b := char(var1^.tu8) = GetString(Var2, Result)
|
|
else
|
|
b := var1^.tu8 = GetUInt(Var2, Result);
|
|
btS8: b := var1^.tS8 = GetInt(Var2, Result);
|
|
btU16: b := var1^.tu16 = GetUInt(Var2, Result);
|
|
btS16: b := var1^.ts16 = GetInt(Var2, Result);
|
|
btU32, btProcPtr: b := var1^.tu32 = GetUInt(Var2, Result);
|
|
btS32: b := var1^.ts32 = GetInt(Var2, Result);
|
|
btSingle: b := var1^.tsingle = GetReal(Var2, Result);
|
|
btDouble: b := var1^.tdouble = GetReal(Var2, Result);
|
|
btExtended: b := var1^.textended = GetReal(Var2, Result);
|
|
btPchar, btString: b := TbtString(var1^.tstring) = GetString(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: b := var1^.ts64 = GetInt64(Var2, Result);
|
|
{$ENDIF}
|
|
btChar: b := Var1^.tchar = GetString(Var2, Result);
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWideChar: b := Var1^.twidechar = GetWideString(Var2, Result);
|
|
btWideString: b := tbtwidestring(Var1^.twidestring) = GetWideString(Var2, Result);
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
SetBoolean(b, Result);
|
|
end;
|
|
else begin
|
|
Result := False;
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TIFPSExec.DoCalc(var1, Var2: PIfVariant; CalcType: Cardinal): Boolean;
|
|
{ var1=dest, var2=src }
|
|
begin
|
|
try
|
|
Result := True;
|
|
case CalcType of
|
|
0: begin { + }
|
|
case var1^.FType^.BaseType of
|
|
btU8: var1^.tu8 := var1^.tu8 + GetUInt(Var2, Result);
|
|
btS8: var1^.tS8 := var1^.tS8 + GetInt(Var2, Result);
|
|
btU16: var1^.tu16 := var1^.tu16 + GetUInt(Var2, Result);
|
|
btS16: var1^.ts16 := var1^.ts16 + GetInt(Var2, Result);
|
|
btU32: var1^.tu32 := var1^.tu32 + GetUInt(Var2, Result);
|
|
btS32: var1^.ts32 := var1^.ts32 + GetInt(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: var1^.ts64 := var1^.ts64 + GetInt64(var2, Result);
|
|
{$ENDIF}
|
|
btSingle: var1^.tsingle := var1^.tsingle + GetReal(Var2, Result);
|
|
btDouble: var1^.tdouble := var1^.tdouble + GetReal(Var2, Result);
|
|
btExtended: var1^.textended := var1^.textended + GetReal(Var2,
|
|
Result);
|
|
btPchar, btString: TbtString((@var1^.tstring)^) :=
|
|
TbtString((@var1^.tstring)^) + GetString(Var2, Result);
|
|
btChar: Var1^.tchar := char(ord(Var1^.tchar) + GetUInt(Var2, Result));
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWideChar: var1^.twidechar := widechar(ord(var1^.twidechar) + GetUInt(Var2, Result));
|
|
btWideString: tbtwidestring(var1^.twidestring) := tbtwidestring(var1^.twidestring) + GetWideString(Var2, Result);
|
|
{$ENDIF}
|
|
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
1: begin { - }
|
|
case var1^.FType^.BaseType of
|
|
btU8: var1^.tu8 := var1^.tu8 - GetUInt(Var2, Result);
|
|
btS8: var1^.tS8 := var1^.tS8 - GetInt(Var2, Result);
|
|
btU16: var1^.tu16 := var1^.tu16 - GetUInt(Var2, Result);
|
|
btS16: var1^.ts16 := var1^.ts16 - GetInt(Var2, Result);
|
|
btU32: var1^.tu32 := var1^.tu32 - GetUInt(Var2, Result);
|
|
btS32: var1^.ts32 := var1^.ts32 - GetInt(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: var1^.ts64 := var1^.ts64 - GetInt64(var2, Result);
|
|
{$ENDIF}
|
|
btSingle: var1^.tsingle := var1^.tsingle - GetReal(Var2, Result);
|
|
btDouble: var1^.tdouble := var1^.tdouble - GetReal(Var2, Result);
|
|
btExtended: var1^.textended := var1^.textended - GetReal(Var2,
|
|
Result);
|
|
btChar: Var1^.tchar := char(ord(Var1^.tchar) - GetUInt(Var2, Result));
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWideChar: Var1^.twidechar := widechar(ord(Var1^.twidechar) - GetUInt(Var2, Result));
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
2: begin { * }
|
|
case var1^.FType^.BaseType of
|
|
btU8: var1^.tu8 := var1^.tu8 * GetUInt(Var2, Result);
|
|
btS8: var1^.tS8 := var1^.tS8 * GetInt(Var2, Result);
|
|
btU16: var1^.tu16 := var1^.tu16 * GetUInt(Var2, Result);
|
|
btS16: var1^.ts16 := var1^.ts16 * GetInt(Var2, Result);
|
|
btU32: var1^.tu32 := var1^.tu32 * GetUInt(Var2, Result);
|
|
btS32: var1^.ts32 := var1^.ts32 * GetInt(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: var1^.ts64 := var1^.ts64 * GetInt64(var2, Result);
|
|
{$ENDIF}
|
|
btSingle: var1^.tsingle := var1^.tsingle * GetReal(Var2, Result);
|
|
btDouble: var1^.tdouble := var1^.tdouble * GetReal(Var2, Result);
|
|
btExtended: var1^.textended := var1^.textended * GetReal(Var2,
|
|
Result);
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
3: begin { / }
|
|
case var1^.FType^.BaseType of
|
|
btU8: var1^.tu8 := var1^.tu8 div GetUInt(Var2, Result);
|
|
btS8: var1^.tS8 := var1^.tS8 div GetInt(Var2, Result);
|
|
btU16: var1^.tu16 := var1^.tu16 div GetUInt(Var2, Result);
|
|
btS16: var1^.ts16 := var1^.ts16 div GetInt(Var2, Result);
|
|
btU32: var1^.tu32 := var1^.tu32 div GetUInt(Var2, Result);
|
|
btS32: var1^.ts32 := var1^.ts32 div GetInt(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: var1^.ts64 := var1^.ts64 div GetInt64(var2, Result);
|
|
{$ENDIF}
|
|
btSingle: var1^.tsingle := var1^.tsingle / GetReal(Var2, Result);
|
|
btDouble: var1^.tdouble := var1^.tdouble / GetReal(Var2, Result);
|
|
btExtended: var1^.textended := var1^.textended / GetReal(Var2, Result);
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
4: begin { MOD }
|
|
case var1^.FType^.BaseType of
|
|
btU8: var1^.tu8 := var1^.tu8 mod GetUInt(Var2, Result);
|
|
btS8: var1^.tS8 := var1^.tS8 mod GetInt(Var2, Result);
|
|
btU16: var1^.tu16 := var1^.tu16 mod GetUInt(Var2, Result);
|
|
btS16: var1^.ts16 := var1^.ts16 mod GetInt(Var2, Result);
|
|
btU32: var1^.tu32 := var1^.tu32 mod GetUInt(Var2, Result);
|
|
btS32: var1^.ts32 := var1^.ts32 mod GetInt(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: var1^.ts64 := var1^.ts64 mod GetInt64(var2, Result);
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
5: begin { SHL }
|
|
case var1^.FType^.BaseType of
|
|
btU8: var1^.tu8 := var1^.tu8 shl GetUInt(Var2, Result);
|
|
btS8: var1^.tS8 := var1^.tS8 shl GetInt(Var2, Result);
|
|
btU16: var1^.tu16 := var1^.tu16 shl GetUInt(Var2, Result);
|
|
btS16: var1^.ts16 := var1^.ts16 shl GetInt(Var2, Result);
|
|
btU32: var1^.tu32 := var1^.tu32 shl GetUInt(Var2, Result);
|
|
btS32: var1^.ts32 := var1^.ts32 shl GetInt(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: var1^.ts64 := var1^.ts64 shl GetInt64(var2, Result);
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
6: begin { SHR }
|
|
case var1^.FType^.BaseType of
|
|
btU8: var1^.tu8 := var1^.tu8 shr GetUInt(Var2, Result);
|
|
btS8: var1^.tS8 := var1^.tS8 shr GetInt(Var2, Result);
|
|
btU16: var1^.tu16 := var1^.tu16 shr GetUInt(Var2, Result);
|
|
btS16: var1^.ts16 := var1^.ts16 shr GetInt(Var2, Result);
|
|
btU32: var1^.tu32 := var1^.tu32 shr GetUInt(Var2, Result);
|
|
btS32: var1^.ts32 := var1^.ts32 shr GetInt(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: var1^.ts64 := var1^.ts64 shr GetInt64(var2, Result);
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
7: begin { AND }
|
|
case var1^.FType^.BaseType of
|
|
btU8: var1^.tu8 := var1^.tu8 and GetUInt(Var2, Result);
|
|
btS8: var1^.tS8 := var1^.tS8 and GetInt(Var2, Result);
|
|
btU16: var1^.tu16 := var1^.tu16 and GetUInt(Var2, Result);
|
|
btS16: var1^.ts16 := var1^.ts16 and GetInt(Var2, Result);
|
|
btU32: var1^.tu32 := var1^.tu32 and GetUInt(Var2, Result);
|
|
btS32: var1^.ts32 := var1^.ts32 and GetInt(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: var1^.ts64 := var1^.ts64 and GetInt64(var2, Result);
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
8: begin { OR }
|
|
case var1^.FType^.BaseType of
|
|
btU8: var1^.tu8 := var1^.tu8 or GetUInt(Var2, Result);
|
|
btS8: var1^.tS8 := var1^.tS8 or GetInt(Var2, Result);
|
|
btU16: var1^.tu16 := var1^.tu16 or GetUInt(Var2, Result);
|
|
btS16: var1^.ts16 := var1^.ts16 or GetInt(Var2, Result);
|
|
btU32: var1^.tu32 := var1^.tu32 or GetUInt(Var2, Result);
|
|
btS32: var1^.ts32 := var1^.ts32 or GetInt(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: var1^.ts64 := var1^.ts64 or GetInt64(var2, Result);
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
9: begin { XOR }
|
|
case var1^.FType^.BaseType of
|
|
btU8: var1^.tu8 := var1^.tu8 xor GetUInt(Var2, Result);
|
|
btS8: var1^.tS8 := var1^.tS8 xor GetInt(Var2, Result);
|
|
btU16: var1^.tu16 := var1^.tu16 xor GetUInt(Var2, Result);
|
|
btS16: var1^.ts16 := var1^.ts16 xor GetInt(Var2, Result);
|
|
btU32: var1^.tu32 := var1^.tu32 xor GetUInt(Var2, Result);
|
|
btS32: var1^.ts32 := var1^.ts32 xor GetInt(Var2, Result);
|
|
{$IFNDEF NOINT64}
|
|
btS64: var1^.ts64 := var1^.ts64 xor GetInt64(var2, Result);
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
if not Result then begin
|
|
CMD_Err(erTypeMismatch);
|
|
exit;
|
|
end;
|
|
end;
|
|
else begin
|
|
Result := False;
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
exit;
|
|
end;
|
|
end;
|
|
except
|
|
on E: EDivByZero do
|
|
begin
|
|
Result := False;
|
|
CMD_Err(erDivideByZero);
|
|
Exit;
|
|
end;
|
|
on E: EZeroDivide do
|
|
begin
|
|
Result := False;
|
|
CMD_Err(erDivideByZero);
|
|
Exit;
|
|
end;
|
|
on E: EMathError do
|
|
begin
|
|
Result := False;
|
|
CMD_Err(erMathError);
|
|
Exit;
|
|
end;
|
|
on E: Exception do
|
|
begin
|
|
Result := False;
|
|
CMD_Err2(erException, e.Message);
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TIFPSExec.ReadVariable(var NeedToFree: LongBool; UsePointer: LongBool): PIfVariant;
|
|
var
|
|
VarType: Cardinal;
|
|
Param: Cardinal;
|
|
Tmp: PIfVariant;
|
|
|
|
begin
|
|
if not (ReadByte(VarType) and ReadLong(Param)) then begin
|
|
CMD_Err(erOutOfRange);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
case VarType of
|
|
0: begin
|
|
NeedToFree := False;
|
|
if Param < IFPSAddrNegativeStackStart then begin
|
|
Result := FGlobalVars.GetItem(Param);
|
|
if Result = nil then begin
|
|
CMD_Err(erOutOfGlobalVarsRange);
|
|
exit;
|
|
end;
|
|
end
|
|
else begin
|
|
Result := FStack.GetItem(Cardinal(Longint(-IFPSAddrStackStart) +
|
|
Longint(FCurrStackBase) + Longint(Param)));
|
|
if Result = nil then begin
|
|
CMD_Err(erOutOfStackRange);
|
|
exit;
|
|
end;
|
|
end;
|
|
if UsePointer then
|
|
begin
|
|
if Result^.FType^.BaseType = btPointer then begin
|
|
Result := Result^.tPointer;
|
|
if Result = nil then begin
|
|
CMD_Err(erNullPointerException);
|
|
exit;
|
|
end;
|
|
end;
|
|
if Result^.FType^.BaseType = btVariant then begin
|
|
Result := Result^.tvariant;
|
|
if Result = nil then begin
|
|
CMD_Err(erNullPointerException);
|
|
exit;
|
|
end;
|
|
if Result^.FType = nil then
|
|
begin
|
|
Result := nil;
|
|
CMD_Err(erNullVariantError);
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
1: begin
|
|
NeedToFree := True;
|
|
Result := CreateVariant({$IFNDEF NOSMARTMM}MM,
|
|
{$ENDIF}FTypes.GetItem(Param));
|
|
if Result = nil then begin
|
|
CMD_Err(erInvalidType);
|
|
exit;
|
|
end;
|
|
case Result^.FType^.BaseType of
|
|
bts8, btchar, btU8: if not ReadData(Result^.tu8, 1) then begin
|
|
CMD_Err(erOutOfRange);
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
bts16, {$IFNDEF NOWIDESTRING}btwidechar,{$ENDIF} btU16: if not ReadData((@Result^.tu16)^, SizeOf(TbtU16)) then begin
|
|
CMD_Err(ErOutOfRange);
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
bts32, btU32, btProcPtr: if not ReadLong(Result^.tu32) then begin
|
|
CMD_Err(erOutOfRange);
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
{$IFNDEF NOINT64}
|
|
bts64: if not ReadData(Result^.ts64, sizeof(tbts64)) then
|
|
begin
|
|
CMD_Err(erOutOfRange);
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
{$ENDIF}
|
|
btSingle: if not ReadData((@Result^.tsingle)^, SizeOf(TbtSingle))
|
|
then begin
|
|
CMD_Err(erOutOfRange);
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
btDouble: if not ReadData((@Result^.tdouble)^, SizeOf(TbtDouble))
|
|
then begin
|
|
CMD_Err(erOutOfRange);
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
btExtended: if not ReadData((@Result^.textended)^,
|
|
SizeOf(TbtExtended)) then begin
|
|
CMD_Err(erOutOfRange);
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
btPchar, btString: begin
|
|
if not ReadLong(Param) then begin
|
|
CMD_Err(erOutOfRange);
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
SetLength(TbtString((@Result^.tstring)^), Param);
|
|
if not ReadData(TbtString((@Result^.tstring)^)[1], Param) then begin
|
|
CMD_Err(erOutOfRange);
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
end;
|
|
{$IFNDEF NOWIDESTRING}
|
|
btWidestring:
|
|
begin
|
|
if not ReadLong(Param) then begin
|
|
CMD_Err(erOutOfRange);
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
SetLength(TbtwideString(Result^.twidestring), Param);
|
|
if not ReadData(TbtwideString(Result^.twidestring)[1], Param*2) then begin
|
|
CMD_Err(erOutOfRange);
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
else begin
|
|
CMD_Err(erInvalidType);
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
2: begin
|
|
NeedToFree := False;
|
|
if Param < IFPSAddrNegativeStackStart then begin
|
|
Result := FGlobalVars.GetItem(Param);
|
|
if Result = nil then begin
|
|
CMD_Err(erOutOfGlobalVarsRange);
|
|
exit;
|
|
end;
|
|
end
|
|
else begin
|
|
Result := FStack.GetItem(Cardinal(Longint(-IFPSAddrStackStart) +
|
|
Longint(FCurrStackBase) + Longint(Param)));
|
|
if Result = nil then begin
|
|
CMD_Err(erOutOfStackRange);
|
|
exit;
|
|
|
|
end;
|
|
end;
|
|
if (Result^.FType^.BaseType = btPointer) then begin
|
|
Result := Result^.tPointer;
|
|
if Result = nil then begin
|
|
CMD_Err(erNullPointerException);
|
|
exit;
|
|
end;
|
|
end;
|
|
if Result^.FType^.BaseType = btVariant then begin
|
|
Result := Result^.tvariant;
|
|
if Result = nil then begin
|
|
CMD_Err(erNullPointerException);
|
|
exit;
|
|
end;
|
|
if Result^.FType = nil then
|
|
begin
|
|
Result := nil;
|
|
CMD_Err(erNullVariantError);
|
|
Exit;
|
|
end;
|
|
end;
|
|
if (Result^.FType^.BaseType <> btRecord) and (Result^.FType^.BaseType <> btArray) then begin
|
|
CMD_Err(erInvalidType);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
if not ReadLong(Param) then begin
|
|
CMD_Err(erOutOfRange);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
if (Result^.trecord = nil) or (Param >= pbtrecord(Result^.trecord)^.FieldCount) then begin
|
|
CMD_Err(erOutofRecordRange);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
Result := pbtrecord(Result^.trecord)^.Fields[Param];
|
|
if UsePointer then
|
|
begin
|
|
if Result^.FType^.BaseType = btPointer then begin
|
|
Result := Result^.tPointer;
|
|
if Result = nil then begin
|
|
CMD_Err(erNullPointerException);
|
|
exit;
|
|
end;
|
|
end;
|
|
if Result^.FType^.BaseType = btVariant then begin
|
|
Result := Result^.tvariant;
|
|
if Result = nil then begin
|
|
CMD_Err(erNullPointerException);
|
|
exit;
|
|
end;
|
|
if Result^.FType = nil then
|
|
begin
|
|
Result := nil;
|
|
CMD_Err(erNullVariantError);
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
3: begin
|
|
NeedToFree := False;
|
|
if Param < IFPSAddrNegativeStackStart then begin
|
|
Result := FGlobalVars.GetItem(Param);
|
|
if Result = nil then begin
|
|
CMD_Err(erOutOfGlobalVarsRange);
|
|
exit;
|
|
end;
|
|
end
|
|
else begin
|
|
Result := FStack.GetItem(Cardinal(Longint(-IFPSAddrStackStart) +
|
|
Longint(FCurrStackBase) + Longint(Param)));
|
|
if Result = nil then begin
|
|
CMD_Err(erOutOfStackRange);
|
|
exit;
|
|
end;
|
|
end;
|
|
if (Result^.FType^.BaseType = btPointer) then begin
|
|
Result := Result^.tPointer;
|
|
if Result = nil then begin
|
|
CMD_Err(erNullPointerException);
|
|
exit;
|
|
end;
|
|
end;
|
|
if Result^.FType^.BaseType = btVariant then begin
|
|
Result := Result^.tvariant;
|
|
if Result = nil then begin
|
|
CMD_Err(erNullPointerException);
|
|
exit;
|
|
end;
|
|
if Result^.FType = nil then
|
|
begin
|
|
Result := nil;
|
|
CMD_Err(erNullVariantError);
|
|
Exit;
|
|
end;
|
|
end;
|
|
if (Result^.FType^.BaseType <> btRecord) and (Result^.FType^.BaseType <> btArray) then begin
|
|
CMD_Err(erInvalidType);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
if not ReadLong(Param) then begin
|
|
CMD_Err(erOutOfRange);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
if Param < IFPSAddrNegativeStackStart then begin
|
|
Tmp := FGlobalVars.GetItem(Param);
|
|
if Tmp = nil then begin
|
|
CMD_Err(erOutOfGlobalVarsRange);
|
|
exit;
|
|
end;
|
|
end
|
|
else begin
|
|
Tmp := FStack.GetItem(Cardinal(Longint(-IFPSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param)));
|
|
if Tmp = nil then begin
|
|
CMD_Err(erOutOfStackRange);
|
|
exit;
|
|
end;
|
|
end;
|
|
case Tmp^.FType^.BaseType of
|
|
btu8: Param := Tmp^.tu8;
|
|
bts8: Param := Tmp^.ts8;
|
|
btu16: Param := Tmp^.tu16;
|
|
bts16: Param := Tmp^.ts16;
|
|
btu32, btProcPtr: Param := Tmp^.tu32;
|
|
bts32: Param := Tmp^.ts32;
|
|
else
|
|
CMD_Err(ErTypeMismatch);
|
|
exit;
|
|
end;
|
|
|
|
if (Result^.trecord = nil) or (Param >= pbtrecord(Result^.trecord)^.FieldCount) then begin
|
|
CMD_Err(erOutofRecordRange);
|
|
Result := nil;
|
|
exit;
|
|
end;
|
|
Result := pbtrecord(Result^.trecord)^.Fields[Param];
|
|
if UsePointer then
|
|
begin
|
|
if Result^.FType^.BaseType = btPointer then begin
|
|
Result := Result^.tPointer;
|
|
if Result = nil then begin
|
|
CMD_Err(erNullPointerException);
|
|
exit;
|
|
end;
|
|
end;
|
|
if Result^.FType^.BaseType = btVariant then begin
|
|
if Result = nil then begin
|
|
CMD_Err(erNullPointerException);
|
|
exit;
|
|
end;
|
|
if Result^.FType = nil then
|
|
begin
|
|
Result := nil;
|
|
CMD_Err(erNullVariantError);
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
else
|
|
Result := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TIFPSExec.DoMinus(Vd: PIfVariant);
|
|
begin
|
|
case Vd^.FType^.BaseType of
|
|
btU8: Vd^.tu8 := -Vd^.tu8;
|
|
btU16: Vd^.tu16 := -Vd^.tu16;
|
|
btU32: Vd^.tu32 := -Vd^.tu32;
|
|
btS8: Vd^.tS8 := -Vd^.tS8;
|
|
btS16: Vd^.ts16 := -Vd^.ts16;
|
|
btS32: Vd^.ts32 := -Vd^.ts32;
|
|
btSingle: Vd^.tsingle := - vd^.tsingle;
|
|
btDouble: Vd^.tdouble := -vd^.tdouble;
|
|
btExtended: Vd^.textended := -vd^.textended;
|
|
else
|
|
CMD_Err(erTypeMismatch);
|
|
end;
|
|
end;
|
|
|
|
procedure TIFPSExec.DoBooleanNot(Vd: PIfVariant);
|
|
begin
|
|
case Vd^.FType^.BaseType of
|
|
btU8: Vd^.tu8 := TbtU8(Vd^.tu8 = 0);
|
|
btS8: Vd^.tS8 := TbtS8(Vd^.tS8 = 0);
|
|
btU16: Vd^.tu16 := TbtU16(Vd^.tu16 = 0);
|
|
btS16: Vd^.ts16 := TbtS16(Vd^.ts16 = 0);
|
|
btU32: Vd^.tu32 := TbtU32(Vd^.tu32 = 0);
|
|
btS32: Vd^.ts32 := TbtS32(Vd^.ts32 = 0);
|
|
else
|
|
CMD_Err(erTypeMismatch);
|
|
end;
|
|
end;
|
|
|
|
function TIFPSExec.RunScript: Boolean;
|
|
var
|
|
CalcType: Cardinal;
|
|
Vd, Vs, v3: PIfVariant;
|
|
vdFree, vsFree: LongBool;
|
|
p: Cardinal;
|
|
P2: Longint;
|
|
u: PIFProcRec;
|
|
Cmd: Cardinal;
|
|
I: Longint;
|
|
pp: PIFPSExceptionHandler;
|
|
FExitPoint: Cardinal;
|
|
FOldStatus: TIFStatus;
|
|
|
|
begin
|
|
FExitPoint := Cardinal(-1);
|
|
if FStatus = isLoaded then
|
|
begin
|
|
for i := FExceptionStack.Count -1 downto 0 do
|
|
begin
|
|
pp := FExceptionStack.GetItem(i);
|
|
Dispose(pp);
|
|
end;
|
|
FExceptionStack.Clear;
|
|
end;
|
|
ExceptionProc(Cardinal(-1), Cardinal(-1), erNoError, '');
|
|
RunScript := True;
|
|
FOldStatus := FStatus;
|
|
case FStatus of
|
|
isLoaded: begin
|
|
if FMainProc = Cardinal(-1) then
|
|
begin
|
|
RunScript := False;
|
|
exit;
|
|
end;
|
|
FStatus := isRunning;
|
|
FCurrProc := FProcs.GetItem(FMainProc);
|
|
if FCurrProc^.ExternalProc then begin
|
|
CMD_Err(erNoMainProc);
|
|
FStatus := isLoaded;
|
|
exit;
|
|
end;
|
|
FCurrStackBase := Cardinal(-1);
|
|
FCurrentPosition := 0;
|
|
end;
|
|
isPaused: begin
|
|
FStatus := isRunning;
|
|
end;
|
|
else begin
|
|
RunScript := False;
|
|
exit;
|
|
end;
|
|
end;
|
|
RunLine;
|
|
repeat
|
|
FStatus := isRunning;
|
|
while FStatus = isRunning do begin
|
|
if not ReadByte(Cmd) then
|
|
CMD_Err(erOutOfRange) // Error
|
|
else begin
|
|
if Cmd = CM_CA then begin // Calc and assigning are needed most and have priority
|
|
if not ReadByte(CalcType) then begin
|
|
CMD_Err(erOutOfRange);
|
|
break;
|
|
end;
|
|
Vd := ReadVariable(vdFree, True);
|
|
if Vd = nil then
|
|
break;
|
|
if vdFree then begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
break;
|
|
end;
|
|
Vs := ReadVariable(vsFree, True);
|
|
if Vs = nil then
|
|
break;
|
|
if not DoCalc(Vd, Vs, CalcType) then Break;
|
|
if vsFree then
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
|
|
end
|
|
else if Cmd = CM_A then begin // Calc and assigning are needed most and have priority
|
|
Vd := ReadVariable(vdFree, False);
|
|
if Vd = nil then
|
|
break;
|
|
if vdFree then begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
break;
|
|
end;
|
|
if vd^.FType^.BaseType = btPointer then
|
|
begin
|
|
vd := vd^.tPointer;
|
|
if vd = nil then
|
|
begin
|
|
CMD_Err(erNullPointerException);
|
|
Break;
|
|
end;
|
|
end;
|
|
Vs := ReadVariable(vsFree, False);
|
|
if Vs = nil then
|
|
break;
|
|
if vs^.FType^.BaseType = btPointer then begin
|
|
v3 := vs^.tPointer;
|
|
if v3 = nil then begin
|
|
if vsFree then
|
|
begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
|
|
end;
|
|
CMD_Err(erNullPointerException);
|
|
Break;
|
|
end;
|
|
vs := v3;
|
|
end;
|
|
if not SetVariantValue(Vd, Vs) then
|
|
begin
|
|
if vsFree then
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
|
|
cmd_err(erTypeMismatch);
|
|
Break;
|
|
end;
|
|
if vsFree then
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
|
|
end
|
|
else
|
|
case Cmd of
|
|
CM_P: begin
|
|
Vs := ReadVariable(vsFree, True);
|
|
if Vs = nil then
|
|
break;
|
|
if vsFree then begin
|
|
FStack.Add(Vs);
|
|
end
|
|
else begin
|
|
Vd := CreateVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs^.FType);
|
|
SetVariantValue(Vd, Vs);
|
|
FStack.Add(Vd);
|
|
end;
|
|
end;
|
|
CM_PV: begin
|
|
Vs := ReadVariable(vsFree, False);
|
|
if vs^.FType^.BaseType = btPointer then
|
|
begin
|
|
vs := vs^.tPointer;
|
|
if vs = nil then
|
|
begin
|
|
CMD_Err(erNullPointerException);
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
if Vs = nil then
|
|
break;
|
|
if vsFree then begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
break;
|
|
end
|
|
else begin
|
|
Inc(Vs^.RefCount);
|
|
FStack.Add(Vs);
|
|
end;
|
|
end;
|
|
CM_PO: begin
|
|
if FStack.Count = 0 then begin
|
|
CMD_Err(erOutOfStackRange);
|
|
break;
|
|
end;
|
|
Vs := FStack.GetItem(FStack.Count - 1);
|
|
FStack.Delete(FStack.Count - 1);
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
|
|
end;
|
|
Cm_C: begin
|
|
if not ReadLong(p) then begin
|
|
CMD_Err(erOutOfRange);
|
|
break;
|
|
end;
|
|
if p >= FProcs.Count then begin
|
|
CMD_Err(erOutOfProcRange);
|
|
break;
|
|
end;
|
|
u := FProcs.GetItem(p);
|
|
if u^.ExternalProc then begin
|
|
if not u^.ProcPtr(Self, u, FGlobalVars, FStack) then
|
|
begin
|
|
if ExEx = erNoError then
|
|
CMD_Err(erCouldNotCallProc);
|
|
Break;
|
|
end;
|
|
end
|
|
else begin
|
|
Vd := CreateVariant({$IFNDEF NOSMARTMM}MM,
|
|
{$ENDIF}@ReturnAddressType);
|
|
Vd^.treturnaddress.ProcNo := FCurrProc;
|
|
Vd^.treturnaddress.Position := FCurrentPosition;
|
|
Vd^.treturnaddress.StackBase := FCurrStackBase;
|
|
FStack.Add(Vd);
|
|
|
|
FCurrStackBase := FStack.Count - 1;
|
|
FCurrProc := u;
|
|
FCurrentPosition := 0;
|
|
end;
|
|
end;
|
|
Cm_G: begin
|
|
if not ReadLong(p) then begin
|
|
CMD_Err(erOutOfRange);
|
|
break;
|
|
end;
|
|
FCurrentPosition := FCurrentPosition + p;
|
|
end;
|
|
Cm_CG: begin
|
|
if not ReadLong(p) then begin
|
|
CMD_Err(erOutOfRange);
|
|
break;
|
|
end;
|
|
Vs := ReadVariable(vsFree, True);
|
|
if Vs = nil then
|
|
break;
|
|
if vsFree then begin
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
break;
|
|
end;
|
|
case Vs^.FType^.BaseType of
|
|
btU8: vdFree := Vs^.tu8 <> 0;
|
|
btS8: vdFree := Vs^.tS8 <> 0;
|
|
btU16: vdFree := Vs^.tu16 <> 0;
|
|
btS16: vdFree := Vs^.ts16 <> 0;
|
|
btU32, btProcPtr: vdFree := Vs^.tu32 <> 0;
|
|
btS32: vdFree := Vs^.ts32 <> 0;
|
|
else begin
|
|
CMD_Err(erInvalidType);
|
|
break;
|
|
end;
|
|
end;
|
|
if vdFree then
|
|
FCurrentPosition := FCurrentPosition + p;
|
|
end;
|
|
Cm_CNG: begin
|
|
if not ReadLong(p) then begin
|
|
CMD_Err(erOutOfRange);
|
|
break;
|
|
end;
|
|
Vs := ReadVariable(vsFree, True);
|
|
if Vs = nil then
|
|
break;
|
|
if vsFree then begin
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
break;
|
|
end;
|
|
case Vs^.FType^.BaseType of
|
|
btU8: vdFree := Vs^.tu8 = 0;
|
|
btS8: vdFree := Vs^.tS8 = 0;
|
|
btU16: vdFree := Vs^.tu16 = 0;
|
|
btS16: vdFree := Vs^.ts16 = 0;
|
|
btU32, btProcPtr: vdFree := Vs^.tu32 = 0;
|
|
btS32: vdFree := Vs^.ts32 = 0;
|
|
else begin
|
|
CMD_Err(erInvalidType);
|
|
break;
|
|
end;
|
|
end;
|
|
if vdFree then
|
|
FCurrentPosition := FCurrentPosition + p;
|
|
end;
|
|
Cm_R: begin
|
|
FExitPoint := FCurrentPosition -1;
|
|
P2 := 0;
|
|
if FExceptionStack.Count > 0 then
|
|
begin
|
|
pp := FExceptionStack.GetItem(FExceptionStack.Count -1);
|
|
if (pp^.BasePtr = FCurrStackBase) or ((pp^.BasePtr > FCurrStackBase) and (pp^.BasePtr <> Cardinal(-1))) then
|
|
begin
|
|
if pp^.StackSize < FStack.Count then
|
|
begin
|
|
for p := Longint(FStack.count) -1 downto Longint(pp^.StackSize) do
|
|
begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}mm, {$ENDIF}FStack.GetItem(p));
|
|
FStack.Delete(p);
|
|
end;
|
|
end;
|
|
FCurrStackBase := pp^.BasePtr;
|
|
if pp^.FinallyOffset <> Cardinal(-1) then
|
|
begin
|
|
FCurrentPosition := pp^.FinallyOffset;
|
|
pp^.FinallyOffset := cardinal(-1);
|
|
p2 := 1;
|
|
end else if pp^.Finally2Offset <> Cardinal(-1) then
|
|
begin
|
|
FCurrentPosition := pp^.Finally2Offset;
|
|
pp^.Finally2Offset := cardinal(-1);
|
|
p2 := 1;
|
|
end;
|
|
end;
|
|
end;
|
|
if p2 = 0 then
|
|
begin
|
|
FExitPoint := Cardinal(-1);
|
|
Vs := FStack.GetItem(FCurrStackBase);
|
|
if Vs = nil then begin
|
|
FStatus := FOldStatus;
|
|
break;
|
|
end;
|
|
for P2 := FStack.Count - 1 downto FCurrStackBase + 1 do begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM,
|
|
{$ENDIF}FStack.GetItem(P2));
|
|
FStack.Delete(P2);
|
|
end;
|
|
FStack.Delete(FCurrStackBase);
|
|
FCurrProc := Vs^.treturnaddress.ProcNo;
|
|
FCurrentPosition := Vs^.treturnaddress.Position;
|
|
FCurrStackBase := Vs^.treturnaddress.StackBase;
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
|
|
if FCurrProc = nil then begin
|
|
FStatus := FOldStatus;
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
Cm_ST: begin
|
|
if not ReadLong(p) or not ReadLong(Cardinal(P2)) then begin
|
|
CMD_Err(erOutOfRange);
|
|
break;
|
|
end;
|
|
Cardinal(P2) := FCurrStackBase + Cardinal(P2);
|
|
if p >= FTypes.Count then begin
|
|
CMD_Err(erInvalidType);
|
|
break;
|
|
end;
|
|
if Cardinal(P2) >= FStack.Count then begin
|
|
CMD_Err(erOutOfStackRange);
|
|
break;
|
|
end;
|
|
Vs := FStack.GetItem(Cardinal(P2));
|
|
if Vs^.FType = @ReturnAddressType then begin
|
|
CMD_Err(erInvalidType);
|
|
break;
|
|
end;
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
|
|
Vs := CreateVariant({$IFNDEF NOSMARTMM}MM,
|
|
{$ENDIF}FTypes.GetItem(p));
|
|
FStack.SetItem(Cardinal(P2), Vs);
|
|
end;
|
|
Cm_Pt: begin
|
|
if not ReadLong(p) then begin
|
|
CMD_Err(erInvalidType);
|
|
break;
|
|
end;
|
|
Vs := CreateVariant({$IFNDEF NOSMARTMM}MM,
|
|
{$ENDIF}FTypes.GetItem(p));
|
|
if Vs = nil then begin
|
|
CMD_Err(erInvalidType);
|
|
break;
|
|
end;
|
|
FStack.Add(Vs);
|
|
end;
|
|
CM_CO: begin
|
|
if not ReadByte(CalcType) then begin
|
|
CMD_Err(erOutOfRange);
|
|
break;
|
|
end;
|
|
v3 := ReadVariable(vsFree, True);
|
|
if v3 = nil then
|
|
break;
|
|
if vsFree then begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}v3);
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
break;
|
|
end;
|
|
Vs := ReadVariable(vsFree, False);
|
|
if Vs = nil then
|
|
break;
|
|
if vs^.FType^.BaseType = btPointer then begin
|
|
vs := vs^.tPointer;
|
|
if vs = nil then begin
|
|
CMD_Err(erNullPointerException);
|
|
break;
|
|
end;
|
|
end;
|
|
if vs^.FType^.BaseType = btVariant then begin
|
|
vs := vs^.tvariant;
|
|
end;
|
|
Vd := ReadVariable(vdFree, False);
|
|
if vd = nil then
|
|
begin
|
|
if vsFree then
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
|
|
break;
|
|
end;
|
|
if vd^.FType^.BaseType = btPointer then begin
|
|
vd := vd^.tPointer;
|
|
if vd = nil then begin
|
|
CMD_Err(erNullPointerException);
|
|
break;
|
|
end;
|
|
end;
|
|
if vd^.FType^.BaseType = btVariant then begin
|
|
vd := vd^.tvariant;
|
|
end;
|
|
if Vd = nil then begin
|
|
if vsFree then
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
|
|
break;
|
|
end;
|
|
DoBooleanCalc(Vs, Vd, v3, CalcType);
|
|
if vsFree then
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
|
|
if vdFree then
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
|
|
end;
|
|
Cm_cv: begin
|
|
Vd := ReadVariable(vdFree, True);
|
|
if Vd = nil then
|
|
break;
|
|
if (Vd^.FType^.BaseType <> btU32) and (Vd^.FType^.BaseType <>
|
|
btS32) and (vd^.FType^.BaseType <> btProcPtr) then begin
|
|
if vdFree then
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
|
|
CMD_Err(ErTypeMismatch);
|
|
break;
|
|
end;
|
|
p := Vd^.tu32;
|
|
if vdFree then
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
|
|
if (p >= FProcs.Count) or (p = FMainProc) then begin
|
|
CMD_Err(erOutOfProcRange);
|
|
break;
|
|
end;
|
|
u := FProcs.GetItem(p);
|
|
if u^.ExternalProc then begin
|
|
if not u^.ProcPtr(Self, u, FGlobalVars, FStack) then
|
|
CMD_Err(erCouldNotCallProc);
|
|
end
|
|
else begin
|
|
Vs := CreateVariant({$IFNDEF NOSMARTMM}MM,
|
|
{$ENDIF}@ReturnAddressType);
|
|
Vs^.treturnaddress.ProcNo := FCurrProc;
|
|
Vs^.treturnaddress.Position := FCurrentPosition;
|
|
Vs^.treturnaddress.StackBase := FCurrStackBase;
|
|
FStack.Add(Vs);
|
|
FCurrStackBase := FStack.Count - 1;
|
|
FCurrProc := u;
|
|
FCurrentPosition := 0;
|
|
end;
|
|
end;
|
|
cm_sp: begin
|
|
Vd := ReadVariable(vdFree, False);
|
|
if Vd = nil then
|
|
begin
|
|
cmd_err(erInvalidOpcodeParameter);
|
|
break;
|
|
end;
|
|
if vdFree then begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
break;
|
|
end;
|
|
if Vd^.FType^.BaseType <> btPointer then begin
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
break;
|
|
end;
|
|
Vs := ReadVariable(vsFree, False);
|
|
if Vs = nil then begin
|
|
break;
|
|
end else if vsFree then begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
break;
|
|
end else begin
|
|
if (Vd^.tPointer <> nil) then
|
|
begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd^.tPointer);
|
|
vd^.tPointer := nil;
|
|
end;
|
|
if vs^.FType^.BaseType = btPointer then
|
|
begin
|
|
vs := vs^.tPointer;
|
|
end;
|
|
Inc(Vs^.RefCount);
|
|
Vd^.tPointer := Vs;
|
|
end;
|
|
end;
|
|
cm_bn: begin
|
|
Vd := ReadVariable(vdFree, True);
|
|
if Vd = nil then
|
|
break;
|
|
if vdFree then begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
break;
|
|
end;
|
|
DoBooleanNot(Vd);
|
|
end;
|
|
cm_in: begin
|
|
Vd := ReadVariable(vdFree, True);
|
|
if Vd = nil then
|
|
break;
|
|
if vdFree then begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
break;
|
|
end;
|
|
DoIntegerNot(Vd);
|
|
end;
|
|
cm_vm: begin
|
|
Vd := ReadVariable(vdFree, True);
|
|
if Vd = nil then
|
|
break;
|
|
if vdFree then begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
break;
|
|
end;
|
|
DoMinus(Vd);
|
|
end;
|
|
cm_sf:
|
|
begin
|
|
vd := ReadVariable(vdFree, True);
|
|
if vd = nil then
|
|
break;
|
|
if vdFree then
|
|
begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}vd);
|
|
CMD_Err(erInvalidOpcodeParameter);
|
|
break;
|
|
end;
|
|
if not ReadByte(p) then
|
|
begin
|
|
CMD_Err(erOutOfRange);
|
|
Break;
|
|
end;
|
|
case Vd^.FType^.BaseType of
|
|
btU8: vdFree := Vd^.tu8 <> 0;
|
|
btS8: vdFree := Vd^.tS8 <> 0;
|
|
btU16: vdFree := Vd^.tu16 <> 0;
|
|
btS16: vdFree := Vd^.ts16 <> 0;
|
|
btU32, btProcPtr: vdFree := Vd^.tu32 <> 0;
|
|
btS32: vdFree := Vd^.ts32 <> 0;
|
|
else begin
|
|
CMD_Err(erInvalidType);
|
|
break;
|
|
end;
|
|
end;
|
|
if p <> 0 then
|
|
FJumpFlag := not vdFree
|
|
else
|
|
FJumpFlag := vdFree;
|
|
end;
|
|
cm_fg:
|
|
begin
|
|
if not ReadLong(p) then begin
|
|
CMD_Err(erOutOfRange);
|
|
break;
|
|
end;
|
|
if FJumpFlag then
|
|
FCurrentPosition := FCurrentPosition + p;
|
|
end;
|
|
cm_puexh:
|
|
begin
|
|
New(pp);
|
|
pp^.BasePtr :=FCurrStackBase;
|
|
pp^.StackSize := FStack.Count;
|
|
if not ReadLong(pp^.FinallyOffset) then begin
|
|
CMD_Err(erOutOfRange);
|
|
Dispose(pp);
|
|
Break;
|
|
end;
|
|
if not ReadLong(pp^.ExceptOffset) then begin
|
|
CMD_Err(erOutOfRange);
|
|
Dispose(pp);
|
|
Break;
|
|
end;
|
|
if not ReadLong(pp^.Finally2Offset) then begin
|
|
CMD_Err(erOutOfRange);
|
|
Dispose(pp);
|
|
Break;
|
|
end;
|
|
if not ReadLong(pp^.EndOfBlock) then begin
|
|
CMD_Err(erOutOfRange);
|
|
Dispose(pp);
|
|
Break;
|
|
end;
|
|
if pp^.FinallyOffset <> Cardinal(-1) then
|
|
pp^.FinallyOffset := pp^.FinallyOffset + FCurrentPosition;
|
|
if pp^.ExceptOffset <> Cardinal(-1) then
|
|
pp^.ExceptOffset := pp^.ExceptOffset + FCurrentPosition;
|
|
if pp^.Finally2Offset <> Cardinal(-1) then
|
|
pp^.Finally2Offset := pp^.Finally2Offset + FCurrentPosition;
|
|
if pp^.EndOfBlock <> Cardinal(-1) then
|
|
pp^.EndOfBlock := pp^.EndOfBlock + FCurrentPosition;
|
|
if ((pp^.FinallyOffset <> cardinal(-1)) and (pp^.FinallyOffset >= FCurrProc^.Length)) or
|
|
((pp^.ExceptOffset <> cardinal(-1)) and (pp^.ExceptOffset >= FCurrProc^.Length)) or
|
|
((pp^.Finally2Offset <> cardinal(-1)) and (pp^.Finally2Offset >= FCurrProc^.Length)) or
|
|
((pp^.EndOfBlock <> cardinal(-1)) and (pp^.EndOfBlock >= FCurrProc^.Length)) then
|
|
begin
|
|
CMD_Err(ErOutOfRange);
|
|
Dispose(pp);
|
|
Break;
|
|
end;
|
|
FExceptionStack.Add(pp);
|
|
end;
|
|
cm_poexh:
|
|
begin
|
|
if not ReadByte(p) then
|
|
begin
|
|
CMD_Err(ErOutOfRange);
|
|
Break;
|
|
end;
|
|
case p of
|
|
2:
|
|
begin
|
|
ExceptionProc(Cardinal(-1), Cardinal(-1), erNoError, '');
|
|
pp := FExceptionStack.GetItem(FExceptionStack.Count -1);
|
|
if pp = nil then begin
|
|
cmd_err(ErOutOfRange);
|
|
Break;
|
|
end;
|
|
if pp^.Finally2Offset <> cardinal(-1) then
|
|
begin
|
|
FCurrentPosition := pp^.Finally2Offset;
|
|
pp^.Finally2Offset := cardinal(-1);
|
|
end else begin
|
|
p := pp^.EndOfBlock;
|
|
Dispose(pp);
|
|
FExceptionStack.Delete(FExceptionStack.Count -1);
|
|
if FExitPoint <> Cardinal(-1) then
|
|
begin
|
|
FCurrentPosition := FExitPoint;
|
|
end else begin
|
|
FCurrentPosition := p;
|
|
end;
|
|
end;
|
|
end;
|
|
0:
|
|
begin
|
|
pp := FExceptionStack.GetItem(FExceptionStack.Count -1);
|
|
if pp = nil then begin
|
|
cmd_err(ErOutOfRange);
|
|
Break;
|
|
end;
|
|
if pp^.FinallyOffset <> cardinal(-1) then
|
|
begin
|
|
FCurrentPosition := pp^.FinallyOffset;
|
|
pp^.FinallyOffset := cardinal(-1);
|
|
end else if pp^.Finally2Offset <> cardinal(-1) then
|
|
begin
|
|
FCurrentPosition := pp^.Finally2Offset;
|
|
pp^.ExceptOffset := cardinal(-1);
|
|
end else begin
|
|
p := pp^.EndOfBlock;
|
|
Dispose(pp);
|
|
FExceptionStack.Delete(FExceptionStack.Count -1);
|
|
if ExEx <> eNoError then
|
|
begin
|
|
ExceptionProc(ExProc, ExPos, ExEx, ExParam);
|
|
end else
|
|
if FExitPoint <> Cardinal(-1) then
|
|
begin
|
|
FCurrentPosition := FExitPoint;
|
|
end else begin
|
|
FCurrentPosition := p;
|
|
end;
|
|
end;
|
|
end;
|
|
1:
|
|
begin
|
|
pp := FExceptionStack.GetItem(FExceptionStack.Count -1);
|
|
if pp = nil then begin
|
|
cmd_err(ErOutOfRange);
|
|
Break;
|
|
end;
|
|
if (ExEx <> ENoError) and (pp^.ExceptOffset <> cardinal(-1)) then
|
|
begin
|
|
FCurrentPosition := pp^.ExceptOffset;
|
|
pp^.ExceptOffset := cardinal(-1);
|
|
end else if (pp^.Finally2Offset <> cardinal(-1)) then
|
|
begin
|
|
FCurrentPosition := pp^.Finally2Offset;
|
|
pp^.Finally2Offset := cardinal(-1);
|
|
end else begin
|
|
p := pp^.EndOfBlock;
|
|
Dispose(pp);
|
|
FExceptionStack.Delete(FExceptionStack.Count -1);
|
|
if ExEx <> eNoError then
|
|
begin
|
|
ExceptionProc(ExProc, ExPos, ExEx, ExParam);
|
|
end else
|
|
if FExitPoint <> Cardinal(-1) then
|
|
begin
|
|
FCurrentPosition := FExitPoint;
|
|
end else begin
|
|
FCurrentPosition := p;
|
|
end;
|
|
end;
|
|
end;
|
|
3:
|
|
begin
|
|
pp := FExceptionStack.GetItem(FExceptionStack.Count -1);
|
|
if pp = nil then begin
|
|
cmd_err(ErOutOfRange);
|
|
Break;
|
|
end;
|
|
p := pp^.EndOfBlock;
|
|
Dispose(pp);
|
|
FExceptionStack.Delete(FExceptionStack.Count -1);
|
|
if ExEx <> eNoError then
|
|
begin
|
|
ExceptionProc(ExProc, ExPos, ExEx, ExParam);
|
|
end else
|
|
if FExitPoint <> Cardinal(-1) then
|
|
begin
|
|
FCurrentPosition := FExitPoint;
|
|
end else begin
|
|
FCurrentPosition := p;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
else
|
|
CMD_Err(erInvalidOpcode); // Error
|
|
end;
|
|
RunLine;
|
|
end;
|
|
end;
|
|
if ExEx <> erNoError then FStatus := FOldStatus;
|
|
until (FExceptionStack.Count = 0) or (Fstatus <> IsRunning);
|
|
if FStatus = isLoaded then begin
|
|
for I := 0 to Longint(FStack.Count) - 1 do begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FStack.GetItem(I));
|
|
end;
|
|
FStack.Clear;
|
|
if FCallCleanup then Cleanup;
|
|
end;
|
|
Result := ExEx = erNoError;
|
|
end;
|
|
|
|
procedure TIFPSExec.Stop;
|
|
var
|
|
I: Longint;
|
|
begin
|
|
if FStatus = isRunning then
|
|
FStatus := isLoaded
|
|
else if FStatus = isPaused then begin
|
|
FStatus := isLoaded;
|
|
for I := 0 to Longint(FStack.Count) - 1 do begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FStack.GetItem(I));
|
|
end;
|
|
FStack.Clear;
|
|
end;
|
|
end;
|
|
|
|
function TIFPSExec.ReadByte(var b: Cardinal): Boolean;
|
|
begin
|
|
if FCurrentPosition < FCurrProc.Length then begin
|
|
b := FCurrProc.Data^[FCurrentPosition];
|
|
Inc(FCurrentPosition);
|
|
Result := True;
|
|
end
|
|
else
|
|
Result := False;
|
|
end;
|
|
|
|
function TIFPSExec.ReadLong(var b: Cardinal): Boolean;
|
|
begin
|
|
if FCurrentPosition + 3 < FCurrProc.Length then begin
|
|
b := Cardinal((@FCurrProc.Data^[FCurrentPosition])^);
|
|
Inc(FCurrentPosition, 4);
|
|
Result := True;
|
|
end
|
|
else
|
|
Result := False;
|
|
end;
|
|
|
|
function TIFPSExec.RunProc(Params: TIfList; ProcNo: Cardinal): Boolean;
|
|
var
|
|
I, I2: Integer;
|
|
Vd: PIfVariant;
|
|
Cp: PIFProcRec;
|
|
oldStatus: TIFStatus;
|
|
begin
|
|
if FStatus <> isNotLoaded then begin
|
|
if ProcNo >= FProcs.Count then begin
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
if PIFProcRec(FProcs.GetItem(ProcNo))^.ExternalProc then begin
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
for I := 0 to Params.Count - 1 do begin
|
|
vd := Params.GetItem(I);
|
|
if vd = nil then
|
|
begin
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
FStack.Add(Params.GetItem(I));
|
|
end;
|
|
Vd := CreateVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}@ReturnAddressType);
|
|
Cp := FCurrProc;
|
|
Vd^.treturnaddress.ProcNo := nil;
|
|
Vd^.treturnaddress.Position := FCurrentPosition;
|
|
Vd^.treturnaddress.StackBase := FCurrStackBase;
|
|
I := FStack.Count;
|
|
FStack.Add(Vd);
|
|
FCurrStackBase := FStack.Count - 1;
|
|
FCurrProc := FProcs.GetItem(ProcNo);
|
|
FCurrentPosition := 0;
|
|
oldStatus := FStatus;
|
|
FStatus := isPaused;
|
|
Result := RunScript;
|
|
if FStack.Count > Cardinal(I) then
|
|
begin
|
|
vd := FStack.GetItem(I);
|
|
if (vd <> nil) and (vd^.FType = @ReturnAddressType) then begin
|
|
for i2 := FStack.Count - 1 downto I + 1 do begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FStack.GetItem(i2));
|
|
FStack.Delete(i2);
|
|
end;
|
|
FStack.Delete(I);
|
|
FCurrentPosition := Vd^.treturnaddress.Position;
|
|
FCurrStackBase := Vd^.treturnaddress.StackBase;
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
|
|
end;
|
|
end;
|
|
for I := Params.Count - 1 downto 0 do begin
|
|
FStack.Delete(FStack.Count - 1);
|
|
end;
|
|
FStatus := oldStatus;
|
|
FCurrProc := Cp;
|
|
end else begin
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
function TIFPSExec.CreateIntegerVariant(FType: PIFTypeRec; Value: Longint): PIfVariant;
|
|
begin
|
|
Result := CreateVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FType);
|
|
if Result <> nil then begin
|
|
case FType^.BaseType of
|
|
btU8: Result^.tu8 := Value;
|
|
btS8: Result^.tS8 := Value;
|
|
btU16: Result^.tu16 := Value;
|
|
btS16: Result^.ts16 := Value;
|
|
btU32, btProcPtr: Result^.tu32 := Value;
|
|
btS32: Result^.ts32 := Value;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TIFPSExec.CreateStringVariant(FType: PIFTypeRec; const Value: string): PIfVariant;
|
|
begin
|
|
Result := CreateVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FType);
|
|
if Result <> nil then begin
|
|
case FType^.BaseType of
|
|
btPChar, btString: begin
|
|
TbtString(Result^.tstring) := Value;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TIFPSExec.CreateFloatVariant(FType: PIFTypeRec; Value: Extended): PIfVariant;
|
|
begin
|
|
Result := CreateVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FType);
|
|
if Result <> nil then begin
|
|
case FType^.BaseType of
|
|
btSingle: Result^.tsingle := Value;
|
|
btDouble: Result^.tdouble := Value;
|
|
btExtended: Result^.textended := Value;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TIFPSExec.FindType2(BaseType: TIFPSBaseType): PIFTypeRec;
|
|
var
|
|
l: Cardinal;
|
|
begin
|
|
FindType2 := FindType(0, BaseType, l);
|
|
|
|
end;
|
|
|
|
function TIFPSExec.FindType(StartAt: Cardinal; BaseType: TIFPSBaseType; var l: Cardinal): PIFTypeRec;
|
|
var
|
|
I: Integer;
|
|
n: PIFTypeRec;
|
|
begin
|
|
for I := StartAt to FTypes.Count - 1 do begin
|
|
n := FTypes.GetItem(I);
|
|
if n^.BaseType = BaseType then begin
|
|
l := I;
|
|
Result := n;
|
|
exit;
|
|
end;
|
|
end;
|
|
Result := nil;
|
|
end;
|
|
|
|
function TIFPSExec.GetTypeNo(l: Cardinal): PIFTypeRec;
|
|
begin
|
|
Result := FTypes.GetItem(l);
|
|
end;
|
|
|
|
function TIFPSExec.GetProc(const Name: string): Cardinal;
|
|
var
|
|
MM,
|
|
I: Longint;
|
|
n: PIFProcRec;
|
|
begin
|
|
MM := MakeHash(Name);
|
|
for I := 0 to FProcs.Count - 1 do begin
|
|
n := FProcs.GetItem(I);
|
|
if (not n^.ExternalProc) and (Length(n^.ExportName) <> 0) and (n^.ExportNameHash = MM) and (n^.ExportName = Name) then begin
|
|
Result := I;
|
|
exit;
|
|
end;
|
|
end;
|
|
Result := Cardinal(-1);
|
|
end;
|
|
|
|
function TIFPSExec.GetType(const Name: string): Cardinal;
|
|
var
|
|
MM,
|
|
I: Longint;
|
|
n: PIFTypeRec;
|
|
begin
|
|
MM := MakeHash(Name);
|
|
for I := 0 to FTypes.Count - 1 do begin
|
|
n := FTypes.GetItem(I);
|
|
if (Length(n^.ExportName) <> 0) and (n^.ExportNameHash = MM) and (n^.ExportName = Name) then begin
|
|
Result := I;
|
|
exit;
|
|
end;
|
|
end;
|
|
Result := Cardinal(-1);
|
|
end;
|
|
|
|
|
|
procedure TIFPSExec.AddResource(Proc, P: Pointer);
|
|
var
|
|
Temp: PIFPSResource;
|
|
begin
|
|
New(Temp);
|
|
Temp^.Proc := Proc;
|
|
Temp^.P := p;
|
|
FResources.Add(temp);
|
|
end;
|
|
|
|
procedure TIFPSExec.DeleteResource(P: Pointer);
|
|
var
|
|
i: Longint;
|
|
begin
|
|
for i := Longint(FResources.Count) -1 downto 0 do
|
|
begin
|
|
if PIFPSResource(FResources.GetItem(I))^.P = P then
|
|
begin
|
|
FResources.Delete(I);
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TIFPSExec.FindProcResource(Proc: Pointer): Pointer;
|
|
var
|
|
I: Longint;
|
|
temp: PIFPSResource;
|
|
begin
|
|
for i := Longint(FResources.Count) -1 downto 0 do
|
|
begin
|
|
temp := FResources.GetItem(I);
|
|
if temp^.Proc = proc then
|
|
begin
|
|
Result := Temp^.P;
|
|
exit;
|
|
end;
|
|
end;
|
|
Result := nil;
|
|
end;
|
|
|
|
function TIFPSExec.IsValidResource(Proc, P: Pointer): Boolean;
|
|
var
|
|
i: Longint;
|
|
temp: PIFPSResource;
|
|
begin
|
|
for i := 0 to Longint(FResources.Count) -1 do
|
|
begin
|
|
temp := FResources.GetItem(i);
|
|
if temp^.p = p then begin
|
|
result := temp^.Proc = Proc;
|
|
exit;
|
|
end;
|
|
end;
|
|
result := false;
|
|
end;
|
|
|
|
function TIFPSExec.FindProcResource2(Proc: Pointer;
|
|
var StartAt: Longint): Pointer;
|
|
var
|
|
I: Longint;
|
|
temp: PIFPSResource;
|
|
begin
|
|
if StartAt > longint(FResources.Count) -1 then
|
|
StartAt := longint(FResources.Count) -1;
|
|
for i := StartAt downto 0 do
|
|
begin
|
|
temp := FResources.GetItem(I);
|
|
if temp^.Proc = proc then
|
|
begin
|
|
Result := Temp^.P;
|
|
StartAt := i -1;
|
|
exit;
|
|
end;
|
|
end;
|
|
StartAt := -1;
|
|
Result := nil;
|
|
end;
|
|
|
|
procedure TIFPSExec.RunLine;
|
|
begin
|
|
if @FOnRunLine <> nil then
|
|
FOnRunLine(Self);
|
|
end;
|
|
|
|
procedure TIFPSExec.CMD_Err2(EC: TIFError; const Param: string);
|
|
var
|
|
l: Longint;
|
|
C: Cardinal;
|
|
begin
|
|
C := Cardinal(-1);
|
|
for l := 0 to FProcs.Count - 1 do begin
|
|
if FProcs.GetItem(l) = FCurrProc then begin
|
|
C := l;
|
|
break;
|
|
end;
|
|
end;
|
|
ExceptionProc(C, FCurrentPosition, EC, Param);
|
|
end;
|
|
|
|
procedure FreePIFVariantList({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}List: TIfList);
|
|
var
|
|
I: Longint;
|
|
begin
|
|
for I := List.Count -1 downto 0 do
|
|
begin
|
|
DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}List.GetItem(I));
|
|
end;
|
|
List.Free;
|
|
end;
|
|
procedure TIFPSExec.AddSpecialProcImport(const FName: string;
|
|
P: TIFPSOnSpecialProcImport; Tag: Pointer);
|
|
var
|
|
N: PSpecialProc;
|
|
begin
|
|
New(n);
|
|
n^.P := P;
|
|
N^.Name := FName;
|
|
n^.namehash := MakeHash(FName);
|
|
n^.Tag := Tag;
|
|
FSpecialProcList.Add(n);
|
|
end;
|
|
|
|
function TIFPSExec.GetVar(const Name: string): Cardinal;
|
|
var
|
|
l: Longint;
|
|
h: longint;
|
|
begin
|
|
h := makehash(Name);
|
|
for l := FExportedVars.Count - 1 downto 0 do
|
|
begin
|
|
if (PIFPSExportedVar(FexportedVars.GetItem(L))^.FNameHash = h) and(PIFPSExportedVar(FexportedVars.GetItem(L))^.FName=Name) then
|
|
begin
|
|
Result := L;
|
|
exit;
|
|
end;
|
|
end;
|
|
Result := Cardinal(-1);
|
|
end;
|
|
|
|
function TIFPSExec.GetVarNo(C: Cardinal): PIFVariant;
|
|
begin
|
|
Result := FGlobalVars.GetItem(c);
|
|
end;
|
|
|
|
function TIFPSExec.GetVar2(const Name: string): PIFVariant;
|
|
begin
|
|
Result := GetVarNo(GetVar(Name));
|
|
end;
|
|
|
|
function TIFPSExec.GetProcNo(C: Cardinal): PIFProcRec;
|
|
begin
|
|
Result := FProcs.GetItem(c);
|
|
end;
|
|
|
|
procedure TIFPSExec.DoIntegerNot(Vd: PIfVariant);
|
|
begin
|
|
case Vd^.FType^.BaseType of
|
|
btU8: Vd^.tu8 := not Vd^.tu8;
|
|
btS8: Vd^.tS8 := not Vd^.tS8;
|
|
btU16: Vd^.tu16 := not Vd^.tu16;
|
|
btS16: Vd^.ts16 := not Vd^.ts16;
|
|
btU32: Vd^.tu32 := not Vd^.tu32;
|
|
btS32: Vd^.ts32 := not Vd^.ts32;
|
|
{$IFNDEF NOINT64} btS64: vd^.ts64 := not vd^.ts64; {$ENDIF}
|
|
else
|
|
CMD_Err(erTypeMismatch);
|
|
end;
|
|
end;
|
|
end.
|
|
|