home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d456 / CAJSCRPT.ZIP / ifps3 / ifps3.pas < prev    next >
Pascal/Delphi Source File  |  2002-07-20  |  130KB  |  4,102 lines
  1. {
  2.   The execute part of the script engine
  3. }
  4. unit ifps3;
  5. {$I ifps3_def.inc}
  6. {
  7.  
  8. Innerfuse Pascal Script III
  9. Copyright (C) 2000-2002 by Carlo Kok (ck@carlo-kok.com)
  10.  
  11. }
  12. interface
  13. uses
  14.   SysUtils, ifps3utl, ifps3common;
  15.  
  16. type
  17.   TIFPSExec = class;
  18. { TIFError contains all possible errors }
  19.   TIFError = (ErNoError, erCannotImport, erInvalidType, ErInternalError,
  20.     erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc,
  21.     erOutOfGlobalVarsRange, erOutOfProcRange, ErOutOfRange, erOutOfStackRange,
  22.     ErTypeMismatch, erUnexpectedEof, erVersionError, ErDivideByZero, ErMathError,
  23.     erCouldNotCallProc, erOutofRecordRange, erOutOfMemory, erException,
  24.     erNullPointerException, erNullVariantError, erCustomError);
  25. { The current status of the script }
  26.   TIFStatus = (isNotLoaded, isLoaded, isRunning, isPaused);
  27. {Pointer to array of bytes}
  28.   PByteArray = ^TByteArray;
  29. {Array of bytes}
  30.   TByteArray = array[0..1023] of Byte;
  31. {Pointer to array of words}
  32.   PDWordArray = ^TDWordArray;
  33. {Array of dwords}
  34.   TDWordArray = array[0..1023] of Cardinal;
  35. { Pointer to @link(TIFTypeRec)}
  36.   PIFTypeRec = ^TIFTypeRec;
  37. {TIFTypeRec is used to store all types inside the script}
  38.   TIFTypeRec = record
  39.     {Ext is used in a typecopy or array to store more information}
  40.     Ext: Pointer;
  41.     BaseType: TIFPSBaseType;
  42.     ExportName: string;
  43.     ExportNameHash: Longint;
  44.   end;
  45. {TIFArrayType is a pointer to an other type}
  46.   TIFArrayType = PIFTypeRec;
  47. {PIFRecordType is a pointer to record information}
  48.   PIFRecordType = ^TIFRecordType;
  49. {TIFRecordType is used to store information about records}
  50.   TIFRecordType = record
  51.     Data: string;
  52.   end;
  53. {@link(TProcRec)
  54.   PProcRec is pointer to a TProcRec record}
  55.   PProcRec = ^TProcRec;
  56. {@link(TIFProcRec)
  57.   PIFProcRec is a pointer to a TIProcRec record}
  58.   PIFProcRec = ^TIFProcRec;
  59. {
  60. @link(TIFPSExec)
  61. @link(PIFProcRec)
  62. @link(TIfList)
  63. TIFProc is is the procedure definition of all external functions
  64. }
  65.   TIFProc = function(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
  66. {
  67. @link(PProcRec)
  68. FreeProc is called when a PProcRec is freed}
  69.   TIFFreeProc = procedure (Caller: TIFPSExec; p: PProcRec);
  70. {TIFProcRec contains a currently used internal or external function}
  71.   TIFProcRec = record
  72.     {True means the procedure is external}
  73.     ExternalProc: Boolean;
  74.     {The exportname/decl used to identify the procedure}
  75.     ExportName, ExportDecl: string;
  76.     {ExportNameHash is used to quickly find an ExportName}
  77.     ExportNameHash: Longint;
  78.     case Boolean of
  79.       False: (Data: PByteArray; Length: Cardinal);
  80.       True: (ProcPtr: TIFProc; Name: ShortString; Ext1, Ext2: Pointer);
  81.       // ExportDecl will contain Params in case of importing with Flags := 3;
  82.   end;
  83. {TProcrec is used to store an external function that could be used by the script executer}
  84.   TProcRec = record
  85.     Name: ShortString;
  86.     Hash: Longint;
  87.     ProcPtr: TIFProc;
  88.     FreeProc: TIFFreeProc;
  89.     Ext1, Ext2: Pointer;
  90.   end;
  91. {@link(TBTReturnAddress)
  92.   PBTReturnAddress is a pointer to an TBTReturnAddress record}
  93.   PBTReturnAddress = ^TBTReturnAddress;
  94. {TBTReturnAddress is a record used to store return information}
  95.   TBTReturnAddress = record
  96.     ProcNo: PIFProcRec;
  97.     Position, StackBase: Cardinal;
  98.   end;
  99. {@link(PIFVariant)
  100. PPIFVariant is a pointer to a PIFVariant}
  101.   PPIFVariant = ^PIfVariant;
  102. {@link(TIFVariant)
  103. PIFVariant is a pointer to a TIFVariant}
  104.   PIFVariant = ^TIfVariant;
  105. {@link(TVariantResourceFreeProc)
  106.   TVRMode is used to when the scriptengine needs to free or duplicate a resourcepointer}
  107.   TVRFMode = (vrfFree, vrfDuplicate);
  108. {@link(TVRMode)
  109.   TVariantResourceFreeProc is used when the scriptengine needs to free or duplicate a resourcepointer}
  110.   TVariantResourceFreeProc = function (FMode: TVRFMode; P, IntoP: PIFVariant): Boolean;
  111.   {PBTRecord is a pointer to a @link(TbtRecord) record}
  112.   pbtrecord = ^TbtRecord;
  113. {TIFvariant is variant used for storing all variables used by the script}
  114.   TIFVariant = packed record
  115.     {The type of the variant}
  116.     FType: PIFTypeRec;
  117.     {The number of pointers referencing this variant}
  118.     RefCount: Cardinal; // 0 = Freeable
  119.     case Byte of
  120.       1: (tu8: TbtU8);
  121.       2: (tS8: TbtS8);
  122.       3: (tu16: TbtU16);
  123.       4: (ts16: TbtS16);
  124.       5: (tu32: TbtU32);
  125.       6: (ts32: TbtS32);
  126.       7: (tsingle: TbtSingle);
  127.       8: (tdouble: TbtDouble);
  128.       9: (textended: TbtExtended);
  129.       10: (tstring: Pointer);
  130.       11: (treturnaddress: TBTReturnAddress);
  131.       12: (trecord: pbtrecord);
  132.       13: (tArray: pbtrecord);
  133.       14: (tPointer: PIfVariant);
  134.       15: (tResourceP1, tResourceP2: Pointer; tResourceFreeProc: TVariantResourceFreeProc);
  135.       16: (tvariant: PIFVariant);
  136.       {$IFNDEF NOINT64}
  137.       17: (ts64: Tbts64);
  138.       {$ENDIF}
  139.   end;
  140.   {TbtRecord is used to store the fields in a record or array}
  141.   TbtRecord = packed record
  142.     FieldCount: Cardinal;
  143.     Fields: array[0..10000] of PIfVariant;
  144.   end;
  145.   {TIFPSResourceFreeProc is called when a resource needs to be freed}
  146.   TIFPSResourceFreeProc = procedure (Sender: TIFPSExec; P: Pointer);
  147.   {@link(TIFPSResource)
  148.     PIFPSResource is a pointer to a TIFPSResource record
  149.   }
  150.   PIFPSResource = ^TIFPSResource;
  151.   { A resource in IFPS3 is stored as a pointer to the proc and a tag (p) }
  152.   TIFPSResource = record
  153.     Proc: Pointer;
  154.     P: Pointer;
  155.   end;
  156.   {@link(pbtrecord)
  157.     PBTRecord}
  158.   PBTArray = pbtrecord;
  159.   {@link(TbtRecord)
  160.   tbtrecord}
  161.   TBTArray = TbtRecord;
  162.   {See TIFPSExec.OnRunLine}
  163.   TIFPSOnLineEvent = procedure(Sender: TIFPSExec);
  164.   {See TIFPSExec.AddSpecialProcImport}
  165.   TIFPSOnSpecialProcImport = function (Sender: TIFPSExec; p: PIFProcRec; Tag: Pointer): Boolean;
  166.   {TIFPSExec is the core of the script engine executer}
  167.   TIFPSExec = class(TObject)
  168.   Private
  169.     FId: Pointer;
  170.     FJumpFlag: Boolean;
  171.     FCallCleanup: Boolean;
  172.     function ReadData(var Data; Len: Cardinal): Boolean;
  173.     function ReadByte(var b: Cardinal): Boolean;
  174.     function ReadLong(var b: Cardinal): Boolean;
  175.     function DoCalc(var1, Var2: PIfVariant; CalcType: Cardinal): Boolean;
  176.     function DoBooleanCalc(var1, Var2: PIfVariant; Into: PIfVariant; Cmd: Cardinal): Boolean;
  177.     function SetVariantValue(dest, Src: PIfVariant): Boolean;
  178.     function ReadVariable(var NeedToFree: LongBool; UsePointer: LongBool): PIfVariant;
  179.     procedure DoBooleanNot(Vd: PIfVariant);
  180.     procedure DoMinus(Vd: PIfVariant);
  181.     function BuildArray(Dest, Src: PIFVariant): boolean;
  182.   Protected
  183.     {MM is the memory manager used internally. It's needed to create and destroy variants}
  184. {$IFNDEF NOSMARTMM}MM: Pointer;
  185. {$ENDIF}
  186.     {The exception stack}
  187.     FExceptionStack: TIFList; 
  188.     {The list of resources}
  189.     FResources: TIFList;
  190.     {The list of exported variables}
  191.     FExportedVars: TIfList;
  192.     {FTypes contains all types used by the script}
  193.     FTypes: TIfList; 
  194.     {FProcs contains all script procedures}
  195.     FProcs: TIfList; 
  196.     {FGlobalVars contains the global variables of the current script}
  197.     FGlobalVars: TIfList; 
  198.     {The current stack}
  199.     FStack: TIfList; 
  200.     {The main proc no or -1 (no main proc)}
  201.     FMainProc: Cardinal;
  202.     {The current status of the script engine}
  203.     FStatus: TIFStatus;
  204.     {The current proc}
  205.     FCurrProc: PIFProcRec;
  206.     {The current position in the current proc}
  207.     FCurrentPosition: Cardinal;
  208.     {Current stack base}
  209.     FCurrStackBase: Cardinal;
  210.     {FOnRunLine event}
  211.     FOnRunLine: TIFPSOnLineEvent;
  212.     {List of SpecialProcs; See TIFPSExec.AddSpecialProc}
  213.     FSpecialProcList: TIfList;
  214.     {List of all registered external functions}
  215.     FRegProcs: TIfList;
  216.     {The proc where the last error occured}
  217.     ExProc: Cardinal;
  218.     {The position of the last error}
  219.     ExPos: Cardinal;
  220.     {The error code}
  221.     ExEx: TIFError;
  222.     {The optional parameter for the error}
  223.     ExParam: string;
  224.     {RunLine function}
  225.     procedure RunLine; virtual;
  226.     {ImportProc is called when the script needs to import an external function}
  227.     function ImportProc(const Name: ShortString; var proc: TIFProcRec): Boolean; Virtual;
  228.     {ExceptionProc is called when an error occurs}
  229.     procedure ExceptionProc(proc, Position: Cardinal; Ex: TIFError; const s: string); Virtual;
  230.   Public
  231.     {Call CMD_Err to cause an error and stop the script}
  232.     procedure CMD_Err(EC: TIFError);
  233.     {Call CMD_Err2 to cause an error and stop the script}
  234.     procedure CMD_Err2(EC: TIFError; const Param: string);
  235.     {Optional tag of the script engine}
  236.     property Id: Pointer read FID write FID;
  237.     {The MemoryManager used when calling CreateVariant/DestroyVariant}
  238. {$IFNDEF NOSMARTMM}property MemoryManager: Pointer Read MM;{$ENDIF}
  239.     {This function will return about information}
  240.     class function About: string;
  241.     {Use RunProc to call a script function. The Params will not be freed after the call}
  242.     function RunProc(Params: TIfList; ProcNo: Cardinal): Boolean;
  243.     {Search for a type (l is the starting position)}
  244.     function FindType(StartAt: Cardinal; BaseType: TIFPSBaseType; var l: Cardinal): PIFTypeRec;
  245.     {Search for a type}
  246.     function FindType2(BaseType: TIFPSBaseType): PIFTypeRec;
  247.     {Return type no L}
  248.     function GetTypeNo(l: Cardinal): PIFTypeRec;
  249.     {Create an integer variant}
  250.     function CreateIntegerVariant(FType: PIFTypeRec; Value: Longint): PIfVariant;
  251.     {create a string variant}
  252.     function CreateStringVariant(FType: PIFTypeRec; const Value: string): PIfVariant;
  253.     {Create a float variant}
  254.     function CreateFloatVariant(FType: PIFTypeRec; Value: Extended): PIfVariant;
  255.  
  256.     {Get Type that has been compiled with a name}
  257.     function GetType(const Name: string): Cardinal;
  258.     {Get function that has been compiled with a name}
  259.     function GetProc(const Name: string): Cardinal;
  260.     {Get variable that has been compiled with a name}
  261.     function GetVar(const Name: string): Cardinal;
  262.     {Get variable compiled with a name as a variant}
  263.     function GetVar2(const Name: string): PIFVariant;
  264.     {Get variable no (C)}
  265.     function GetVarNo(C: Cardinal): PIFVariant;
  266.     {Get Proc no (C)}
  267.     function GetProcNo(C: Cardinal): PIFProcRec;
  268.  
  269.     {Create an instance of the executer}
  270.     constructor Create;
  271.     {Destroy this instance of the executer}
  272.     destructor Destroy; Override;
  273.  
  274.     {Run the current script}
  275.     function RunScript: Boolean;
  276.  
  277.     {Load data into the script engine}
  278.     function LoadData(const s: string): Boolean; virtual;
  279.     {Clear the currently loaded script}
  280.     procedure Clear; Virtual;
  281.     {Reset all variables in the script to zero}
  282.     procedure Cleanup; Virtual;
  283.     {Stop the script engine}
  284.     procedure Stop; Virtual;
  285.     {Pause the script engine}
  286.     procedure Pause; Virtual;
  287.     {Set CallCleanup to false when you don't want the script engine to cleanup all variables after RunScript}
  288.     property CallCleanup: Boolean read FCallCleanup write FCallCleanup;
  289.     {Status contains the current status of the scriptengine}
  290.     property Status: TIFStatus Read FStatus;
  291.     {The OnRunLine event is called after each executed script line}
  292.     property OnRunLine: TIFPSOnLineEvent Read FOnRunLine Write FOnRunLine;
  293.     {Add a special proc import; this is used for the dll and class library}
  294.     procedure AddSpecialProcImport(const FName: string; P: TIFPSOnSpecialProcImport; Tag: Pointer);
  295.     {Register a function by name}
  296.     function RegisterFunctionName(const Name: ShortString; ProcPtr: TIFProc;
  297.       Ext1, Ext2: Pointer): PProcRec;
  298.     {Clear the function list}
  299.     procedure ClearFunctionList;
  300.     {Contains the last error proc}
  301.     property ExceptionProcNo: Cardinal Read ExProc;
  302.     {Contains the last error position}
  303.     property ExceptionPos: Cardinal Read ExPos;
  304.     {Contains the last error code}
  305.     property ExceptionCode: TIFError Read ExEx;
  306.     {Contains the last error string}
  307.     property ExceptionString: string read ExParam;
  308.  
  309.     {Add a resource}
  310.     procedure AddResource(Proc, P: Pointer);
  311.     {Check if P is a valid resource for Proc}
  312.     function IsValidResource(Proc, P: Pointer): Boolean;
  313.     {Delete a resource}
  314.     procedure DeleteResource(P: Pointer);
  315.     {Find a resource}
  316.     function FindProcResource(Proc: Pointer): Pointer;
  317.     {Find a resource}
  318.     function FindProcResource2(Proc: Pointer; var StartAt: Longint): Pointer;
  319.   end;
  320. {Decrease the variant's refcount and free it if it's 0}
  321. procedure DisposeVariant({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}p: PIfVariant);
  322. {Create a variant}
  323. function CreateVariant({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}n: PIFTypeRec): PIfVariant;
  324. {Convert an error to a string}
  325. function TIFErrorToString(x: TIFError; const Param: string): string;
  326. {Get the value of a variant (as Cardinal/Longword)}
  327. function GetUInt(Src: PIfVariant; var s: Boolean): Cardinal;
  328. {Get the value of a variant (as Longint)}
  329. function GetInt(Src: PIfVariant; var s: Boolean): Longint;
  330. {Get the value of a variant (as Extended)}
  331. function GetReal(Src: PIfVariant; var s: Boolean): Extended;
  332. {Get the value of a variant (as String)}
  333. function GetString(Src: PIfVariant; var s: Boolean): string;
  334. {Set the value of an Integer variant in a list} 
  335. procedure LSetInt(List: TIfList; Pos: Cardinal; Val: Longint);
  336. {Set the value of an unsigned integer variant in a list} 
  337. procedure LSetUInt(List: TIfList; Pos: Cardinal; Val: Cardinal);
  338. {Get the value of an Integer variant in a list} 
  339. function LGetInt(List: TIfList; Pos: Cardinal): Longint;
  340. {Get the value of an unsigned integer variant in a list} 
  341. function LGetUInt(List: TIfList; Pos: Cardinal): Cardinal;
  342. {Set the value of a string variant in a list} 
  343. procedure LSetStr(List: TIfList; Pos: Cardinal; const s: string);
  344. {Get the value of a string variant in a list} 
  345. function LGetStr(List: TIfList; Pos: Cardinal): string;
  346. {Set the value of a real variant in a list}
  347. procedure LSetReal(List: TIfList; Pos: Cardinal; const Val: Extended);
  348. {Get the value of a real variant in a list} 
  349. function LGetReal(List: TIfList; Pos: Cardinal): Extended;
  350. {Get the length of a variant array}
  351. function GetIFPSArrayLength(SE: TIFPSExec; p: PIfVariant): Cardinal;
  352. {Set the length of a variant array}
  353. procedure SetIFPSArrayLength(SE: TIFPSExec; p: PIfVariant; NewLength: Cardinal);
  354.  
  355. {Convert a variant to a string}
  356. function IFPSVariantToString(p: PIfVariant): string;
  357. {Free a list of variants and also the list}
  358. procedure FreePIFVariantList({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}List: TIfList);
  359.  
  360. function VGetString(P: PIFVariant): string;
  361. function VGetFloat(P: PIFVariant): Extended;
  362. function VGetInt(P: PIFVariant): Longint;
  363. {$IFNDEF NOINT64}
  364. function VGetInt64(P: PIFVariant): Int64;
  365. {$ENDIF}
  366.  
  367. procedure VSetString(P: PIFVariant; const d: string);
  368. procedure VSetFloat(P: PIFVariant; const d: Extended);
  369. procedure VSetInt(P: PIFVariant; const d: Longint);
  370. {$IFNDEF NOINT64}
  371. procedure VSetInt64(P: PIFVariant; const d: Int64);
  372. {$ENDIF}
  373.  
  374. const
  375.   ENoError = ERNoError;
  376.   ecCustomError = erCustomError; 
  377.  
  378.  
  379. procedure ChangeVariantType({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}p: PIFVariant; n: PIFTypeRec);
  380.   
  381. implementation
  382.  
  383. function VGetString(P: PIFVariant): string;
  384. begin
  385.   if p = nil then begin Result := ''; exit; end;
  386.   case p^.FType^.BaseType of
  387.     btu8: Result := chr(p^.tu8);
  388.     btString: Result := TbtString(p^.tstring);
  389.     else Result := '';
  390.   end;
  391. end;
  392.  
  393. function VGetFloat(P: PIFVariant): Extended;
  394. begin
  395.   if p = nil then begin Result := 0; exit; end;
  396.   case p^.FType^.BaseType of
  397.     btSingle: Result := p^.tsingle;
  398.     btDouble: Result := p^.tdouble;
  399.     btExtended: Result := p^.textended;
  400.     else Result := 0;
  401.   end;
  402. end;
  403. function VGetInt(P: PIFVariant): Longint;
  404. begin
  405.   if p = nil then begin Result := 0; exit; end;
  406.   case p^.FType^.BaseType of
  407.     btu8: Result := p^.tu8;
  408.     bts8: Result := p^.ts8;
  409.     btu16: Result := p^.tu16;
  410.     bts16: Result := p^.ts16;
  411.     btu32: Result := p^.tu32;
  412.     bts32: Result := p^.ts32;
  413.     else Result := 0;
  414.   end;
  415. end;
  416. {$IFNDEF NOINT64}
  417.  
  418. function VGetInt64(P: PIFVariant): Int64;
  419. begin
  420.   if p = nil then begin Result := 0; exit; end;
  421.   case p^.FType^.BaseType of
  422.     btu8: Result := p^.tu8;
  423.     bts8: Result := p^.ts8;
  424.     btu16: Result := p^.tu16;
  425.     bts16: Result := p^.ts16;
  426.     btu32: Result := p^.tu32;
  427.     bts32: Result := p^.ts32;
  428.     btS64: Result := p^.ts64;
  429.     else Result := 0;
  430.   end;
  431. end;
  432. {$ENDIF}
  433. procedure VSetString(P: PIFVariant; const d: string);
  434. begin
  435.   if p = nil then begin exit; end;
  436.   case p^.FType^.BaseType of
  437.     btString: TbtString(p^.tstring) := d;
  438.   end;
  439. end;
  440. procedure VSetFloat(P: PIFVariant; const d: Extended);
  441. begin
  442.   if p = nil then begin exit; end;
  443.   case p^.FType^.BaseType of
  444.     btSingle: p^.tsingle := d;
  445.     btDouble: p^.tdouble := d;
  446.     btExtended: p^.textended := d;
  447.   end;
  448. end;
  449. procedure VSetInt(P: PIFVariant; const d: Longint);
  450. begin
  451.   if p = nil then begin exit; end;
  452.   case p^.FType^.BaseType of
  453.     btu8: p^.tu8 := d;
  454.     bts8: p^.ts8 := d;
  455.     btu16: p^.tu16 := d;
  456.     bts16: p^.ts16 := d;
  457.     btu32: p^.tu32 := d;
  458.     bts32: p^.ts32 := d;
  459.   end;
  460. end;
  461. {$IFNDEF NOINT64}
  462. procedure VSetInt64(P: PIFVariant; const d: Int64);
  463. begin
  464.   if p = nil then begin exit; end;
  465.   case p^.FType^.BaseType of
  466.     btu8: p^.tu8 := d;
  467.     bts8: p^.ts8 := d;
  468.     btu16: p^.tu16 := d;
  469.     bts16: p^.ts16 := d;
  470.     btu32: p^.tu32 := d;
  471.     bts32: p^.ts32 := d;
  472.     btS64: p^.ts64 := d;
  473.   end;
  474. end;
  475. {$ENDIF}
  476. function MakeString(const s: string): string;
  477. var
  478.   i: Longint;
  479.   e: string;
  480.   b: boolean;
  481. begin
  482.   Result := s;
  483.   i := 1;
  484.   b := false;
  485.   while i <= length(result) do
  486.   begin
  487.     if Result[i] = '''' then
  488.     begin
  489.       if not b then
  490.       begin
  491.         b := true;
  492.         Insert('''', Result, i);
  493.         inc(i);
  494.       end;
  495.       Insert('''', Result, i);
  496.       inc(i, 2);
  497.     end else if (Result[i] < #32) then
  498.     begin
  499.       e := '#'+inttostr(ord(Result[i]));
  500.       Delete(Result, i, 1);
  501.       if b then
  502.       begin
  503.         b := false;
  504.         Insert('''', Result, i);
  505.         inc(i);
  506.       end;
  507.       Insert(e, Result, i);
  508.       inc(i, length(e));
  509.     end else begin
  510.       if not b then
  511.       begin
  512.         b := true;
  513.         Insert('''', Result, i);
  514.         inc(i, 2);
  515.       end else
  516.         inc(i);
  517.     end;  
  518.   end;
  519.   if b then
  520.   begin
  521.     Result := Result + '''';
  522.   end;
  523.   if Result = '' then
  524.     Result := '''''';
  525. end;
  526.  
  527. function IFPSVariantToString(p: PIfVariant): string;
  528. var
  529.   I: Longint;
  530. begin
  531.   while p^.FType^.BaseType = btPointer do
  532.   begin
  533.     if p^.tPointer <> nil then p := p^.tPointer else break;
  534.   end;
  535.   if p^.FType^.BaseType = btVariant then P := p^.tvariant;
  536.   case p^.FType^.BaseType of
  537.     btU8: str(p^.tu8, Result);
  538.     btS8: str(p^.ts8, Result);
  539.     btU16: str(p^.tu16, Result);
  540.     btS16: str(p^.ts16, Result);
  541.     btU32: str(p^.tu32, Result);
  542.     btS32: str(p^.ts32, Result);
  543.     btSingle: str(p^.tsingle, Result);
  544.     btDouble: str(p^.tdouble, Result);
  545.     btExtended: str(p^.textended, Result);
  546.     btString, btPChar: Result := makestring(string(p^.tString));
  547.     {$IFNDEF NOINT64}btS64: str(p^.ts64, Result);{$ENDIF}
  548.     btRecord, btArray:
  549.       begin
  550.         Result := '[';
  551.         if p^.tArray <>nil then
  552.         begin
  553.           for i := 0 to pbtRecord(p^.tarray)^.FieldCount -1 do
  554.           begin
  555.             if i <> 0 then
  556.               Result := Result + ', ';
  557.             Result := Result + IFPSVariantToString(pbtRecord(p^.tarray)^.Fields[i]);
  558.           end;
  559.         end;
  560.         Result := Result + ']';
  561.       end;
  562.     btPointer: Result := 'Nil';
  563.     btResourcePointer: Result := '[ResourcePointer]';
  564.   else
  565.     Result := '[Invalid]';
  566.   end;
  567. end;
  568.  
  569.  
  570. function GetIFPSArrayLength(SE: TIFPSExec; p: PIfVariant): Cardinal;
  571. begin
  572.   if p^.FType^.BaseType <> btArray then begin
  573.     Result := 0;
  574.     exit;
  575.   end;
  576.   if p^.tArray = nil then
  577.     Result := 0
  578.   else
  579.     Result := pbtrecord(p^.tArray)^.FieldCount;
  580. end;
  581.  
  582. function Min(const x, Y: Integer): Integer;
  583. begin
  584.   if x < Y then Result := x else Result := Y;
  585. end;
  586.  
  587. procedure SetIFPSArrayLength(SE: TIFPSExec; p: PIfVariant; NewLength: Cardinal);
  588. var
  589.   I, oldl: Integer;
  590.   r: pbtrecord;
  591. begin
  592.   if p^.FType^.BaseType <> btArray then exit;
  593.   if p^.tArray = nil then begin
  594.     I := NewLength;
  595.     if I > 0 then begin
  596.       try
  597.         GetMem(r, 4 + I * 4);
  598.       except
  599.         exit;
  600.       end;
  601.       r^.FieldCount := I;
  602.       Dec(I);
  603.       while I >= 0 do begin
  604.         r^.Fields[I] := CreateVariant({$IFNDEF NOSMARTMM}SE.MemoryManager, {$ENDIF}SE.GetTypeNo(Cardinal(p^.FType^.Ext)));
  605.         if r^.Fields[I] = nil then begin
  606.           while I < Longint(NewLength) do begin
  607.             DisposeVariant({$IFNDEF NOSMARTMM}SE.MemoryManager, {$ENDIF}r.Fields[I]);
  608.             Inc(I);
  609.           end;
  610.           exit;
  611.         end;
  612.         Dec(I);
  613.       end;
  614.       p^.tArray := r;
  615.     end;
  616.   end else begin
  617.     r := p^.tArray;
  618.     oldl := NewLength;
  619.     for I := oldl to r^.FieldCount - 1 do begin
  620.       DisposeVariant({$IFNDEF NOSMARTMM}SE.MemoryManager, {$ENDIF}r^.Fields[I]);
  621.     end;
  622.     if oldl = 0 then begin
  623.       FreeMem(r, 4 + 4 * r^.FieldCount);
  624.       p^.tArray := nil;
  625.     end else begin
  626.       I := oldl;
  627.       oldl := r^.FieldCount;
  628.       try
  629.         ReallocMem(r, 4 + 4 * I);
  630.       except
  631.         for I := 0 to Min(NewLength, oldl) - 1 do begin
  632.           DisposeVariant({$IFNDEF NOSMARTMM}SE.MemoryManager, {$ENDIF}r^.Fields[I]);
  633.         end;
  634.         FreeMem(r, 4 + 4 * NewLength);
  635.         p^.tArray := nil;
  636.         exit;
  637.       end;
  638.       r^.FieldCount := I;
  639.       for I := r^.FieldCount - 1 downto oldl do begin
  640.         r^.Fields[I] := CreateVariant({$IFNDEF NOSMARTMM}SE.MemoryManager, {$ENDIF}SE.GetTypeNo(Cardinal(p^.FType^.Ext)));
  641.         if r^.Fields[I] = nil then begin
  642.           oldl := I;
  643.           while oldl < Longint(NewLength) do begin
  644.             DisposeVariant({$IFNDEF NOSMARTMM}SE.MemoryManager, {$ENDIF}r.Fields[oldl]);
  645.             Inc(oldl);
  646.           end;
  647.           exit;
  648.         end;
  649.       end;
  650.       p^.tArray := r;
  651.     end;
  652.   end;
  653. end;
  654.  
  655. function SafeStr(const s: string): string;
  656. var
  657.  i : Longint;
  658. begin
  659.   Result := s;
  660.   for i := 1 to length(s) do
  661.   begin
  662.     if s[i] in [#0..#31] then
  663.     begin
  664.       Result := Copy(s, 1, i-1);
  665.       exit;
  666.     end;
  667.   end;
  668.  
  669. end;
  670.  
  671. function TIFErrorToString(x: TIFError; const Param: string): string;
  672. begin
  673.   case x of
  674.     ErNoError: Result := 'No Error';
  675.     erCannotImport: Result := 'Cannot Import '+Safestr(Param);
  676.     erInvalidType: Result := 'Invalid Type';
  677.     ErInternalError: Result := 'Internal error';
  678.     erInvalidHeader: Result := 'Invalid Header';
  679.     erInvalidOpcode: Result := 'Invalid Opcode';
  680.     erInvalidOpcodeParameter: Result := 'Invalid Opcode Parameter';
  681.     erNoMainProc: Result := 'no Main Proc';
  682.     erOutOfGlobalVarsRange: Result := 'Out of Global Vars range';
  683.     erOutOfProcRange: Result := 'Out of Proc Range';
  684.     ErOutOfRange: Result := 'Out Of Range';
  685.     erOutOfStackRange: Result := 'Out Of Stack Range';
  686.     ErTypeMismatch: Result := 'Type Mismatch';
  687.     erUnexpectedEof: Result := 'Unexpected End Of File';
  688.     erVersionError: Result := 'Version error';
  689.     ErDivideByZero: Result := 'divide by Zero';
  690.     erMathError: Result := 'Math error';
  691.     erCouldNotCallProc: Result := 'Could not call proc';
  692.     erOutofRecordRange: Result := 'Out of Record Fields Range';
  693.     erNullPointerException: Result := 'Null Pointer Exception';
  694.     erNullVariantError: Result := 'Null variant error';
  695.     erOutOfMemory: Result := 'Out Of Memory';
  696.     erException: Result := 'Exception: '+ Param;
  697.     erCustomError: Result := Param;
  698.       else
  699.     Result := 'Unknown error';
  700.   end;
  701.   //
  702. end;
  703.  
  704. {$IFNDEF NOSMARTMM}
  705. const
  706.   Count = 50;
  707.  
  708. type
  709.   TFreeIFVariant = packed record
  710.     NextFreeItem: Longint;
  711.     DummyData: array[0..SizeOf(TIfVariant) - SizeOf(Longint) - 1 +
  712.     SizeOf(Pointer)] of Byte;
  713.   end;
  714.   PPageData = ^TPageData;
  715.   TMyIFVariant = packed record
  716.     Page: PPageData;
  717.     p: TIfVariant;
  718.   end;
  719.   TPageData = packed record
  720.     ItemCount, FirstFreeItem: Longint;
  721.     PrevPage, NextPage,
  722.       PrevFreeItemsPage, NextFreeItemsPage: PPageData;
  723.     case Byte of
  724.       0: (BLOCK: array[0..Count - 1] of TMyIFVariant);
  725.       1: (FREELIST: array[0..Count - 1] of TFreeIFVariant);
  726.   end;
  727.  
  728. type
  729.   TIFVariantMemoryManager = class
  730.   Private
  731.     FFirstFreeItemsPage, FFirstPage: PPageData;
  732.     procedure CleanItem(Page: PPageData);
  733.     function AllocItem: Boolean;
  734.   Public
  735.     constructor Create;
  736.     destructor Destroy; Override;
  737.     procedure Clear;
  738.  
  739.     function Alloc: PIfVariant;
  740.     procedure DisposeItem(p: PIfVariant);
  741.   end;
  742. type
  743.   TPointingInteger = Longint; // same size as Pointer
  744.  
  745. function TIFVariantMemoryManager.Alloc: PIfVariant;
  746. var
  747.   CB: PPageData;
  748.   I: Integer;
  749. begin
  750.   if FFirstFreeItemsPage = nil then begin
  751.     if not AllocItem then begin
  752.       Result := nil;
  753.       exit;
  754.     end;
  755.   end;
  756.   CB := FFirstFreeItemsPage;
  757.   Inc(CB^.ItemCount);
  758.   I := CB^.FirstFreeItem;
  759.   CB^.FirstFreeItem := CB^.FREELIST[I].NextFreeItem;
  760.   Result := @CB^.BLOCK[I].p;
  761.   CB^.BLOCK[I].Page := CB;
  762.   if CB^.FirstFreeItem = -1 then begin // remove from freeitemspage list
  763.     if CB^.PrevFreeItemsPage <> nil then
  764.       CB^.PrevFreeItemsPage^.NextFreeItemsPage := CB^.NextFreeItemsPage;
  765.     if CB^.NextFreeItemsPage <> nil then
  766.       CB^.NextFreeItemsPage^.PrevFreeItemsPage := CB^.PrevFreeItemsPage;
  767.     if FFirstFreeItemsPage = CB then
  768.       FFirstFreeItemsPage := CB^.NextFreeItemsPage;
  769.   end;
  770. end;
  771.  
  772. function TIFVariantMemoryManager.AllocItem: Boolean;
  773. var
  774.   NewItem: PPageData;
  775.   I: Longint;
  776.  
  777. begin
  778.   try
  779.     New(NewItem);
  780.   except
  781.     Result := False;
  782.     exit;
  783.   end;
  784.  
  785.   NewItem^.ItemCount := 0;
  786.   NewItem^.FirstFreeItem := Count - 1;
  787.   NewItem^.PrevPage := nil;
  788.   NewItem^.NextPage := FFirstPage;
  789.   NewItem^.PrevFreeItemsPage := nil;
  790.   NewItem^.NextFreeItemsPage := FFirstFreeItemsPage;
  791.  
  792.   for I := Count - 1 downto 0 do begin
  793.     NewItem^.FREELIST[I].NextFreeItem := I - 1;
  794.   end;
  795.  
  796.   if FFirstPage <> nil then
  797.     FFirstPage^.PrevPage := NewItem;
  798.   if FFirstFreeItemsPage <> nil then
  799.     FFirstFreeItemsPage^.PrevPage := NewItem;
  800.  
  801.   FFirstPage := NewItem;
  802.   FFirstFreeItemsPage := NewItem;
  803.   Result := True;
  804. end;
  805.  
  806. procedure TIFVariantMemoryManager.CleanItem(Page: PPageData);
  807. begin
  808.   if Page^.PrevPage <> nil then
  809.     Page^.PrevPage^.NextPage := Page^.NextPage;
  810.   if Page^.NextPage <> nil then
  811.     Page^.NextPage^.PrevPage := Page^.PrevPage;
  812.  
  813.   if Page^.PrevFreeItemsPage <> nil then
  814.     Page^.PrevFreeItemsPage^.NextFreeItemsPage := Page^.NextFreeItemsPage;
  815.   if Page^.NextFreeItemsPage <> nil then
  816.     Page^.NextFreeItemsPage^.PrevFreeItemsPage := Page^.PrevFreeItemsPage;
  817.   if FFirstPage = Page then
  818.     FFirstPage := Page^.NextPage;
  819.   if FFirstFreeItemsPage = Page then
  820.     FFirstFreeItemsPage := Page^.NextFreeItemsPage;
  821.   Dispose(Page);
  822. end;
  823.  
  824. procedure TIFVariantMemoryManager.Clear;
  825. var
  826.   CB, NB: PPageData;
  827. begin
  828.   CB := FFirstPage;
  829.   while CB <> nil do begin
  830.     NB := CB^.NextPage;
  831.     Dispose(CB);
  832.     CB := NB;
  833.   end;
  834.   FFirstPage := nil;
  835.   FFirstFreeItemsPage := nil;
  836. end;
  837.  
  838. constructor TIFVariantMemoryManager.Create;
  839. begin
  840.   inherited Create;
  841.   FFirstFreeItemsPage := nil;
  842.   FFirstPage := nil;
  843. end;
  844.  
  845. destructor TIFVariantMemoryManager.Destroy;
  846. begin
  847.   Clear;
  848.   inherited Destroy;
  849. end;
  850.  
  851. procedure TIFVariantMemoryManager.DisposeItem(p: PIfVariant);
  852. var
  853.   Page: PPageData;
  854.   I: Longint;
  855. begin
  856.   Page := PPageData(Pointer(TPointingInteger(p) - SizeOf(Pointer))^);
  857.   I := (TPointingInteger(p) - TPointingInteger(@Page^.BLOCK) - SizeOf(Pointer)) div SizeOf(TMyIFVariant);
  858.   Dec(Page^.ItemCount);
  859.   Page^.FREELIST[I].NextFreeItem := Page^.FirstFreeItem;
  860.   Page^.FirstFreeItem := I;
  861.   if Page^.ItemCount = 0 then begin
  862.     CleanItem(Page);
  863.   end
  864.   else if Page^.ItemCount = Count - 1 then begin // insert into list
  865.     if FFirstFreeItemsPage <> nil then
  866.       FFirstFreeItemsPage^.PrevFreeItemsPage := Page;
  867.     Page^.PrevFreeItemsPage := nil;
  868.     Page^.NextFreeItemsPage := FFirstFreeItemsPage;
  869.     FFirstFreeItemsPage := Page;
  870.   end;
  871. end;
  872.  
  873. {$ENDIF}
  874.  
  875. const
  876.   ReturnAddressType: TIFTypeRec = (Ext: nil; BaseType: btReturnAddress);
  877.  
  878. type
  879.   PIFPSExceptionHandler =^TIFPSExceptionHandler;
  880.   TIFPSExceptionHandler = packed record
  881.     BasePtr, StackSize: Cardinal;
  882.     FinallyOffset, ExceptOffset, Finally2Offset, EndOfBlock: Cardinal;
  883.   end;
  884.   TIFPSHeader = packed record
  885.     HDR: Cardinal;
  886.     IFPSBuildNo: Cardinal;
  887.     TypeCount: Cardinal;
  888.     ProcCount: Cardinal;
  889.     VarCount: Cardinal;
  890.     MainProcNo: Cardinal;
  891.     ImportTableSize: Cardinal;
  892.   end;
  893.  
  894.   TIFPSExportItem = packed record
  895.     ProcNo: Cardinal;
  896.     NameLength: Cardinal;
  897.     DeclLength: Cardinal;
  898.   end;
  899.  
  900.   TIFPSType = packed record
  901.     BaseType: TIFPSBaseType;
  902.   end;
  903.   TIFPSProc = packed record
  904.     Flags: Byte;
  905.   end;
  906.  
  907.   TIFPSVar = packed record
  908.     TypeNo: Cardinal;
  909.     Flags: Byte;
  910.   end;
  911.   PSpecialProc = ^TSpecialProc;
  912.   TSpecialProc = record
  913.     P: TIFPSOnSpecialProcImport;
  914.     namehash: Longint;
  915.     Name: string;
  916.     tag: pointer;
  917.   end;
  918.  
  919. procedure DisposeType(p: PIFTypeRec);
  920. var
  921.   x: PIFRecordType;
  922. begin
  923.   if p^.BaseType = btRecord then begin
  924.     x := p^.Ext;
  925.     x^.Data := '';
  926.     Dispose(x);
  927.   end;
  928.   Dispose(p);
  929. end;
  930.  
  931. procedure DisposeProc(SE: TIFPSExec; p: PIFProcRec);
  932. begin
  933.   if not p^.ExternalProc then
  934.     FreeMem(p^.Data, p^.Length);
  935.  
  936.   Dispose(p);
  937. end;
  938.  
  939. function Initrecord({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}FType:
  940.   PIFRecordType; var Rec: pbtrecord): Boolean;
  941. var
  942.   I, J: Longint;
  943. begin
  944.   I := (Length(FType^.Data) shr 2);
  945.   try
  946.     GetMem(Rec, 4 + 4 * I);
  947.   except
  948.     Result := False;
  949.     exit;
  950.   end;
  951.   Rec.FieldCount := I;
  952.   for I := 0 to Rec.FieldCount - 1 do begin
  953.     Rec.Fields[I] := CreateVariant({$IFNDEF NOSMARTMM}MM,
  954. {$ENDIF}PIFTypeRec((@FType^.Data[I shl 2 + 1])^));
  955.     if Rec.Fields[I] = nil then begin
  956.       for J := I - 1 downto 0 do begin
  957.         DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Rec.Fields[J]);
  958.         FreeMem(Rec, 4 * 4 * (Length(FType^.Data) shr 2));
  959.         Result := False;
  960.         exit;
  961.       end;
  962.     end;
  963.   end;
  964.   Result := True;
  965. end;
  966.  
  967. procedure FreeRecord({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}Rec: pbtrecord);
  968. var
  969.   I: Longint;
  970. begin
  971.   if Rec <> nil then begin
  972.     for I := Rec.FieldCount - 1 downto 0 do
  973.       DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Rec.Fields[I]);
  974.     FreeMem(Rec, Rec.FieldCount * 4 + 4);
  975.   end;
  976. end;
  977.  
  978. procedure DisposeVariant({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}p: PIfVariant);
  979. begin
  980.   if p <> nil then
  981.   if p^.RefCount = 0 then begin
  982.     if p^.FType <> nil then
  983.     begin
  984.       if (p^.FType^.BaseType = btRecord) or (p^.FType^.BaseType = btArray) then
  985.         FreeRecord({$IFNDEF NOSMARTMM}MM, {$ENDIF}p^.trecord)
  986.       else if p^.FType^.BaseType = btString then
  987.         Finalize(TbtString((@p^.tstring)^))
  988.       else if p^.FType^.BaseType = btResourcePointer then
  989.       begin
  990.         if (@p^.tResourceFreeProc <> nil) then
  991.         begin
  992.           p^.tResourceFreeProc(vrfFree, p, nil);
  993.         end;
  994.       end else if p^.FType^.BaseType = btvariant then
  995.          DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}p^.tvariant);
  996.     end;
  997.     {$IFNDEF NOSMARTMM}
  998.     TIFVariantMemoryManager(MM).DisposeItem(p);
  999.     {$ELSE}
  1000.     Dispose(p);
  1001.     {$ENDIF}
  1002.   end
  1003.   else
  1004.     Dec(p^.RefCount);
  1005. end;
  1006.  
  1007. procedure ChangeVariantType({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}p: PIFVariant; n: PIFTypeRec);
  1008. begin
  1009.   if p^.FType <> nil then
  1010.   begin
  1011.     if (p^.FType^.BaseType = btRecord) or (p^.FType^.BaseType = btArray) then
  1012.       FreeRecord({$IFNDEF NOSMARTMM}MM, {$ENDIF}p^.trecord)
  1013.     else if p^.FType^.BaseType = btString then
  1014.       Finalize(TbtString((@p^.tstring)^))
  1015.     else if p^.FType^.BaseType = btResourcePointer then
  1016.     begin
  1017.       if (@p^.tResourceFreeProc <> nil) then
  1018.       begin
  1019.         p^.tResourceFreeProc(vrfFree, p, nil);
  1020.       end;
  1021.     end else if p^.FType^.BaseType = btvariant then
  1022.       DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}p^.tvariant);
  1023.   end;
  1024.   p^.FType := n;
  1025.   if n <> nil then
  1026.   begin
  1027.     if n^.BaseType = btVariant then
  1028.     begin
  1029.       {$IFDEF NOSMARTMM}
  1030.       try
  1031.         New(p^.tvariant);
  1032.       except
  1033.         p^.tvariant := nil;
  1034.         exit;
  1035.       end;
  1036.       {$ELSE}
  1037.       p^.TVariant := TIFVariantMemoryManager(MM).Alloc;
  1038.       {$ENDIF}
  1039.        p^.tVariant^.FType := nil;
  1040.        p^.tvariant^.refcount := 0;
  1041.     end else if (n^.BaseType = btRecord) then begin
  1042.       p^.RefCount := 0;
  1043.       if not Initrecord({$IFNDEF NOSMARTMM}MM, {$ENDIF}n^.Ext, pbtrecord(p^.trecord)) then begin
  1044.         p^.trecord := nil;
  1045.         DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}p);
  1046.       end;
  1047.     end
  1048.     else begin
  1049.       FillChar(p^.RefCount, SizeOf(TIfVariant) - SizeOf(Pointer), 0);
  1050.     end;
  1051.   end;
  1052. end;
  1053.  
  1054. function CreateVariant({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}n: PIFTypeRec): PIfVariant;
  1055. var
  1056.   p: PIfVariant;
  1057. begin
  1058.   if n = nil then begin
  1059.     Result := nil;
  1060.     exit;
  1061.   end;
  1062. {$IFNDEF NOSMARTMM}
  1063.   p := TIFVariantMemoryManager(MM).Alloc;
  1064.   if p = nil then begin
  1065.     Result := nil;
  1066.     exit;
  1067.   end;
  1068. {$ELSE}
  1069.   try
  1070.     New(p);
  1071.   except
  1072.     Result := nil;
  1073.     exit;
  1074.   end;
  1075. {$ENDIF}
  1076.  
  1077.   p^.FType := n;
  1078.   if n^.BaseType = btVariant then
  1079.   begin
  1080.     {$IFDEF NOSMARTMM}
  1081.     try
  1082.       New(p^.tvariant);
  1083.     except
  1084.       p^.tvariant := nil;
  1085.       exit;
  1086.     end;
  1087.     {$ELSE}
  1088.     p^.TVariant := TIFVariantMemoryManager(MM).Alloc;
  1089.     {$ENDIF}
  1090.      p^.tVariant^.FType := nil;
  1091.      p^.tvariant^.RefCount := 0;
  1092.   end else if (n^.BaseType = btRecord) then begin
  1093.     p^.RefCount := 0;
  1094.     if not Initrecord({$IFNDEF NOSMARTMM}MM, {$ENDIF}n^.Ext, pbtrecord(p^.trecord)) then begin
  1095.       p^.trecord := nil;
  1096.       DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}p);
  1097.     end;
  1098.   end
  1099.   else begin
  1100.     FillChar(p^.RefCount, SizeOf(TIfVariant) - SizeOf(Pointer), 0);
  1101.   end;
  1102.   CreateVariant := p;
  1103. end;
  1104. procedure LSetReal(List: TIfList; Pos: Cardinal; const Val: Extended);
  1105. var
  1106.   p: PIfVariant;
  1107. begin
  1108.   p := List.GetItem(Pos);
  1109.   if p = nil then exit;
  1110.   case p^.FType^.BaseType of
  1111.     btSingle: p^.tsingle := Val;
  1112.     btDouble: p^.tdouble := Val;
  1113.     btExtended: p^.textended := Val;
  1114.   end;
  1115. end;
  1116.  
  1117. function LGetReal(List: TIfList; Pos: Cardinal): Extended;
  1118. var
  1119.   p: PIfVariant;
  1120. begin
  1121.   p := List.GetItem(Pos);
  1122.   if p = nil then begin result := 0; exit; end;
  1123.   case p^.FType^.BaseType of
  1124.     btSingle: Result := p^.tsingle;
  1125.     btDouble: Result := p^.tdouble;
  1126.     btExtended: Result := p^.textended;
  1127.   else
  1128.     Result := 0;
  1129.   end;
  1130. end;
  1131.  
  1132. function LGetStr(List: TIfList; Pos: Cardinal): string;
  1133. var
  1134.   p: PIfVariant;
  1135. begin
  1136.   p := List.GetItem(Pos);
  1137.   if p = nil then begin result := ''; exit; end;
  1138.   case p^.FType^.BaseType of
  1139.     btstring: Result := TbtString(p^.tstring);
  1140.   end;
  1141. end;
  1142.  
  1143. procedure LSetStr(List: TIfList; Pos: Cardinal; const s: string);
  1144. var
  1145.   p: PIfVariant;
  1146. begin
  1147.   p := List.GetItem(Pos);
  1148.   if p = nil then exit;
  1149.   case p^.FType^.BaseType of
  1150.     btstring: TbtString(p^.tstring) := s;
  1151.   end;
  1152. end;
  1153.  
  1154. function LGetUInt(List: TIfList; Pos: Cardinal): Cardinal;
  1155. var
  1156.   p: PIfVariant;
  1157. begin
  1158.   p := List.GetItem(Pos);
  1159.   if p = nil then begin result := 0; exit; end;
  1160.   case p^.FType^.BaseType of
  1161.     btU8: Result := p^.tu8;
  1162.     btS8: Result := p^.tS8;
  1163.     btU16: Result := p^.tu16;
  1164.     btS16: Result := p^.ts16;
  1165.     btU32: Result := p^.tu32;
  1166.     btS32: Result := p^.ts32;
  1167.     {$IFNDEF NOINT64}btS64: Result := p^.ts64;{$ENDIF}
  1168.     btString: begin
  1169.       if Length(tbtstring(p^.tstring)) =1 then
  1170.       begin
  1171.         Result := ord(tbtstring(p^.tstring)[1]);
  1172.       end else Result := 0;
  1173.     end;
  1174.   else
  1175.     Result := 0;
  1176.   end;
  1177. end;
  1178.  
  1179. function LGetInt(List: TIfList; Pos: Cardinal): Longint;
  1180. var
  1181.   p: PIfVariant;
  1182. begin
  1183.   p := List.GetItem(Pos);
  1184.   if p = nil then begin result := 0; exit; end;
  1185.   case p^.FType^.BaseType of
  1186.     btU8: Result := p^.tu8;
  1187.     btS8: Result := p^.tS8;
  1188.     btU16: Result := p^.tu16;
  1189.     btS16: Result := p^.ts16;
  1190.     btU32: Result := p^.tu32;
  1191.     btS32: Result := p^.ts32;
  1192.     {$IFNDEF NOINT64}btS64: Result := p^.ts64;{$ENDIF}
  1193.     btString: begin
  1194.       if Length(tbtstring(p^.tstring)) =1 then
  1195.       begin
  1196.         Result := ord(tbtstring(p^.tstring)[1]);
  1197.       end else Result := 0;
  1198.     end;
  1199.   else
  1200.     Result := 0;
  1201.   end;
  1202. end;
  1203.  
  1204. procedure LSetUInt(List: TIfList; Pos: Cardinal; Val: Cardinal);
  1205. var
  1206.   Src: PIfVariant;
  1207. begin
  1208.   Src := List.GetItem(Pos);
  1209.   if Src = nil then exit;
  1210.   case Src^.FType^.BaseType of
  1211.     btU8: Src^.tu8 := Val;
  1212.     btS8: Src^.tS8 := Val;
  1213.     btU16: Src^.tu16 := Val;
  1214.     btS16: Src^.ts16 := Val;
  1215.     btU32: Src^.tu32 := Val;
  1216.     btS32: Src^.ts32 := Val;
  1217.     {$IFNDEF NOINT64}btS64: src^.ts64 := Val;{$ENDIF}
  1218.     btString: tbtstring(src^.tstring) := Chr(Val);
  1219.   end;
  1220. end;
  1221.  
  1222. procedure LSetInt(List: TIfList; Pos: Cardinal; Val: Longint);
  1223. var
  1224.   Src: PIfVariant;
  1225. begin
  1226.   Src := List.GetItem(Pos);
  1227.   if Src = nil then exit;
  1228.   case Src^.FType^.BaseType of
  1229.     btU8: Src^.tu8 := Val;
  1230.     btS8: Src^.tS8 := Val;
  1231.     btU16: Src^.tu16 := Val;
  1232.     btS16: Src^.ts16 := Val;
  1233.     btU32: Src^.tu32 := Val;
  1234.     btS32: Src^.ts32 := Val;
  1235.     {$IFNDEF NOINT64}btS64: src^.ts64 := Val;{$ENDIF}
  1236.     btString: tbtstring(src^.tstring) := chr(Val);
  1237.   end;
  1238. end;
  1239. {$IFNDEF NOINT64}
  1240. function GetInt64(Src: PIfVariant; var s: Boolean): Int64;
  1241. begin
  1242.   case Src^.FType^.BaseType of
  1243.     btVariant:
  1244.       begin
  1245.         if src^.TVariant^.FType <> nil then
  1246.           Result := GetInt64(Src^.TVariant, s)
  1247.         else
  1248.          Result := 0;
  1249.       end;
  1250.     btU8: Result := Src^.tu8;
  1251.     btS8: Result := Src^.tS8;
  1252.     btU16: Result := Src^.tu16;
  1253.     btS16: Result := Src^.ts16;
  1254.     btU32: Result := Src^.tu32;
  1255.     btS32: Result := Src^.ts32;
  1256.     btS64: Result := src^.ts64;
  1257.     btString: begin
  1258.       if Length(tbtstring(src^.tstring)) =1 then
  1259.       begin
  1260.         Result := ord(tbtstring(src^.tstring)[1]);
  1261.       end else begin Result := 0; s := False; end;
  1262.     end;
  1263.   else begin
  1264.       s := False;
  1265.       Result := 0;
  1266.     end;
  1267.   end;
  1268. end;
  1269. {$ENDIF}
  1270.  
  1271. function GetUInt(Src: PIfVariant; var s: Boolean): Cardinal;
  1272. begin
  1273.   case Src^.FType^.BaseType of
  1274.     btVariant:
  1275.       begin
  1276.         if src^.TVariant^.FType <> nil then
  1277.           Result := GetUINT(Src^.TVariant, s)
  1278.         else
  1279.          Result := 0;
  1280.       end;
  1281.     btU8: Result := Src^.tu8;
  1282.     btS8: Result := Src^.tS8;
  1283.     btU16: Result := Src^.tu16;
  1284.     btS16: Result := Src^.ts16;
  1285.     btU32: Result := Src^.tu32;
  1286.     btS32: Result := Src^.ts32;
  1287.     {$IFNDEF NOINT64}btS64: Result := src^.ts64;{$ENDIF}
  1288.     btString: begin
  1289.       if Length(tbtstring(src^.tstring)) =1 then
  1290.       begin
  1291.         Result := ord(tbtstring(src^.tstring)[1]);
  1292.       end else begin Result := 0; s := False; end;
  1293.     end;
  1294.   else begin
  1295.       s := False;
  1296.       Result := 0;
  1297.     end;
  1298.   end;
  1299. end;
  1300.  
  1301. function GetInt(Src: PIfVariant; var s: Boolean): Longint;
  1302. begin
  1303.   case Src^.FType^.BaseType of
  1304.     btVariant:
  1305.       begin
  1306.         if src^.TVariant^.FType <> nil then
  1307.           Result := GetInt(Src^.TVariant, s)
  1308.         else
  1309.          Result := 0;
  1310.       end;
  1311.     btU8: Result := Src^.tu8;
  1312.     btS8: Result := Src^.tS8;
  1313.     btU16: Result := Src^.tu16;
  1314.     btS16: Result := Src^.ts16;
  1315.     btU32: Result := Src^.tu32;
  1316.     btS32: Result := Src^.ts32;
  1317.     {$IFNDEF NOINT64}btS64: Result := src^.ts64;{$ENDIF}
  1318.     btString: begin
  1319.       if Length(tbtstring(src^.tstring)) =1 then
  1320.       begin
  1321.         Result := ord(tbtstring(src^.tstring)[1]);
  1322.       end else begin Result := 0; s := False; end;
  1323.     end;
  1324.   else begin
  1325.       s := False;
  1326.       Result := 0;
  1327.     end;
  1328.   end;
  1329. end;
  1330.  
  1331. function GetReal(Src: PIfVariant; var s: Boolean): Extended;
  1332. begin
  1333.   case Src^.FType^.BaseType of
  1334.     btVariant:
  1335.       begin
  1336.         if src^.TVariant^.FType <> nil then
  1337.           Result := GetReal(Src^.TVariant, s)
  1338.         else
  1339.          Result := 0;
  1340.       end;
  1341.     btU8: Result := Src^.tu8;
  1342.     btS8: Result := Src^.tS8;
  1343.     btU16: Result := Src^.tu16;
  1344.     btS16: Result := Src^.ts16;
  1345.     btU32: Result := Src^.tu32;
  1346.     btS32: Result := Src^.ts32;
  1347.     btSingle: Result := Src^.tsingle;
  1348.     btDouble: Result := Src^.tdouble;
  1349.     btExtended: Result := Src^.textended;
  1350.   else begin
  1351.       s := False;
  1352.       Result := 0;
  1353.     end;
  1354.   end;
  1355. end;
  1356.  
  1357. function GetString(Src: PIfVariant; var s: Boolean): string;
  1358. begin
  1359.   case Src^.FType^.BaseType of
  1360.     btVariant:
  1361.       begin
  1362.         if src^.TVariant^.FType <> nil then
  1363.           Result := GetString(Src^.TVariant, s)
  1364.         else
  1365.          Result := '';
  1366.       end;
  1367.     btU8, btS8: Result := Char(Src^.tu8);
  1368.     btPChar, btString: Result := TbtString((@Src^.tstring)^);
  1369.   else begin
  1370.       s := False;
  1371.       Result := '';
  1372.     end;
  1373.   end;
  1374. end;
  1375.  
  1376. function LookupProc(List: TIfList; const Name: ShortString): PProcRec;
  1377. var
  1378.   h, l: Longint;
  1379. begin
  1380.   h := MakeHash(Name);
  1381.   for l := 0 to List.Count - 1 do begin
  1382.     if (PProcRec(List.GetItem(l))^.Hash = h) and (PProcRec(List.GetItem(l))^.Name
  1383.       = Name) then begin
  1384.       Result := List.GetItem(l);
  1385.       exit;
  1386.     end;
  1387.   end;
  1388.   Result := nil;
  1389. end;
  1390.  
  1391. { TIFPSExec }
  1392.  
  1393. procedure TIFPSExec.ClearFunctionList;
  1394. var
  1395.   x: PProcRec;
  1396.   l: Longint;
  1397. begin
  1398.   for l := 0 to FRegProcs.Count - 1 do begin
  1399.     x := FRegProcs.GetItem(l);
  1400.     if @x^.FreeProc <> nil then x^.FreeProc(Self, x);
  1401.     Dispose(x);
  1402.   end;
  1403.   FRegProcs.Clear;
  1404. end;
  1405.  
  1406. class function TIFPSExec.About: string;
  1407. begin
  1408.   Result := 'Innerfuse Pascal Script III ' + IFPSCurrentversion + '. Copyright (c) 2001-2002 by Carlo Kok';
  1409. end;
  1410.  
  1411. procedure TIFPSExec.Cleanup;
  1412. var
  1413.   I: Longint;
  1414.   p: PIfVariant;
  1415. begin
  1416.   if FStatus <> isLoaded then
  1417.     exit;
  1418.   for I := 0 to Longint(FGlobalVars.Count) - 1 do begin
  1419.     p := FGlobalVars.GetItem(I);
  1420.     FGlobalVars.SetItem(I, CreateVariant({$IFNDEF NOSMARTMM}MM,
  1421. {$ENDIF}p^.FType));
  1422.     DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}p);
  1423.   end;
  1424. end;
  1425. type
  1426.   PIFPSExportedVar = ^TIFPSExportedVar;
  1427.   TIFPSExportedVar = record
  1428.     FName: string;
  1429.     FNameHash: Longint;
  1430.     FVarNo: Cardinal;
  1431.   end;
  1432.  
  1433. procedure TIFPSExec.Clear;
  1434. var
  1435.   I: Longint;
  1436.   temp: PIFPSResource;
  1437.   Proc: TIFPSResourceFreeProc;
  1438.   pp: PIFPSExceptionHandler;
  1439. begin
  1440.   for i := Longint(FExceptionStack.Count) -1 downto 0 do
  1441.   begin
  1442.     pp := FExceptionStack.GetItem(i);
  1443.     Dispose(pp);
  1444.   end;
  1445.   for i := Longint(FResources.Count) -1 downto 0 do
  1446.   begin
  1447.     Temp := FResources.GetItem(i);
  1448.     Proc := Temp^.Proc;
  1449.     Proc(Self, Temp^.P);
  1450.     Dispose(Temp);
  1451.   end;
  1452.   for i := Longint(FExportedVars.Count) -1 downto 0 do
  1453.   begin
  1454.     Dispose(PIFPSExportedVar(FExportedVars.GetItem(I)));
  1455.   end;
  1456.   for I := 0 to Longint(FStack.Count) - 1 do begin
  1457.     DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FStack.GetItem(I));
  1458.   end;
  1459.   for I := 0 to Longint(FProcs.Count) - 1 do begin
  1460.     DisposeProc(Self, FProcs.GetItem(I));
  1461.   end;
  1462.   for I := 0 to Longint(FGlobalVars.Count) - 1 do begin
  1463.     DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FGlobalVars.GetItem(I));
  1464.   end;
  1465.   for I := 0 to Longint(FTypes.Count) - 1 do begin
  1466.     DisposeType(FTypes.GetItem(I));
  1467.   end;
  1468.   FStack.Clear;
  1469.   FProcs.Clear;
  1470.   FGlobalVars.Clear;
  1471.   FTypes.Clear;
  1472.   FStatus := isNotLoaded;
  1473.   FResources.Clear;
  1474.   FExportedVars.Clear;
  1475.   FExceptionStack.Clear;
  1476. end;
  1477.  
  1478. constructor TIFPSExec.Create;
  1479. begin
  1480.   inherited Create;
  1481. {$IFNDEF NOSMARTMM}MM := TIFVariantMemoryManager.Create;
  1482. {$ENDIF}
  1483.   FExceptionStack := TIfList.Create;
  1484.   FCallCleanup := False;
  1485.   FResources := TIfList.Create;
  1486.   FTypes := TIfList.Create;
  1487.   FProcs := TIfList.Create;
  1488.   FGlobalVars := TIfList.Create;
  1489.   FStack := TIfList.Create;
  1490.   FMainProc := 0;
  1491.   FStatus := isNotLoaded;
  1492.   FRegProcs := TIfList.Create;
  1493.   FExportedVars := TIfList.create;
  1494.   FSpecialProcList := TIfList.Create;
  1495. end;
  1496.  
  1497. destructor TIFPSExec.Destroy;
  1498. var
  1499.   I: Longint;
  1500.   P: PSpecialProc;
  1501. begin
  1502.   Clear;
  1503.   for I := FSpecialProcList.Count -1 downto 0 do
  1504.   begin
  1505.     P := FSpecialProcList.GetItem(I);
  1506.     Dispose(p);
  1507.   end;
  1508.   FStack.Free;
  1509.   FResources.Free;
  1510.   FExportedVars.Free;
  1511.   FGlobalVars.Free;
  1512.   FProcs.Free;
  1513.   FTypes.Free;
  1514.   FSpecialProcList.Free;
  1515.   ClearFunctionList;
  1516.  
  1517.   FRegProcs.Free;
  1518.   FExceptionStack.Free;
  1519. {$IFNDEF NOSMARTMM}TIFVariantMemoryManager(MM).Free;
  1520. {$ENDIF}
  1521.   inherited Destroy;
  1522. end;
  1523.  
  1524. procedure TIFPSExec.ExceptionProc(proc, Position: Cardinal; Ex: TIFError; const s: string);
  1525. var
  1526.   d, l: Longint;
  1527.   pp: PIFPSExceptionHandler;
  1528. begin
  1529.   ExProc := proc;
  1530.   ExPos := Position;
  1531.   ExEx := Ex;
  1532.   ExParam := s;
  1533.   if Ex = eNoError then Exit;
  1534.   for d := FExceptionStack.Count -1 downto 0 do
  1535.   begin
  1536.     pp := FExceptionStack.GetItem(d);
  1537.     if FStack.Count > pp^.StackSize then
  1538.     begin
  1539.       for l := Longint(FStack.count) -1 downto Longint(pp^.StackSize) do
  1540.       begin
  1541.         DisposeVariant({$IFNDEF SMARTMM}mm, {$ENDIF}FStack.GetItem(l));
  1542.         FStack.Delete(l);
  1543.       end;
  1544.     end;
  1545.     FCurrStackBase := pp^.BasePtr;
  1546.     if pp^.FinallyOffset <> cardinal(-1) then
  1547.     begin
  1548.       FCurrentPosition := pp^.FinallyOffset;
  1549.       pp^.FinallyOffset := cardinal(-1);
  1550.       Exit;
  1551.     end else if pp^.ExceptOffset <> cardinal(-1) then
  1552.     begin
  1553.       FCurrentPosition := pp^.ExceptOffset;
  1554.       pp^.ExceptOffset := cardinal(-1);
  1555.       Exit;
  1556.     end else if pp^.Finally2Offset <> Cardinal(-1) then
  1557.     begin
  1558.       FCurrentPosition := pp^.FinallyOffset;
  1559.       pp^.FinallyOffset := cardinal(-1);
  1560.       Exit;
  1561.     end;
  1562.     Dispose(pp);
  1563.     FExceptionStack.Delete(FExceptionStack.Count -1);
  1564.   end;
  1565.   FStatus := isPaused; 
  1566. end;
  1567.  
  1568. function TIFPSExec.ImportProc(const Name: ShortString; var proc: TIFProcRec): Boolean;
  1569. var
  1570.   u: PProcRec;
  1571.   fname: string;
  1572.   I, fnh: Longint;
  1573.   P: PSpecialProc;
  1574.  
  1575. begin
  1576.   if name = '' then
  1577.   begin
  1578.     fname := proc.ExportDecl;
  1579.     fname := copy(fname, 1, pos(':', fname)-1);
  1580.     fnh := MakeHash(fname);
  1581.     for I := FSpecialProcList.Count -1 downto 0 do
  1582.     begin
  1583.       p := FSpecialProcList.GetItem(I);
  1584.       IF (p^.name = '') or ((p^.namehash = fnh) and (p^.name = fname)) then
  1585.       begin
  1586.         if p^.P(Self, @Proc, p^.tag) then
  1587.         begin
  1588.           Result := True;
  1589.           exit;
  1590.         end;
  1591.       end;
  1592.     end;
  1593.     Result := FAlse;
  1594.     exit;
  1595.   end;
  1596.   u := LookupProc(FRegProcs, Name);
  1597.   if u = nil then begin
  1598.     Result := False;
  1599.     exit;
  1600.   end;
  1601.   proc.ProcPtr := u^.ProcPtr;
  1602.   proc.Ext1 := u^.Ext1;
  1603.   proc.Ext2 := u^.Ext2;
  1604.   Result := True;
  1605. end;
  1606.  
  1607. function TIFPSExec.RegisterFunctionName(const Name: ShortString; ProcPtr: TIFProc; Ext1, Ext2: Pointer): PProcRec;
  1608. var
  1609.   p: PProcRec;
  1610. begin
  1611.   if LookupProc(FRegProcs, Name) <> nil then begin
  1612.     Result :=  nil;
  1613.     exit;
  1614.   end;
  1615.   New(p);
  1616.   p^.Name := Name;
  1617.   p^.Hash := MakeHash(Name);
  1618.   p^.ProcPtr := ProcPtr;
  1619.   p^.FreeProc := nil;
  1620.   p^.Ext1 := Ext1;
  1621.   p^.Ext2 := Ext2;
  1622.   FRegProcs.Add(p);
  1623.   Result := P;
  1624. end;
  1625.  
  1626. function TIFPSExec.LoadData(const s: string): Boolean;
  1627. var
  1628.   HDR: TIFPSHeader;
  1629.   Pos: Cardinal;
  1630.  
  1631.   function read(var Data; Len: Cardinal): Boolean;
  1632.   begin
  1633.     if Longint(Pos + Len) <= Length(s) then begin
  1634.       Move(s[Pos + 1], Data, Len);
  1635.       Pos := Pos + Len;
  1636.       read := True;
  1637.     end
  1638.     else
  1639.       read := False;
  1640.   end;
  1641. {$WARNINGS OFF}
  1642.  
  1643.   function LoadTypes: Boolean;
  1644.   var
  1645.     currf: TIFPSType;
  1646.     Curr: PIFTypeRec;
  1647.     currr: PIFRecordType;
  1648.     fe: Boolean;
  1649.     l: Longint;
  1650.     d: Cardinal;
  1651.  
  1652.     function resolve(var s: string): Boolean;
  1653.     var
  1654.       l: Longint;
  1655.       p: PIFTypeRec;
  1656.     begin
  1657.       l := 1;
  1658.       while l < Length(s) do begin
  1659.         p := FTypes.GetItem(Cardinal(s[l]));
  1660.         if p = nil then begin
  1661.           Result := False;
  1662.           exit;
  1663.         end;
  1664.         PIFTypeRec((@s[l])^) := p;
  1665.         if p^.BaseType = btRecord then begin
  1666.           Delete(s, l, 4);
  1667.           insert(PIFRecordType(p^.Ext)^.Data, s, l);
  1668.         end;
  1669.         l := l + 4;
  1670.       end;
  1671.       Result := True;
  1672.     end;
  1673.   begin
  1674.     LoadTypes := True;
  1675.     for l := 0 to HDR.TypeCount - 1 do begin
  1676.       if not read(currf, SizeOf(currf)) then begin
  1677.         cmd_err(erUnexpectedEof);
  1678.         LoadTypes := False;
  1679.         exit;
  1680.       end;
  1681.       if (currf.BaseType and 128) <> 0 then begin
  1682.         fe := True;
  1683.         currf.BaseType := currf.BaseType - 128;
  1684.       end else
  1685.         fe := False;
  1686.       try
  1687.         New(Curr);
  1688.       except
  1689.         CMD_Err(erOutOfMemory);
  1690.         LoadTypes := False;
  1691.         exit;
  1692.       end;
  1693.       case currf.BaseType of
  1694.         {$IFNDEF NOINT64}bts64, {$ENDIF}
  1695.         btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble, btExtended, btString, btPointer, btPChar, btResourcePointer, btVariant: begin
  1696.             Curr^.BaseType := currf.BaseType;
  1697.             Curr^.Ext := nil;
  1698.             FTypes.Add(Curr);
  1699.           end;
  1700.         btArray: begin
  1701.             if not read(d, 4) then begin // Read type
  1702.               cmd_err(erUnexpectedEof);
  1703.               LoadTypes := False;
  1704.               exit;
  1705.             end;
  1706.             if (d >= FTypes.Count) then begin
  1707.               cmd_err(erTypeMismatch);
  1708.               LoadTypes := False;
  1709.               exit;
  1710.             end;
  1711.             Curr^.BaseType := currf.BaseType;
  1712.             Curr^.Ext := Pointer(d);
  1713.             FTypes.Add(Curr);
  1714.           end;
  1715.         btRecord: begin
  1716.             if not read(d, 4) or (d = 0) then begin
  1717.               cmd_err(erUnexpectedEof);
  1718.               LoadTypes := false;
  1719.               exit;
  1720.             end;
  1721.             try
  1722.               New(currr);
  1723.             except
  1724.               cmd_err(erOutOfMemory);
  1725.               LoadTypes := False;
  1726.               exit;
  1727.             end;
  1728.             SetLength(currr^.Data, d * 4);
  1729.             if not read(currr^.Data[1], d * 4) then begin
  1730.               currr^.Data := '';
  1731.               Dispose(currr);
  1732.               cmd_err(erUnexpectedEof);
  1733.               LoadTypes := False;
  1734.               exit;
  1735.             end;
  1736.             if not resolve(currr^.Data) then begin
  1737.               currr^.Data := '';
  1738.               Dispose(currr);
  1739.               cmd_err(erInvalidType);
  1740.               LoadTypes := False;
  1741.               exit;
  1742.             end;
  1743.             Curr^.BaseType := currf.BaseType;
  1744.             Curr^.Ext := currr;
  1745.             FTypes.Add(Curr);
  1746.           end;
  1747.       else begin
  1748.           LoadTypes := False;
  1749.           CMD_Err(erInvalidType);
  1750.           Dispose(Curr);
  1751.           exit;
  1752.         end;
  1753.       end;
  1754.       if fe then begin
  1755.         if not read(d, 4) then begin
  1756.           cmd_err(erUnexpectedEof);
  1757.           LoadTypes := False;
  1758.           exit;
  1759.         end;
  1760.         if d > IFPSAddrNegativeStackStart then begin
  1761.           cmd_err(erInvalidType);
  1762.           LoadTypes := False;
  1763.           exit;
  1764.         end;
  1765.         SetLength(Curr^.ExportName, d);
  1766.         if not read(Curr^.ExportName[1], d) then begin
  1767.           cmd_err(erUnexpectedEof);
  1768.           LoadTypes := False;
  1769.           exit;
  1770.         end;
  1771.         Curr^.ExportNameHash := MakeHash(Curr^.ExportName);
  1772.       end;
  1773.     end;
  1774.   end;
  1775.  
  1776.   function LoadProcs: Boolean;
  1777.   var
  1778.     Rec: TIFPSProc;
  1779.     n: string;
  1780.     b: Byte;
  1781.     l, L2, L3: Longint;
  1782.     Curr: PIFProcRec;
  1783.   begin
  1784.     LoadProcs := True;
  1785.     for l := 0 to HDR.ProcCount - 1 do begin
  1786.       if not read(Rec, SizeOf(Rec)) then begin
  1787.         cmd_err(erUnexpectedEof);
  1788.         LoadProcs := False;
  1789.         exit;
  1790.       end;
  1791.       try
  1792.         New(Curr);
  1793.       except
  1794.         cmd_err(erOutOfMemory);
  1795.         LoadProcs := False;
  1796.         exit;
  1797.       end;
  1798.       Curr^.ExternalProc := (Rec.Flags and 1) <> 0;
  1799.       if Curr^.ExternalProc then begin
  1800.         if not read(b, 1) then begin
  1801.           Dispose(Curr);
  1802.           cmd_err(erUnexpectedEof);
  1803.           LoadProcs := False;
  1804.           exit;
  1805.         end;
  1806.         SetLength(n, b);
  1807.         if not read(n[1], b) then begin
  1808.           Dispose(Curr);
  1809.           cmd_err(erUnexpectedEof);
  1810.           LoadProcs := False;
  1811.           exit;
  1812.         end;
  1813.         Curr^.Name := n;
  1814.         if (Rec.Flags and 3 = 3) then
  1815.         begin
  1816.           if (not Read(L2, 4)) or (L2 > Length(s) - Pos) then
  1817.           begin
  1818.             Dispose(Curr);
  1819.             cmd_err(erUnexpectedEof);
  1820.             LoadProcs := False;
  1821.             exit;
  1822.           end;
  1823.           SetLength(n, L2);
  1824.           Read(n[1], L2); // no check is needed
  1825.           Curr^.ExportDecl := n;
  1826.         end;
  1827.         if not ImportProc(Curr^.Name, Curr^) then begin
  1828.           if Curr^.Name <> '' then
  1829.             CMD_Err2(erCannotImport, Curr^.Name)
  1830.           else if Curr^.ExportDecl <> '' then
  1831.             CMD_Err2(erCannotImport, curr^.ExportDecl)
  1832.           else
  1833.             CMD_Err2(erCannotImport, curr^.ExportName);
  1834.           Dispose(Curr);
  1835.           LoadProcs := False;
  1836.           exit;
  1837.         end;
  1838.       end
  1839.       else begin
  1840.         if not read(L2, 4) then begin
  1841.           Dispose(Curr);
  1842.           cmd_err(erUnexpectedEof);
  1843.           LoadProcs := False;
  1844.           exit;
  1845.         end;
  1846.         if not read(L3, 4) then begin
  1847.           Dispose(Curr);
  1848.           cmd_err(erUnexpectedEof);
  1849.           LoadProcs := False;
  1850.           exit;
  1851.         end;
  1852.         if (L2 < 0) or (L2 >= Length(s)) or (L2 + L3 > Length(s)) then begin
  1853.           Dispose(Curr);
  1854.           cmd_err(erUnexpectedEof);
  1855.           LoadProcs := False;
  1856.           exit;
  1857.         end;
  1858.         GetMem(Curr^.Data, L3);
  1859.         Move(s[L2 + 1], Curr^.Data^, L3);
  1860.         Curr^.Length := L3;
  1861.         if (Rec.Flags and 2) <> 0 then begin // exported
  1862.           if not read(L3, 4) then begin
  1863.             Dispose(Curr);
  1864.             cmd_err(erUnexpectedEof);
  1865.             LoadProcs := False;
  1866.             exit;
  1867.           end;
  1868.           if L3 > IFPSAddrNegativeStackStart then begin
  1869.             Dispose(Curr);
  1870.             cmd_err(erUnexpectedEof);
  1871.             LoadProcs := False;
  1872.             exit;
  1873.           end;
  1874.           SetLength(Curr^.ExportName, L3);
  1875.           if not read(Curr^.ExportName[1], L3) then begin
  1876.             Dispose(Curr);
  1877.             cmd_err(erUnexpectedEof);
  1878.             LoadProcs := False;
  1879.             exit;
  1880.           end;
  1881.           if not read(L3, 4) then begin
  1882.             Dispose(Curr);
  1883.             cmd_err(erUnexpectedEof);
  1884.             LoadProcs := False;
  1885.             exit;
  1886.           end;
  1887.           if L3 > IFPSAddrNegativeStackStart then begin
  1888.             Dispose(Curr);
  1889.             cmd_err(erUnexpectedEof);
  1890.             LoadProcs := False;
  1891.             exit;
  1892.           end;
  1893.           SetLength(Curr^.ExportDecl, L3);
  1894.           if not read(Curr^.ExportDecl[1], L3) then begin
  1895.             Dispose(Curr);
  1896.             cmd_err(erUnexpectedEof);
  1897.             LoadProcs := False;
  1898.             exit;
  1899.           end;
  1900.           Curr^.ExportNameHash := MakeHash(Curr^.ExportName);
  1901.         end;
  1902.       end;
  1903.       FProcs.Add(Curr);
  1904.     end;
  1905.   end;
  1906. {$WARNINGS ON}
  1907.  
  1908.   function LoadVars: Boolean;
  1909.   var
  1910.     l, n: Longint;
  1911.     e: PIFPSExportedVar;
  1912.     Rec: TIFPSVar;
  1913.     Curr: PIfVariant;
  1914.   begin
  1915.     LoadVars := True;
  1916.     for l := 0 to HDR.VarCount - 1 do begin
  1917.       if not read(Rec, SizeOf(Rec)) then begin
  1918.         cmd_err(erUnexpectedEof);
  1919.         LoadVars := False;
  1920.         exit;
  1921.       end;
  1922.       if Rec.TypeNo >= HDR.TypeCount then begin
  1923.         cmd_err(erInvalidType);
  1924.         LoadVars := False;
  1925.         exit;
  1926.       end;
  1927.       Curr := CreateVariant({$IFNDEF NOSMARTMM}MM,
  1928. {$ENDIF}FTypes.GetItem(Rec.TypeNo));
  1929.       if Curr = nil then begin
  1930.         cmd_err(erInvalidType);
  1931.         LoadVars := False;
  1932.         exit;
  1933.       end;
  1934.       if (Rec.Flags and 1) <> 0then
  1935.       begin
  1936.         if not read(n, 4) then begin
  1937.           cmd_err(erUnexpectedEof);
  1938.           LoadVars := False;
  1939.           exit;
  1940.         end;
  1941.         new(e);
  1942.         try
  1943.           SetLength(e^.FName, n);
  1944.           if not Read(e^.FName[1], n) then
  1945.           begin
  1946.             dispose(e);
  1947.             cmd_err(erUnexpectedEof);
  1948.             LoadVars := False;
  1949.             exit;
  1950.           end;
  1951.           e^.FNameHash := MakeHash(e^.FName);
  1952.           e^.FVarNo := FGlobalVars.Count;
  1953.           FExportedVars.Add(E);
  1954.         except
  1955.           dispose(e);
  1956.           cmd_err(erInvalidType);
  1957.           LoadVars := False;
  1958.           exit;
  1959.         end;
  1960.       end;
  1961.       FGlobalVars.Add(Curr);
  1962.     end;
  1963.   end;
  1964.  
  1965. begin
  1966.   Clear;
  1967.   Pos := 0;
  1968.   LoadData := False;
  1969.   if not read(HDR, SizeOf(HDR)) then
  1970.   begin
  1971.     CMD_Err(erInvalidHeader);
  1972.     exit;
  1973.   end;
  1974.   if HDR.HDR <> IFPSValidHeader then
  1975.   begin
  1976.     CMD_Err(erInvalidHeader);
  1977.     exit;
  1978.   end;
  1979.   if (HDR.IFPSBuildNo > IFPSCurrentBuildNo) or (HDR.IFPSBuildNo < IFPSLowBuildSupport) then begin
  1980.     CMD_Err(erInvalidHeader);
  1981.     exit;
  1982.   end;
  1983.   if not LoadTypes then
  1984.   begin
  1985.     Clear;
  1986.     exit;
  1987.   end;
  1988.   if not LoadProcs then
  1989.   begin
  1990.     Clear;
  1991.     exit;
  1992.   end;
  1993.   if not LoadVars then
  1994.   begin
  1995.     Clear;
  1996.     exit;
  1997.   end;
  1998.   if (HDR.MainProcNo >= FProcs.Count) and (HDR.MainProcNo <> Cardinal(-1))then begin
  1999.     CMD_Err(erNoMainProc);
  2000.     Clear;
  2001.     exit;
  2002.   end;
  2003.   // Load Import Table
  2004.   FMainProc := HDR.MainProcNo;
  2005.   FStatus := isLoaded;
  2006.   Result := True;
  2007. end;
  2008.  
  2009. procedure TIFPSExec.Pause;
  2010. begin
  2011.   if FStatus = isRunning then
  2012.     FStatus := isPaused;
  2013. end;
  2014.  
  2015. function TIFPSExec.ReadData(var Data; Len: Cardinal): Boolean;
  2016. begin
  2017.   if FCurrentPosition + Len <= FCurrProc.Length then begin
  2018.     Move(FCurrProc.Data^[FCurrentPosition], Data, Len);
  2019.     FCurrentPosition := FCurrentPosition + Len;
  2020.     Result := True;
  2021.   end
  2022.   else
  2023.     Result := False;
  2024. end;
  2025.  
  2026. procedure TIFPSExec.CMD_Err(EC: TIFError); // Error
  2027. begin
  2028.   CMD_Err2(ec, '');
  2029. end;
  2030.  
  2031. function TIFPSExec.BuildArray(Dest, Src: PIFVariant): boolean;
  2032. var
  2033.   i, j: Longint;
  2034.   t: pbtrecord;
  2035. begin
  2036.   if (Src^.FType^.BaseType = btVariant) and (Src^.TVariant^.FType <> nil) and (Src^.TVariant^.FType^.BaseType = btArray) then
  2037.     Src := Src^.TVariant;
  2038.   if (Src^.FType^.BaseType <> btArray) and (Src^.FType^.BaseType <> btRecord) then
  2039.   begin
  2040.     Result := False;
  2041.     exit;
  2042.   end;
  2043.   if Dest^.TArray <> nil then
  2044.   begin
  2045.     for i := 0 to pbtrecord(Dest^.Tarray)^.FieldCount -1 do
  2046.     begin
  2047.       DisposeVariant({$IFNDEF NOSMARTMM}MM ,{$ENDIF}pbtrecord(Dest^.Tarray)^.fields[i]);
  2048.     end;
  2049.     FreeMem(pbtrecord(Dest^.Tarray), pbtrecord(Dest^.Tarray)^.FieldCount * 4 + 4);
  2050.   end;
  2051.   if src^.TArray = nil then
  2052.   begin
  2053.     Dest^.TArray := nil;
  2054.     Result := true;
  2055.     exit;
  2056.   end;
  2057.   try
  2058.     getmem(t, pbtRecord(src^.Tarray)^.FieldCount * 4 +4);
  2059.     t.FieldCount := pbtRecord(src^.Tarray)^.FieldCount;
  2060.   except
  2061.     Dest^.TArray := nil;
  2062.     Result := False;
  2063.     exit;
  2064.   end;
  2065.   for i := pbtRecord(src^.Tarray)^.FieldCount -1 downto 0 do
  2066.   begin
  2067.     t^.Fields[i] := CreateVariant({$IFNDEF NOSMARTMM}mm, {$ENDIF} pbtRecord(src^.Tarray)^.Fields[i]^.FType);
  2068.     if t^.Fields[i] = nil then
  2069.     begin
  2070.       Freemem(t, t^.FieldCount * 4 + 4);
  2071.       for j := 0 to i -1 do
  2072.       begin
  2073.         DisposeVariant({$IFNDEF NOSMARTMM}mm, {$ENDIF} t^.Fields[j]);
  2074.       end;
  2075.       Dest^.TArray := nil;
  2076.       Result := False;
  2077.       exit;
  2078.     end;
  2079.     if not SetVariantValue(t^.Fields[i], pbtRecord(src^.Tarray)^.Fields[i]) then
  2080.     begin
  2081.       for j := pbtRecord(src^.Tarray)^.FieldCount -1 downto i do
  2082.       begin
  2083.         DisposeVariant({$IFNDEF NOSMARTMM}mm, {$ENDIF} t^.Fields[j]);
  2084.       end;
  2085.       Freemem(t, t^.FieldCount * 4 + 4);
  2086.       Dest^.TArray := nil;
  2087.       Result := False;
  2088.       exit;
  2089.     end;
  2090.   end;
  2091.   dest^.TArray := t;
  2092.  
  2093.   Result := True;
  2094. end;
  2095.  
  2096. function TIFPSExec.SetVariantValue(dest, Src: PIfVariant): Boolean;
  2097. begin
  2098.   Result := True;
  2099.   case dest^.FType^.BaseType of
  2100.     btU8: dest^.tu8 := GetUInt(Src, Result);
  2101.     btS8: dest^.tS8 := GetInt(Src, Result);
  2102.     btU16: dest^.tu16 := GetUInt(Src, Result);
  2103.     btS16: dest^.ts16 := GetInt(Src, Result);
  2104.     btU32: dest^.tu32 := GetUInt(Src, Result);
  2105.     btS32: dest^.ts32 := GetInt(Src, Result);
  2106.     {$IFNDEF NOINT64}
  2107.     btS64: dest^.ts64 := GetInt64(Src, Result);
  2108.     {$ENDIF}
  2109.     btSingle: dest^.tsingle := GetReal(Src, Result);
  2110.     btDouble: dest^.tdouble := GetReal(Src, Result);
  2111.     btExtended: dest^.textended := GetReal(Src, Result);
  2112.     btPChar,btString: TbtString((@dest^.tstring)^) := GetString(Src, Result);
  2113.     btArray, btRecord: Result := BuildArray(Dest, Src);
  2114.     btVariant:
  2115.     begin
  2116.       if Src^.FType^.BaseType = btVariant then
  2117.         ChangeVariantType({$IFNDEF NOSMARTMM}mm, {$ENDIF}Dest^.tVariant, src^.TVariant^.FType)
  2118.       else
  2119.         ChangeVariantType({$IFNDEF NOSMARTMM}mm, {$ENDIF}Dest^.tVariant, src^.FType);
  2120.       if Dest^.tvariant = nil then
  2121.       begin
  2122.         Result := False;
  2123.       end else begin
  2124.         if Dest^.TVariant^.FType <> nil then
  2125.         begin
  2126.           if Src^.FType^.BaseType = btVariant then
  2127.             Result := SetVariantValue(Dest^.TVariant, Src^.tvariant)
  2128.           else
  2129.             Result := SetVariantValue(Dest^.TVariant, Src);
  2130.         end;
  2131.       end;
  2132.     end;
  2133.     btResourcePointer:
  2134.     begin
  2135.       if src^.Ftype^.BaseType = btvariant then
  2136.       begin
  2137.         Src := src^.tvariant;
  2138.         if src^.FType = nil then
  2139.         begin
  2140.           Result := False;
  2141.           exit;
  2142.         end;
  2143.       end;
  2144.       if Src^.FType^.BaseType <> btResourcePointer then
  2145.       begin
  2146.         Result := False;
  2147.         exit;
  2148.       end;
  2149.       if @Src^.tResourceFreeProc <> nil then
  2150.       begin
  2151.         Result := Src^.tResourceFreeProc(vrfDuplicate, Src, Dest);
  2152.       end else begin
  2153.         Dest^.TResourceFreeProc := nil;
  2154.         Dest^.TResourceP1 := nil;
  2155.         Dest^.TResourceP2 := nil;
  2156.       end;
  2157.     end;
  2158.   else begin
  2159.       Result := False;
  2160.     end;
  2161.   end;
  2162.   if Result = False then
  2163.     CMD_Err(ErTypeMismatch);
  2164. end;
  2165.  
  2166. function TIFPSExec.DoBooleanCalc(var1, Var2: PIfVariant; Into: PIfVariant; Cmd:
  2167.   Cardinal): Boolean;
  2168. var
  2169.   b: Boolean;
  2170.  
  2171.   procedure SetBoolean(b: Boolean; var Ok: Boolean);
  2172.   begin
  2173.     Ok := True;
  2174.     case Into^.FType^.BaseType of
  2175.       btU8: Into^.tu8 := Cardinal(b);
  2176.       btS8: Into^.tS8 := Longint(b);
  2177.       btU16: Into^.tu16 := Cardinal(b);
  2178.       btS16: Into^.ts16 := Longint(b);
  2179.       btU32: Into^.tu32 := Cardinal(b);
  2180.       btS32: Into^.ts32 := Longint(b);
  2181.     else begin
  2182.         CMD_Err(ErTypeMismatch);
  2183.         Ok := False;
  2184.       end;
  2185.     end;
  2186.   end;
  2187. begin
  2188.   Result := True;
  2189.   if (var1^.FType = nil) and (var1^.FType = nil) then {variants}
  2190.   begin
  2191.     case Cmd of
  2192.       0,1,2,3: Result := False; 
  2193.       4: SetBoolean(False, Result); { <> }
  2194.       5: SetBoolean(True, Result); { = }
  2195.     else begin
  2196.         Result := False;
  2197.         CMD_Err(erInvalidOpcodeParameter);
  2198.         exit;
  2199.       end;
  2200.     end;
  2201.     if not Result then begin
  2202.       CMD_Err(erTypeMismatch);
  2203.       exit;
  2204.     end;
  2205.   end else
  2206.   if (var1^.FType = nil) xor (var2^.FType = nil) then {variants}
  2207.   begin
  2208.     case Cmd of
  2209.       0,1,2,3: Result := False; 
  2210.       4: SetBoolean(True, Result); { <> }
  2211.       5: SetBoolean(False, Result); { = }
  2212.     else begin
  2213.         Result := False;
  2214.         CMD_Err(erInvalidOpcodeParameter);
  2215.         exit;
  2216.       end;
  2217.     end;
  2218.     if not Result then begin
  2219.       CMD_Err(erTypeMismatch);
  2220.       exit;
  2221.     end;
  2222.   end else
  2223.   case Cmd of
  2224.     0: begin { >= }
  2225.         case var1^.FType^.BaseType of
  2226.           btU8:
  2227.           if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
  2228.             b := char(var1^.tu8) >= GetString(Var2, Result)
  2229.           else
  2230.             b := var1^.tu8 >= GetUInt(Var2, Result);
  2231.           btS8: b := var1^.tS8 >= GetInt(Var2, Result);
  2232.           btU16: b := var1^.tu16 >= GetUInt(Var2, Result);
  2233.           btS16: b := var1^.ts16 >= GetInt(Var2, Result);
  2234.           btU32: b := var1^.tu32 >= GetUInt(Var2, Result);
  2235.           btS32: b := var1^.ts32 >= GetInt(Var2, Result);
  2236.           btSingle: b := var1^.tsingle >= GetReal(Var2, Result);
  2237.           btDouble: b := var1^.tdouble >= GetReal(Var2, Result);
  2238.           btExtended: b := var1^.textended >= GetReal(Var2, Result);
  2239.           {$IFNDEF NOINT64}
  2240.           btS64: b := var1^.ts64 >= GetInt64(Var2, Result);
  2241.           {$ENDIF}
  2242.           btPChar,btString: b := tbtstring(var1^.tstring) >= GetString(Var2, Result);
  2243.         else begin
  2244.             CMD_Err(ErTypeMismatch);
  2245.             exit;
  2246.           end;
  2247.         end;
  2248.         if not Result then begin
  2249.           CMD_Err(ErTypeMismatch);
  2250.           exit;
  2251.         end;
  2252.         SetBoolean(b, Result);
  2253.       end;
  2254.     1: begin { <= }
  2255.         case var1^.FType^.BaseType of
  2256.           btU8:
  2257.           if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
  2258.             b := char(var1^.tu8) <= GetString(Var2, Result)
  2259.           else
  2260.             b := var1^.tu8 <= GetUInt(Var2, Result);
  2261.           btS8: b := var1^.tS8 <= GetInt(Var2, Result);
  2262.           btU16: b := var1^.tu16 <= GetUInt(Var2, Result);
  2263.           btS16: b := var1^.ts16 <= GetInt(Var2, Result);
  2264.           btU32: b := var1^.tu32 <= GetUInt(Var2, Result);
  2265.           btS32: b := var1^.ts32 <= GetInt(Var2, Result);
  2266.           btSingle: b := var1^.tsingle <= GetReal(Var2, Result);
  2267.           btDouble: b := var1^.tdouble <= GetReal(Var2, Result);
  2268.           btExtended: b := var1^.textended <= GetReal(Var2, Result);
  2269.           {$IFNDEF NOINT64}
  2270.           btS64: b := var1^.ts64 <= GetInt64(Var2, Result);
  2271.           {$ENDIF}
  2272.           btPChar,btString: b := tbtstring(var1^.tstring) <= GetString(Var2, Result);
  2273.         else begin
  2274.             CMD_Err(ErTypeMismatch);
  2275.             exit;
  2276.           end;
  2277.         end;
  2278.         if not Result then begin
  2279.           CMD_Err(erTypeMismatch);
  2280.           exit;
  2281.         end;
  2282.         SetBoolean(b, Result);
  2283.       end;
  2284.     2: begin { > }
  2285.         case var1^.FType^.BaseType of
  2286.           btU8:
  2287.           if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
  2288.             b := char(var1^.tu8) > GetString(Var2, Result)
  2289.           else
  2290.             b := var1^.tu8 > GetUInt(Var2, Result);
  2291.           btS8: b := var1^.tS8 > GetInt(Var2, Result);
  2292.           btU16: b := var1^.tu16 > GetUInt(Var2, Result);
  2293.           btS16: b := var1^.ts16 > GetInt(Var2, Result);
  2294.           btU32: b := var1^.tu32 > GetUInt(Var2, Result);
  2295.           btS32: b := var1^.ts32 > GetInt(Var2, Result);
  2296.           btSingle: b := var1^.tsingle > GetReal(Var2, Result);
  2297.           btDouble: b := var1^.tdouble > GetReal(Var2, Result);
  2298.           btExtended: b := var1^.textended > GetReal(Var2, Result);
  2299.           {$IFNDEF NOINT64}
  2300.           btS64: b := var1^.ts64 > GetInt64(Var2, Result);
  2301.           {$ENDIF}
  2302.           btPChar,btString: b := tbtstring(var1^.tstring) > GetString(Var2, Result);
  2303.         else begin
  2304.             CMD_Err(erTypeMismatch);
  2305.             exit;
  2306.           end;
  2307.         end;
  2308.         if not Result then begin
  2309.           CMD_Err(erTypeMismatch);
  2310.           exit;
  2311.         end;
  2312.         SetBoolean(b, Result);
  2313.       end;
  2314.     3: begin { < }
  2315.         case var1^.FType^.BaseType of
  2316.           btU8:
  2317.           if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
  2318.             b := char(var1^.tu8) < GetString(Var2, Result)
  2319.           else
  2320.             b := var1^.tu8 < GetUInt(Var2, Result);
  2321.           btS8: b := var1^.tS8 < GetInt(Var2, Result);
  2322.           btU16: b := var1^.tu16 < GetUInt(Var2, Result);
  2323.           btS16: b := var1^.ts16 < GetInt(Var2, Result);
  2324.           btU32: b := var1^.tu32 < GetUInt(Var2, Result);
  2325.           btS32: b := var1^.ts32 < GetInt(Var2, Result);
  2326.           btSingle: b := var1^.tsingle < GetReal(Var2, Result);
  2327.           btDouble: b := var1^.tdouble < GetReal(Var2, Result);
  2328.           btExtended: b := var1^.textended < GetReal(Var2, Result);
  2329.           {$IFNDEF NOINT64}
  2330.           btS64: b := var1^.ts64 < GetInt64(Var2, Result);
  2331.           {$ENDIF}
  2332.           btPChar,btString: b := tbtstring(var1^.tstring) < GetString(Var2, Result);
  2333.         else begin
  2334.             CMD_Err(erTypeMismatch);
  2335.             exit;
  2336.           end;
  2337.         end;
  2338.         if not Result then begin
  2339.           CMD_Err(erTypeMismatch);
  2340.           exit;
  2341.         end;
  2342.         SetBoolean(b, Result);
  2343.       end;
  2344.     4: begin { <> }
  2345.         case var1^.FType^.BaseType of
  2346.           btU8:
  2347.           if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
  2348.             b := char(var1^.tu8) <> GetString(Var2, Result)
  2349.           else
  2350.             b := var1^.tu8 <> GetUInt(Var2, Result);
  2351.           btS8: b := var1^.tS8 <> GetInt(Var2, Result);
  2352.           btU16: b := var1^.tu16 <> GetUInt(Var2, Result);
  2353.           btS16: b := var1^.ts16 <> GetInt(Var2, Result);
  2354.           btU32: b := var1^.tu32 <> GetUInt(Var2, Result);
  2355.           btS32: b := var1^.ts32 <> GetInt(Var2, Result);
  2356.           btSingle: b := var1^.tsingle <> GetReal(Var2, Result);
  2357.           btDouble: b := var1^.tdouble <> GetReal(Var2, Result);
  2358.           btExtended: b := var1^.textended <> GetReal(Var2, Result);
  2359.           btPChar,btString: b := TbtString(var1^.tstring) <> GetString(Var2, Result);
  2360.           {$IFNDEF NOINT64}
  2361.           btS64: b := var1^.ts64 <> GetInt64(Var2, Result);
  2362.           {$ENDIF}
  2363.         else begin
  2364.             CMD_Err(erTypeMismatch);
  2365.             exit;
  2366.           end;
  2367.         end;
  2368.         if not Result then begin
  2369.           CMD_Err(erTypeMismatch);
  2370.           exit;
  2371.         end;
  2372.         SetBoolean(b, Result);
  2373.       end;
  2374.     5: begin { = }
  2375.         case var1^.FType^.BaseType of
  2376.           btU8:
  2377.           if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
  2378.             b := char(var1^.tu8) = GetString(Var2, Result)
  2379.           else
  2380.             b := var1^.tu8 = GetUInt(Var2, Result);
  2381.           btS8: b := var1^.tS8 = GetInt(Var2, Result);
  2382.           btU16: b := var1^.tu16 = GetUInt(Var2, Result);
  2383.           btS16: b := var1^.ts16 = GetInt(Var2, Result);
  2384.           btU32: b := var1^.tu32 = GetUInt(Var2, Result);
  2385.           btS32: b := var1^.ts32 = GetInt(Var2, Result);
  2386.           btSingle: b := var1^.tsingle = GetReal(Var2, Result);
  2387.           btDouble: b := var1^.tdouble = GetReal(Var2, Result);
  2388.           btExtended: b := var1^.textended = GetReal(Var2, Result);
  2389.           btPchar, btString: b := TbtString(var1^.tstring) = GetString(Var2, Result);
  2390.           {$IFNDEF NOINT64}
  2391.           btS64: b := var1^.ts64 = GetInt64(Var2, Result);
  2392.           {$ENDIF}
  2393.         else begin
  2394.             CMD_Err(erTypeMismatch);
  2395.             exit;
  2396.           end;
  2397.         end;
  2398.         if not Result then begin
  2399.           CMD_Err(erTypeMismatch);
  2400.           exit;
  2401.         end;
  2402.         SetBoolean(b, Result);
  2403.       end;
  2404.   else begin
  2405.       Result := False;
  2406.       CMD_Err(erInvalidOpcodeParameter);
  2407.       exit;
  2408.     end;
  2409.   end;
  2410. end;
  2411.  
  2412. function TIFPSExec.DoCalc(var1, Var2: PIfVariant; CalcType: Cardinal): Boolean;
  2413.     { var1=dest, var2=src }
  2414. begin
  2415.   try
  2416.     Result := True;
  2417.     case CalcType of
  2418.       0: begin { + }
  2419.           case var1^.FType^.BaseType of
  2420.             btU8: var1^.tu8 := var1^.tu8 + GetUInt(Var2, Result);
  2421.             btS8: var1^.tS8 := var1^.tS8 + GetInt(Var2, Result);
  2422.             btU16: var1^.tu16 := var1^.tu16 + GetUInt(Var2, Result);
  2423.             btS16: var1^.ts16 := var1^.ts16 + GetInt(Var2, Result);
  2424.             btU32: var1^.tu32 := var1^.tu32 + GetUInt(Var2, Result);
  2425.             btS32: var1^.ts32 := var1^.ts32 + GetInt(Var2, Result);
  2426.            {$IFNDEF NOINT64}
  2427.             btS64:  var1^.ts64 := var1^.ts64 + GetInt64(var2, Result);
  2428.            {$ENDIF}
  2429.             btSingle: var1^.tsingle := var1^.tsingle + GetReal(Var2, Result);
  2430.             btDouble: var1^.tdouble := var1^.tdouble + GetReal(Var2, Result);
  2431.             btExtended: var1^.textended := var1^.textended + GetReal(Var2,
  2432.                 Result);
  2433.             btPchar, btString: TbtString((@var1^.tstring)^) :=
  2434.               TbtString((@var1^.tstring)^) + GetString(Var2, Result);
  2435.           else begin
  2436.               CMD_Err(erTypeMismatch);
  2437.               exit;
  2438.             end;
  2439.           end;
  2440.           if not Result then begin
  2441.             CMD_Err(erTypeMismatch);
  2442.             exit;
  2443.           end;
  2444.         end;
  2445.       1: begin { - }
  2446.           case var1^.FType^.BaseType of
  2447.             btU8: var1^.tu8 := var1^.tu8 - GetUInt(Var2, Result);
  2448.             btS8: var1^.tS8 := var1^.tS8 - GetInt(Var2, Result);
  2449.             btU16: var1^.tu16 := var1^.tu16 - GetUInt(Var2, Result);
  2450.             btS16: var1^.ts16 := var1^.ts16 - GetInt(Var2, Result);
  2451.             btU32: var1^.tu32 := var1^.tu32 - GetUInt(Var2, Result);
  2452.             btS32: var1^.ts32 := var1^.ts32 - GetInt(Var2, Result);
  2453.            {$IFNDEF NOINT64}
  2454.             btS64: var1^.ts64 := var1^.ts64 - GetInt64(var2, Result);
  2455.            {$ENDIF}
  2456.             btSingle: var1^.tsingle := var1^.tsingle - GetReal(Var2, Result);
  2457.             btDouble: var1^.tdouble := var1^.tdouble - GetReal(Var2, Result);
  2458.             btExtended: var1^.textended := var1^.textended - GetReal(Var2,
  2459.                 Result);
  2460.           else begin
  2461.               CMD_Err(erTypeMismatch);
  2462.               exit;
  2463.             end;
  2464.           end;
  2465.           if not Result then begin
  2466.             CMD_Err(erTypeMismatch);
  2467.             exit;
  2468.           end;
  2469.         end;
  2470.       2: begin { * }
  2471.           case var1^.FType^.BaseType of
  2472.             btU8: var1^.tu8 := var1^.tu8 * GetUInt(Var2, Result);
  2473.             btS8: var1^.tS8 := var1^.tS8 * GetInt(Var2, Result);
  2474.             btU16: var1^.tu16 := var1^.tu16 * GetUInt(Var2, Result);
  2475.             btS16: var1^.ts16 := var1^.ts16 * GetInt(Var2, Result);
  2476.             btU32: var1^.tu32 := var1^.tu32 * GetUInt(Var2, Result);
  2477.             btS32: var1^.ts32 := var1^.ts32 * GetInt(Var2, Result);
  2478.            {$IFNDEF NOINT64}
  2479.             btS64: var1^.ts64 := var1^.ts64 * GetInt64(var2, Result);
  2480.            {$ENDIF}
  2481.             btSingle: var1^.tsingle := var1^.tsingle * GetReal(Var2, Result);
  2482.             btDouble: var1^.tdouble := var1^.tdouble * GetReal(Var2, Result);
  2483.             btExtended: var1^.textended := var1^.textended * GetReal(Var2,
  2484.                 Result);
  2485.           else begin
  2486.               CMD_Err(erTypeMismatch);
  2487.               exit;
  2488.             end;
  2489.           end;
  2490.           if not Result then begin
  2491.             CMD_Err(erTypeMismatch);
  2492.             exit;
  2493.           end;
  2494.         end;
  2495.       3: begin { / }
  2496.           case var1^.FType^.BaseType of
  2497.             btU8: var1^.tu8 := var1^.tu8 div GetUInt(Var2, Result);
  2498.             btS8: var1^.tS8 := var1^.tS8 div GetInt(Var2, Result);
  2499.             btU16: var1^.tu16 := var1^.tu16 div GetUInt(Var2, Result);
  2500.             btS16: var1^.ts16 := var1^.ts16 div GetInt(Var2, Result);
  2501.             btU32: var1^.tu32 := var1^.tu32 div GetUInt(Var2, Result);
  2502.             btS32: var1^.ts32 := var1^.ts32 div GetInt(Var2, Result);
  2503.            {$IFNDEF NOINT64}
  2504.             btS64: var1^.ts64 := var1^.ts64 div GetInt64(var2, Result);
  2505.            {$ENDIF}
  2506.             btSingle: var1^.tsingle := var1^.tsingle / GetReal(Var2, Result);
  2507.             btDouble: var1^.tdouble := var1^.tdouble / GetReal(Var2, Result);
  2508.             btExtended: var1^.textended := var1^.textended / GetReal(Var2, Result);
  2509.           else begin
  2510.               CMD_Err(erTypeMismatch);
  2511.               exit;
  2512.             end;
  2513.           end;
  2514.           if not Result then begin
  2515.             CMD_Err(erTypeMismatch);
  2516.             exit;
  2517.           end;
  2518.         end;
  2519.       4: begin { MOD }
  2520.           case var1^.FType^.BaseType of
  2521.             btU8: var1^.tu8 := var1^.tu8 mod GetUInt(Var2, Result);
  2522.             btS8: var1^.tS8 := var1^.tS8 mod GetInt(Var2, Result);
  2523.             btU16: var1^.tu16 := var1^.tu16 mod GetUInt(Var2, Result);
  2524.             btS16: var1^.ts16 := var1^.ts16 mod GetInt(Var2, Result);
  2525.             btU32: var1^.tu32 := var1^.tu32 mod GetUInt(Var2, Result);
  2526.             btS32: var1^.ts32 := var1^.ts32 mod GetInt(Var2, Result);
  2527.            {$IFNDEF NOINT64}
  2528.             btS64: var1^.ts64 := var1^.ts64 mod GetInt64(var2, Result);
  2529.            {$ENDIF}
  2530.           else begin
  2531.               CMD_Err(erTypeMismatch);
  2532.               exit;
  2533.             end;
  2534.           end;
  2535.           if not Result then begin
  2536.             CMD_Err(erTypeMismatch);
  2537.             exit;
  2538.           end;
  2539.         end;
  2540.       5: begin { SHL }
  2541.           case var1^.FType^.BaseType of
  2542.             btU8: var1^.tu8 := var1^.tu8 shl GetUInt(Var2, Result);
  2543.             btS8: var1^.tS8 := var1^.tS8 shl GetInt(Var2, Result);
  2544.             btU16: var1^.tu16 := var1^.tu16 shl GetUInt(Var2, Result);
  2545.             btS16: var1^.ts16 := var1^.ts16 shl GetInt(Var2, Result);
  2546.             btU32: var1^.tu32 := var1^.tu32 shl GetUInt(Var2, Result);
  2547.             btS32: var1^.ts32 := var1^.ts32 shl GetInt(Var2, Result);
  2548.            {$IFNDEF NOINT64}
  2549.             btS64: var1^.ts64 := var1^.ts64 shl GetInt64(var2, Result);
  2550.            {$ENDIF}
  2551.           else begin
  2552.               CMD_Err(erTypeMismatch);
  2553.               exit;
  2554.             end;
  2555.           end;
  2556.           if not Result then begin
  2557.             CMD_Err(erTypeMismatch);
  2558.             exit;
  2559.           end;
  2560.         end;
  2561.       6: begin { SHR }
  2562.           case var1^.FType^.BaseType of
  2563.             btU8: var1^.tu8 := var1^.tu8 shr GetUInt(Var2, Result);
  2564.             btS8: var1^.tS8 := var1^.tS8 shr GetInt(Var2, Result);
  2565.             btU16: var1^.tu16 := var1^.tu16 shr GetUInt(Var2, Result);
  2566.             btS16: var1^.ts16 := var1^.ts16 shr GetInt(Var2, Result);
  2567.             btU32: var1^.tu32 := var1^.tu32 shr GetUInt(Var2, Result);
  2568.             btS32: var1^.ts32 := var1^.ts32 shr GetInt(Var2, Result);
  2569.            {$IFNDEF NOINT64}
  2570.             btS64: var1^.ts64 := var1^.ts64 shr GetInt64(var2, Result);
  2571.            {$ENDIF}
  2572.           else begin
  2573.               CMD_Err(erTypeMismatch);
  2574.               exit;
  2575.             end;
  2576.           end;
  2577.           if not Result then begin
  2578.             CMD_Err(erTypeMismatch);
  2579.             exit;
  2580.           end;
  2581.         end;
  2582.       7: begin { AND }
  2583.           case var1^.FType^.BaseType of
  2584.             btU8: var1^.tu8 := var1^.tu8 and GetUInt(Var2, Result);
  2585.             btS8: var1^.tS8 := var1^.tS8 and GetInt(Var2, Result);
  2586.             btU16: var1^.tu16 := var1^.tu16 and GetUInt(Var2, Result);
  2587.             btS16: var1^.ts16 := var1^.ts16 and GetInt(Var2, Result);
  2588.             btU32: var1^.tu32 := var1^.tu32 and GetUInt(Var2, Result);
  2589.             btS32: var1^.ts32 := var1^.ts32 and GetInt(Var2, Result);
  2590.            {$IFNDEF NOINT64}
  2591.             btS64: var1^.ts64 := var1^.ts64 and GetInt64(var2, Result);
  2592.            {$ENDIF}
  2593.           else begin
  2594.               CMD_Err(erTypeMismatch);
  2595.               exit;
  2596.             end;
  2597.           end;
  2598.           if not Result then begin
  2599.             CMD_Err(erTypeMismatch);
  2600.             exit;
  2601.           end;
  2602.         end;
  2603.       8: begin { OR }
  2604.           case var1^.FType^.BaseType of
  2605.             btU8: var1^.tu8 := var1^.tu8 or GetUInt(Var2, Result);
  2606.             btS8: var1^.tS8 := var1^.tS8 or GetInt(Var2, Result);
  2607.             btU16: var1^.tu16 := var1^.tu16 or GetUInt(Var2, Result);
  2608.             btS16: var1^.ts16 := var1^.ts16 or GetInt(Var2, Result);
  2609.             btU32: var1^.tu32 := var1^.tu32 or GetUInt(Var2, Result);
  2610.             btS32: var1^.ts32 := var1^.ts32 or GetInt(Var2, Result);
  2611.            {$IFNDEF NOINT64}
  2612.             btS64: var1^.ts64 := var1^.ts64 or GetInt64(var2, Result);
  2613.            {$ENDIF}
  2614.           else begin
  2615.               CMD_Err(erTypeMismatch);
  2616.               exit;
  2617.             end;
  2618.           end;
  2619.           if not Result then begin
  2620.             CMD_Err(erTypeMismatch);
  2621.             exit;
  2622.           end;
  2623.         end;
  2624.       9: begin { XOR }
  2625.           case var1^.FType^.BaseType of
  2626.             btU8: var1^.tu8 := var1^.tu8 xor GetUInt(Var2, Result);
  2627.             btS8: var1^.tS8 := var1^.tS8 xor GetInt(Var2, Result);
  2628.             btU16: var1^.tu16 := var1^.tu16 xor GetUInt(Var2, Result);
  2629.             btS16: var1^.ts16 := var1^.ts16 xor GetInt(Var2, Result);
  2630.             btU32: var1^.tu32 := var1^.tu32 xor GetUInt(Var2, Result);
  2631.             btS32: var1^.ts32 := var1^.ts32 xor GetInt(Var2, Result);
  2632.            {$IFNDEF NOINT64}
  2633.             btS64: var1^.ts64 := var1^.ts64 xor GetInt64(var2, Result);
  2634.            {$ENDIF}
  2635.           else begin
  2636.               CMD_Err(erTypeMismatch);
  2637.               exit;
  2638.             end;
  2639.           end;
  2640.           if not Result then begin
  2641.             CMD_Err(erTypeMismatch);
  2642.             exit;
  2643.           end;
  2644.         end;
  2645.     else begin
  2646.         Result := False;
  2647.         CMD_Err(erInvalidOpcodeParameter);
  2648.         exit;
  2649.       end;
  2650.     end;
  2651.   except
  2652.     on E: EDivByZero do
  2653.     begin
  2654.       Result := False;
  2655.       CMD_Err(erDivideByZero);
  2656.       Exit;
  2657.     end;
  2658.     on E: EZeroDivide do
  2659.     begin
  2660.       Result := False;
  2661.       CMD_Err(erDivideByZero);
  2662.       Exit;
  2663.     end;
  2664.     on E: EMathError do
  2665.     begin
  2666.       Result := False;
  2667.       CMD_Err(erMathError);
  2668.       Exit;
  2669.     end;
  2670.     on E: Exception do
  2671.     begin
  2672.       Result := False;
  2673.       CMD_Err2(erException, e.Message);
  2674.       exit;
  2675.     end;
  2676.   end;
  2677. end;
  2678.  
  2679. function TIFPSExec.ReadVariable(var NeedToFree: LongBool; UsePointer: LongBool): PIfVariant;
  2680. var
  2681.   VarType: Cardinal;
  2682.   Param: Cardinal;
  2683.   Tmp: PIfVariant;
  2684.  
  2685. begin
  2686.   if not (ReadByte(VarType) and ReadLong(Param)) then begin
  2687.     CMD_Err(erOutOfRange);
  2688.     Result := nil;
  2689.     exit;
  2690.   end;
  2691.   case VarType of
  2692.     0: begin
  2693.         NeedToFree := False;
  2694.         if Param < IFPSAddrNegativeStackStart then begin
  2695.           Result := FGlobalVars.GetItem(Param);
  2696.           if Result = nil then begin
  2697.             CMD_Err(erOutOfGlobalVarsRange);
  2698.             exit;
  2699.           end;
  2700.         end
  2701.         else begin
  2702.           Result := FStack.GetItem(Cardinal(Longint(-IFPSAddrStackStart) +
  2703.             Longint(FCurrStackBase) + Longint(Param)));
  2704.           if Result = nil then begin
  2705.             CMD_Err(erOutOfStackRange);
  2706.             exit;
  2707.           end;
  2708.         end;
  2709.         if UsePointer then
  2710.         begin
  2711.           if Result^.FType^.BaseType = btPointer then begin
  2712.             Result := Result^.tPointer;
  2713.             if Result = nil then begin
  2714.               CMD_Err(erNullPointerException);
  2715.               exit;
  2716.             end;
  2717.           end;
  2718.           if Result^.FType^.BaseType = btVariant then begin
  2719.             Result := Result^.tvariant;         
  2720.             if Result = nil then begin
  2721.               CMD_Err(erNullPointerException);
  2722.               exit;
  2723.             end;
  2724.             if Result^.FType = nil then
  2725.             begin
  2726.               Result := nil;
  2727.               CMD_Err(erNullVariantError);
  2728.               Exit;
  2729.             end;
  2730.           end;
  2731.         end;
  2732.       end;
  2733.     1: begin
  2734.         NeedToFree := True;
  2735.         Result := CreateVariant({$IFNDEF NOSMARTMM}MM,
  2736. {$ENDIF}FTypes.GetItem(Param));
  2737.         if Result = nil then begin
  2738.           CMD_Err(erInvalidType);
  2739.           exit;
  2740.         end;
  2741.         case Result^.FType^.BaseType of
  2742.           btU8: if not ReadData(Result^.tu8, 1) then begin
  2743.               CMD_Err(erOutOfRange);
  2744.               DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
  2745.               Result := nil;
  2746.               exit;
  2747.             end;
  2748.           btS8: if not ReadData(Result^.tS8, 1) then begin
  2749.               CMD_Err(erOutOfRange);
  2750.               DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
  2751.               Result := nil;
  2752.               exit;
  2753.             end;
  2754.           btU16: if not ReadData((@Result^.tu16)^, SizeOf(TbtU16)) then begin
  2755.               CMD_Err(ErOutOfRange);
  2756.               DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
  2757.               Result := nil;
  2758.               exit;
  2759.             end;
  2760.           btS16: if not ReadData((@Result^.ts16)^, SizeOf(TbtS16)) then begin
  2761.               CMD_Err(ErOutOfRange);
  2762.               DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
  2763.               Result := nil;
  2764.               exit;
  2765.             end;
  2766.           btU32: if not ReadLong(Result^.tu32) then begin
  2767.               CMD_Err(erOutOfRange);
  2768.               DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
  2769.               Result := nil;
  2770.               exit;
  2771.             end;
  2772.           btS32: if not ReadLong(Cardinal(Result^.ts32)) then begin
  2773.               CMD_Err(erOutOfRange);
  2774.               DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
  2775.               Result := nil;
  2776.               exit;
  2777.             end;
  2778.           {$IFNDEF NOINT64}
  2779.           bts64: if not ReadData(Result^.ts64, sizeof(tbts64)) then
  2780.             begin
  2781.               CMD_Err(erOutOfRange);
  2782.               DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
  2783.               Result := nil;
  2784.               exit;
  2785.             end;
  2786.           {$ENDIF}
  2787.           btSingle: if not ReadData((@Result^.tsingle)^, SizeOf(TbtSingle))
  2788.             then begin
  2789.               CMD_Err(erOutOfRange);
  2790.               DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
  2791.               Result := nil;
  2792.               exit;
  2793.             end;
  2794.           btDouble: if not ReadData((@Result^.tdouble)^, SizeOf(TbtDouble))
  2795.             then begin
  2796.               CMD_Err(erOutOfRange);
  2797.               DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
  2798.               Result := nil;
  2799.               exit;
  2800.             end;
  2801.           btExtended: if not ReadData((@Result^.textended)^,
  2802.               SizeOf(TbtExtended)) then begin
  2803.               CMD_Err(erOutOfRange);
  2804.               DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
  2805.               Result := nil;
  2806.               exit;
  2807.             end;
  2808.           btPchar, btString: begin
  2809.               if not ReadLong(Param) then begin
  2810.                 CMD_Err(erOutOfRange);
  2811.                 DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
  2812.                 Result := nil;
  2813.                 exit;
  2814.               end;
  2815.               SetLength(TbtString((@Result^.tstring)^), Param);
  2816.               if not ReadData(TbtString((@Result^.tstring)^)[1], Param) then begin
  2817.                 CMD_Err(erOutOfRange);
  2818.                 DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
  2819.                 Result := nil;
  2820.                 exit;
  2821.               end;
  2822.             end;
  2823.         else begin
  2824.             CMD_Err(erInvalidType);
  2825.             DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Result);
  2826.             Result := nil;
  2827.             exit;
  2828.           end;
  2829.         end;
  2830.       end;
  2831.     2: begin
  2832.         NeedToFree := False;
  2833.         if Param < IFPSAddrNegativeStackStart then begin
  2834.           Result := FGlobalVars.GetItem(Param);
  2835.           if Result = nil then begin
  2836.             CMD_Err(erOutOfGlobalVarsRange);
  2837.             exit;
  2838.           end;
  2839.         end
  2840.         else begin
  2841.           Result := FStack.GetItem(Cardinal(Longint(-IFPSAddrStackStart) +
  2842.             Longint(FCurrStackBase) + Longint(Param)));
  2843.           if Result = nil then begin
  2844.             CMD_Err(erOutOfStackRange);
  2845.             exit;
  2846.  
  2847.           end;
  2848.         end;
  2849.         if (Result^.FType^.BaseType = btPointer) then begin
  2850.           Result := Result^.tPointer;
  2851.           if Result = nil then begin
  2852.             CMD_Err(erNullPointerException);
  2853.             exit;
  2854.           end;
  2855.         end;
  2856.         if Result^.FType^.BaseType = btVariant then begin
  2857.           Result := Result^.tvariant;
  2858.           if Result = nil then begin
  2859.             CMD_Err(erNullPointerException);
  2860.             exit;
  2861.           end;
  2862.           if Result^.FType = nil then
  2863.           begin
  2864.             Result := nil;
  2865.             CMD_Err(erNullVariantError);
  2866.             Exit;
  2867.           end;
  2868.         end;
  2869.         if (Result^.FType^.BaseType <> btRecord) and (Result^.FType^.BaseType <> btArray) then begin
  2870.           CMD_Err(erInvalidType);
  2871.           Result := nil;
  2872.           exit;
  2873.         end;
  2874.         if not ReadLong(Param) then begin
  2875.           CMD_Err(erOutOfRange);
  2876.           Result := nil;
  2877.           exit;
  2878.         end;
  2879.         if (Result^.trecord = nil) or (Param >= pbtrecord(Result^.trecord)^.FieldCount) then begin
  2880.           CMD_Err(erOutofRecordRange);
  2881.           Result := nil;
  2882.           exit;
  2883.         end;
  2884.         Result := pbtrecord(Result^.trecord)^.Fields[Param];
  2885.         if UsePointer then
  2886.         begin
  2887.           if Result^.FType^.BaseType = btPointer then begin
  2888.             Result := Result^.tPointer;
  2889.             if Result = nil then begin
  2890.               CMD_Err(erNullPointerException);
  2891.               exit;
  2892.             end;
  2893.           end;
  2894.           if Result^.FType^.BaseType = btVariant then begin
  2895.             Result := Result^.tvariant;
  2896.             if Result = nil then begin
  2897.               CMD_Err(erNullPointerException);
  2898.               exit;
  2899.             end;
  2900.             if Result^.FType = nil then
  2901.             begin
  2902.               Result := nil;
  2903.               CMD_Err(erNullVariantError);
  2904.               Exit;
  2905.             end;
  2906.           end;
  2907.         end;
  2908.       end;
  2909.     3: begin
  2910.         NeedToFree := False;
  2911.         if Param < IFPSAddrNegativeStackStart then begin
  2912.           Result := FGlobalVars.GetItem(Param);
  2913.           if Result = nil then begin
  2914.             CMD_Err(erOutOfGlobalVarsRange);
  2915.             exit;
  2916.           end;
  2917.         end
  2918.         else begin
  2919.           Result := FStack.GetItem(Cardinal(Longint(-IFPSAddrStackStart) +
  2920.             Longint(FCurrStackBase) + Longint(Param)));
  2921.           if Result = nil then begin
  2922.             CMD_Err(erOutOfStackRange);
  2923.             exit;
  2924.           end;
  2925.         end;
  2926.         if (Result^.FType^.BaseType = btPointer) then begin
  2927.           Result := Result^.tPointer;
  2928.           if Result = nil then begin
  2929.             CMD_Err(erNullPointerException);
  2930.             exit;
  2931.           end;
  2932.         end;
  2933.         if Result^.FType^.BaseType = btVariant then begin
  2934.           Result := Result^.tvariant;
  2935.           if Result = nil then begin
  2936.             CMD_Err(erNullPointerException);
  2937.             exit;
  2938.           end;
  2939.           if Result^.FType = nil then
  2940.           begin
  2941.             Result := nil;
  2942.             CMD_Err(erNullVariantError);
  2943.             Exit;
  2944.           end;
  2945.         end;
  2946.         if (Result^.FType^.BaseType <> btRecord) and (Result^.FType^.BaseType <> btArray) then begin
  2947.           CMD_Err(erInvalidType);
  2948.           Result := nil;
  2949.           exit;
  2950.         end;
  2951.         if not ReadLong(Param) then begin
  2952.           CMD_Err(erOutOfRange);
  2953.           Result := nil;
  2954.           exit;
  2955.         end;
  2956.         if Param < IFPSAddrNegativeStackStart then begin
  2957.           Tmp := FGlobalVars.GetItem(Param);
  2958.           if Tmp = nil then begin
  2959.             CMD_Err(erOutOfGlobalVarsRange);
  2960.             exit;
  2961.           end;
  2962.         end
  2963.         else begin
  2964.           Tmp := FStack.GetItem(Cardinal(Longint(-IFPSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param)));
  2965.           if Tmp = nil then begin
  2966.             CMD_Err(erOutOfStackRange);
  2967.             exit;
  2968.           end;
  2969.         end;
  2970.         case Tmp^.FType^.BaseType of
  2971.           btu8: Param := Tmp^.tu8;
  2972.           bts8: Param := Tmp^.ts8;
  2973.           btu16: Param := Tmp^.tu16;
  2974.           bts16: Param := Tmp^.ts16;
  2975.           btu32: Param := Tmp^.tu32;
  2976.           bts32: Param := Tmp^.ts32;
  2977.         else
  2978.           CMD_Err(ErTypeMismatch);
  2979.           exit;
  2980.         end;
  2981.  
  2982.         if (Result^.trecord = nil) or (Param >= pbtrecord(Result^.trecord)^.FieldCount) then begin
  2983.           CMD_Err(erOutofRecordRange);
  2984.           Result := nil;
  2985.           exit;
  2986.         end;
  2987.         Result := pbtrecord(Result^.trecord)^.Fields[Param];
  2988.         if UsePointer then
  2989.         begin
  2990.           if Result^.FType^.BaseType = btPointer then begin
  2991.             Result := Result^.tPointer;
  2992.             if Result = nil then begin
  2993.               CMD_Err(erNullPointerException);
  2994.               exit;
  2995.             end;
  2996.           end;
  2997.           if Result^.FType^.BaseType = btVariant then begin
  2998.             if Result = nil then begin
  2999.               CMD_Err(erNullPointerException);
  3000.               exit;
  3001.             end;
  3002.             if Result^.FType = nil then
  3003.             begin
  3004.               Result := nil;
  3005.               CMD_Err(erNullVariantError);
  3006.               Exit;
  3007.             end;
  3008.           end;
  3009.         end;
  3010.       end;
  3011.   else
  3012.     Result := nil;
  3013.   end;
  3014. end;
  3015.  
  3016. procedure TIFPSExec.DoMinus(Vd: PIfVariant);
  3017. begin
  3018.   case Vd^.FType^.BaseType of
  3019.     btU8: Vd^.tu8 := -Vd^.tu8;
  3020.     btU16: Vd^.tu8 := -Vd^.tu16;
  3021.     btU32: Vd^.tu8 := -Vd^.tu32;
  3022.     btS8: Vd^.tS8 := -Vd^.tS8;
  3023.     btS16: Vd^.ts16 := -Vd^.ts16;
  3024.     btS32: Vd^.ts32 := -Vd^.ts32;
  3025.     btSingle: Vd^.tsingle := - vd^.tsingle;
  3026.     btDouble: Vd^.tdouble := -vd^.tdouble;
  3027.     btExtended: Vd^.textended := -vd^.textended;
  3028.   else
  3029.     CMD_Err(erTypeMismatch);
  3030.   end;
  3031. end;
  3032.  
  3033. procedure TIFPSExec.DoBooleanNot(Vd: PIfVariant);
  3034. begin
  3035.   case Vd^.FType^.BaseType of
  3036.     btU8: Vd^.tu8 := TbtU8(Vd^.tu8 = 0);
  3037.     btS8: Vd^.tS8 := TbtS8(Vd^.tS8 = 0);
  3038.     btU16: Vd^.tu16 := TbtU16(Vd^.tu16 = 0);
  3039.     btS16: Vd^.ts16 := TbtS16(Vd^.ts16 = 0);
  3040.     btU32: Vd^.tu32 := TbtU32(Vd^.tu32 = 0);
  3041.     btS32: Vd^.ts32 := TbtS32(Vd^.ts32 = 0);
  3042.   else
  3043.     CMD_Err(erTypeMismatch);
  3044.   end;
  3045. end;
  3046.  
  3047. function TIFPSExec.RunScript: Boolean;
  3048. var
  3049.   CalcType: Cardinal;
  3050.   Vd, Vs, v3: PIfVariant;
  3051.   vdFree, vsFree: LongBool;
  3052.   p: Cardinal;
  3053.   P2: Longint;
  3054.   u: PIFProcRec;
  3055.   Cmd: Cardinal;
  3056.   I: Longint;
  3057.   pp: PIFPSExceptionHandler;
  3058.   FExitPoint: Cardinal;
  3059.  
  3060. begin
  3061.   FExitPoint := Cardinal(-1);
  3062.   for i := FExceptionStack.Count -1 downto 0 do
  3063.   begin
  3064.     pp := FExceptionStack.GetItem(i);
  3065.     Dispose(pp);
  3066.   end;
  3067.   FExceptionStack.Clear;
  3068.   ExceptionProc(Cardinal(-1), Cardinal(-1), erNoError, '');
  3069.   RunScript := True;
  3070.   case FStatus of
  3071.     isLoaded: begin
  3072.         if FMainProc = Cardinal(-1) then
  3073.         begin
  3074.           RunScript := False;
  3075.           exit;
  3076.         end;
  3077.         FStatus := isRunning;
  3078.         FCurrProc := FProcs.GetItem(FMainProc);
  3079.         if FCurrProc^.ExternalProc then begin
  3080.           CMD_Err(erNoMainProc);
  3081.           FStatus := isLoaded;
  3082.           exit;
  3083.         end;
  3084.         FCurrStackBase := Cardinal(-1);
  3085.         FCurrentPosition := 0;
  3086.       end;
  3087.     isPaused: begin
  3088.         FStatus := isRunning;
  3089.       end;
  3090.   else begin
  3091.       RunScript := False;
  3092.       exit;
  3093.     end;
  3094.   end;
  3095.   RunLine;
  3096.   repeat
  3097.     FStatus := isRunning;
  3098.     while FStatus = isRunning do begin
  3099.       if not ReadByte(Cmd) then
  3100.         CMD_Err(erOutOfRange) // Error
  3101.       else begin
  3102.         if Cmd = CM_CA then begin // Calc and assigning are needed most and have priority
  3103.           if not ReadByte(CalcType) then begin
  3104.             CMD_Err(erOutOfRange);
  3105.             break;
  3106.           end;
  3107.           Vd := ReadVariable(vdFree, True);
  3108.           if Vd = nil then
  3109.             break;
  3110.           if vdFree then begin
  3111.             DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
  3112.             CMD_Err(erInvalidOpcodeParameter);
  3113.             break;
  3114.           end;
  3115.           Vs := ReadVariable(vsFree, True);
  3116.           if Vs = nil then
  3117.             break;
  3118.           if not DoCalc(Vd, Vs, CalcType) then Break;
  3119.           if vsFree then
  3120.             DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
  3121.         end
  3122.         else if Cmd = CM_A then begin // Calc and assigning are needed most and have priority
  3123.           Vd := ReadVariable(vdFree, False);
  3124.           if Vd = nil then
  3125.             break;
  3126.           if vdFree then begin
  3127.             DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
  3128.             CMD_Err(erInvalidOpcodeParameter);
  3129.             break;
  3130.           end;
  3131.           if vd^.FType^.BaseType = btPointer then
  3132.           begin
  3133.             vd := vd^.tPointer;
  3134.             if vd = nil then
  3135.             begin
  3136.               CMD_Err(erNullPointerException);
  3137.               Break;
  3138.             end;
  3139.           end;
  3140.           Vs := ReadVariable(vsFree, False);
  3141.           if Vs = nil then
  3142.             break;
  3143.           if vs^.FType^.BaseType = btPointer then begin
  3144.             v3 := vs^.tPointer;
  3145.             if v3 = nil then begin
  3146.               if vsFree then
  3147.               begin
  3148.                 DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
  3149.               end;
  3150.               CMD_Err(erNullPointerException);
  3151.               Break;
  3152.             end;
  3153.             vs := v3;
  3154.           end;
  3155.           if not SetVariantValue(Vd, Vs) then
  3156.           begin
  3157.             if vsFree then
  3158.               DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
  3159.             cmd_err(erTypeMismatch);
  3160.             Break;
  3161.           end;
  3162.           if vsFree then
  3163.             DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
  3164.         end
  3165.         else
  3166.           case Cmd of
  3167.             CM_P: begin
  3168.                 Vs := ReadVariable(vsFree, True);
  3169.                 if Vs = nil then
  3170.                   break;
  3171.                 if vsFree then begin
  3172.                   FStack.Add(Vs);
  3173.                 end
  3174.                 else begin
  3175.                   Vd := CreateVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs^.FType);
  3176.                   SetVariantValue(Vd, Vs);
  3177.                   FStack.Add(Vd);
  3178.                 end;
  3179.               end;
  3180.             CM_PV: begin
  3181.                 Vs := ReadVariable(vsFree, False);
  3182.                 if vs^.FType^.BaseType = btPointer then
  3183.                 begin
  3184.                   vs := vs^.tPointer;
  3185.                   if vs = nil then
  3186.                   begin
  3187.                     CMD_Err(erNullPointerException);
  3188.                     break;
  3189.                   end;
  3190.                 end;
  3191.  
  3192.                 if Vs = nil then
  3193.                   break;
  3194.                 if vsFree then begin
  3195.                   DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
  3196.                   CMD_Err(erInvalidOpcodeParameter);
  3197.                   break;
  3198.                 end
  3199.                 else begin
  3200.                   Inc(Vs^.RefCount);
  3201.                   FStack.Add(Vs);
  3202.                 end;
  3203.               end;
  3204.             CM_PO: begin
  3205.                 if FStack.Count = 0 then begin
  3206.                   CMD_Err(erOutOfStackRange);
  3207.                   break;
  3208.                 end;
  3209.                 Vs := FStack.GetItem(FStack.Count - 1);
  3210.                 FStack.Delete(FStack.Count - 1);
  3211.                 DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
  3212.               end;
  3213.             Cm_C: begin
  3214.                 if not ReadLong(p) then begin
  3215.                   CMD_Err(erOutOfRange);
  3216.                   break;
  3217.                 end;
  3218.                 if p >= FProcs.Count then begin
  3219.                   CMD_Err(erOutOfProcRange);
  3220.                   break;
  3221.                 end;
  3222.                 u := FProcs.GetItem(p);
  3223.                 if u^.ExternalProc then begin
  3224.                   if not u^.ProcPtr(Self, u, FGlobalVars, FStack) then
  3225.                     CMD_Err(erCouldNotCallProc);
  3226.                 end
  3227.                 else begin
  3228.                   Vd := CreateVariant({$IFNDEF NOSMARTMM}MM,
  3229.   {$ENDIF}@ReturnAddressType);
  3230.                   Vd^.treturnaddress.ProcNo := FCurrProc;
  3231.                   Vd^.treturnaddress.Position := FCurrentPosition;
  3232.                   Vd^.treturnaddress.StackBase := FCurrStackBase;
  3233.                   FStack.Add(Vd);
  3234.  
  3235.                   FCurrStackBase := FStack.Count - 1;
  3236.                   FCurrProc := u;
  3237.                   FCurrentPosition := 0;
  3238.                 end;
  3239.               end;
  3240.             Cm_G: begin
  3241.                 if not ReadLong(p) then begin
  3242.                   CMD_Err(erOutOfRange);
  3243.                   break;
  3244.                 end;
  3245.                 FCurrentPosition := FCurrentPosition + p;
  3246.               end;
  3247.             Cm_CG: begin
  3248.                 if not ReadLong(p) then begin
  3249.                   CMD_Err(erOutOfRange);
  3250.                   break;
  3251.                 end;
  3252.                 Vs := ReadVariable(vsFree, True);
  3253.                 if Vs = nil then
  3254.                   break;
  3255.                 if vsFree then begin
  3256.                   CMD_Err(erInvalidOpcodeParameter);
  3257.                   break;
  3258.                 end;
  3259.                 case Vs^.FType^.BaseType of
  3260.                   btU8: vdFree := Vs^.tu8 <> 0;
  3261.                   btS8: vdFree := Vs^.tS8 <> 0;
  3262.                   btU16: vdFree := Vs^.tu16 <> 0;
  3263.                   btS16: vdFree := Vs^.ts16 <> 0;
  3264.                   btU32: vdFree := Vs^.tu32 <> 0;
  3265.                   btS32: vdFree := Vs^.ts32 <> 0;
  3266.                 else begin
  3267.                     CMD_Err(erInvalidType);
  3268.                     break;
  3269.                   end;
  3270.                 end;
  3271.                 if vdFree then
  3272.                   FCurrentPosition := FCurrentPosition + p;
  3273.               end;
  3274.             Cm_CNG: begin
  3275.                 if not ReadLong(p) then begin
  3276.                   CMD_Err(erOutOfRange);
  3277.                   break;
  3278.                 end;
  3279.                 Vs := ReadVariable(vsFree, True);
  3280.                 if Vs = nil then
  3281.                   break;
  3282.                 if vsFree then begin
  3283.                   CMD_Err(erInvalidOpcodeParameter);
  3284.                   break;
  3285.                 end;
  3286.                 case Vs^.FType^.BaseType of
  3287.                   btU8: vdFree := Vs^.tu8 = 0;
  3288.                   btS8: vdFree := Vs^.tS8 = 0;
  3289.                   btU16: vdFree := Vs^.tu16 = 0;
  3290.                   btS16: vdFree := Vs^.ts16 = 0;
  3291.                   btU32: vdFree := Vs^.tu32 = 0;
  3292.                   btS32: vdFree := Vs^.ts32 = 0;
  3293.                 else begin
  3294.                     CMD_Err(erInvalidType);
  3295.                     break;
  3296.                   end;
  3297.                 end;
  3298.                 if vdFree then
  3299.                   FCurrentPosition := FCurrentPosition + p;
  3300.               end;
  3301.             Cm_R: begin
  3302.                 FExitPoint := FCurrentPosition -1;
  3303.                 P2 := 0;
  3304.                 if FExceptionStack.Count > 0 then
  3305.                 begin
  3306.                   pp := FExceptionStack.GetItem(FExceptionStack.Count -1);
  3307.                   if pp^.BasePtr >= FCurrStackBase then
  3308.                   begin
  3309.                     if pp^.StackSize < FStack.Count then
  3310.                     begin
  3311.                       for p := Longint(FStack.count) -1 downto Longint(pp^.StackSize) do
  3312.                       begin
  3313.                         DisposeVariant({$IFNDEF SMARTMM}mm, {$ENDIF}FStack.GetItem(p));
  3314.                         FStack.Delete(p);
  3315.                       end;
  3316.                     end;
  3317.                     FCurrStackBase := pp^.BasePtr;
  3318.                     if pp^.FinallyOffset <> Cardinal(-1) then
  3319.                     begin
  3320.                       FCurrentPosition := pp^.FinallyOffset;
  3321.                       pp^.FinallyOffset := cardinal(-1);
  3322.                       p2 := 1;
  3323.                     end else if pp^.Finally2Offset <> Cardinal(-1) then
  3324.                     begin
  3325.                       FCurrentPosition := pp^.Finally2Offset;
  3326.                       pp^.Finally2Offset := cardinal(-1);
  3327.                       p2 := 1;
  3328.                     end;
  3329.                   end;
  3330.                 end;
  3331.                 if p2 = 0 then
  3332.                 begin
  3333.                   FExitPoint := Cardinal(-1);
  3334.                   Vs := FStack.GetItem(FCurrStackBase);
  3335.                   if Vs = nil then begin
  3336.                     FStatus := isLoaded;
  3337.                     break;
  3338.                   end;
  3339.                   for P2 := FStack.Count - 1 downto FCurrStackBase + 1 do begin
  3340.                     DisposeVariant({$IFNDEF NOSMARTMM}MM,
  3341.     {$ENDIF}FStack.GetItem(P2));
  3342.                     FStack.Delete(P2);
  3343.                   end;
  3344.                   FStack.Delete(FCurrStackBase);
  3345.                   FCurrProc := Vs^.treturnaddress.ProcNo;
  3346.                   FCurrentPosition := Vs^.treturnaddress.Position;
  3347.                   FCurrStackBase := Vs^.treturnaddress.StackBase;
  3348.                   DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
  3349.                   if FCurrProc = nil then begin
  3350.                     FStatus := isPaused;
  3351.                     break;
  3352.                   end;
  3353.                 end;
  3354.               end;
  3355.             Cm_ST: begin
  3356.                 if not ReadLong(p) or not ReadLong(Cardinal(P2)) then begin
  3357.                   CMD_Err(erOutOfRange);
  3358.                   break;
  3359.                 end;
  3360.                 Cardinal(P2) := FCurrStackBase + Cardinal(P2);
  3361.                 if p >= FTypes.Count then begin
  3362.                   CMD_Err(erInvalidType);
  3363.                   break;
  3364.                 end;
  3365.                 if Cardinal(P2) >= FStack.Count then begin
  3366.                   CMD_Err(erOutOfStackRange);
  3367.                   break;
  3368.                 end;
  3369.                 Vs := FStack.GetItem(Cardinal(P2));
  3370.                 if Vs^.FType = @ReturnAddressType then begin
  3371.                   CMD_Err(erInvalidType);
  3372.                   break;
  3373.                 end;
  3374.                 DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
  3375.                 Vs := CreateVariant({$IFNDEF NOSMARTMM}MM,
  3376.   {$ENDIF}FTypes.GetItem(p));
  3377.                 FStack.SetItem(Cardinal(P2), Vs);
  3378.               end;
  3379.             Cm_Pt: begin
  3380.                 if not ReadLong(p) then begin
  3381.                   CMD_Err(erInvalidType);
  3382.                   break;
  3383.                 end;
  3384.                 Vs := CreateVariant({$IFNDEF NOSMARTMM}MM,
  3385.   {$ENDIF}FTypes.GetItem(p));
  3386.                 if Vs = nil then begin
  3387.                   CMD_Err(erInvalidType);
  3388.                   break;
  3389.                 end;
  3390.                 FStack.Add(Vs);
  3391.               end;
  3392.             CM_CO: begin
  3393.                 if not ReadByte(CalcType) then begin
  3394.                   CMD_Err(erOutOfRange);
  3395.                   break;
  3396.                 end;
  3397.                 v3 := ReadVariable(vsFree, True);
  3398.                 if v3 = nil then
  3399.                   break;
  3400.                 if vsFree then begin
  3401.                   DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}v3);
  3402.                   CMD_Err(erInvalidOpcodeParameter);
  3403.                   break;
  3404.                 end;
  3405.                 Vs := ReadVariable(vsFree, False);
  3406.                 if Vs = nil then
  3407.                   break;
  3408.                 if vs^.FType^.BaseType = btPointer then begin
  3409.                   vs := vs^.tPointer;
  3410.                   if vs = nil then begin
  3411.                     CMD_Err(erNullPointerException);
  3412.                     break;
  3413.                   end;
  3414.                 end;
  3415.                 if vs^.FType^.BaseType = btVariant then begin
  3416.                   vs := vs^.tvariant;
  3417.                 end;
  3418.                 Vd := ReadVariable(vdFree, False);
  3419.                 if vd^.FType^.BaseType = btPointer then begin
  3420.                   vd := vs^.tPointer;
  3421.                   if vd = nil then begin
  3422.                     CMD_Err(erNullPointerException);
  3423.                     break;
  3424.                   end;
  3425.                 end;
  3426.                 if vd^.FType^.BaseType = btVariant then begin
  3427.                   vd := vd^.tvariant;
  3428.                 end;
  3429.                 if Vd = nil then begin
  3430.                   if vsFree then
  3431.                     DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
  3432.                   break;
  3433.                 end;
  3434.                 DoBooleanCalc(Vs, Vd, v3, CalcType);
  3435.                 if vsFree then
  3436.                   DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
  3437.                 if vdFree then
  3438.                   DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
  3439.               end;
  3440.             Cm_cv: begin
  3441.                 Vd := ReadVariable(vdFree, True);
  3442.                 if Vd = nil then
  3443.                   break;
  3444.                 if (Vd^.FType^.BaseType <> btU32) and (Vd^.FType^.BaseType <>
  3445.                   btS32) then begin
  3446.                   if vdFree then
  3447.                     DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
  3448.                   CMD_Err(ErTypeMismatch);
  3449.                   break;
  3450.                 end;
  3451.                 p := Vd^.tu32;
  3452.                 if vdFree then
  3453.                   DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
  3454.                 if (p >= FProcs.Count) or (p = FMainProc) then begin
  3455.                   CMD_Err(erOutOfProcRange);
  3456.                   break;
  3457.                 end;
  3458.                 u := FProcs.GetItem(p);
  3459.                 if u^.ExternalProc then begin
  3460.                   if not u^.ProcPtr(Self, u, FGlobalVars, FStack) then
  3461.                     CMD_Err(erCouldNotCallProc);
  3462.                 end
  3463.                 else begin
  3464.                   Vs := CreateVariant({$IFNDEF NOSMARTMM}MM,
  3465.   {$ENDIF}@ReturnAddressType);
  3466.                   Vs^.treturnaddress.ProcNo := FCurrProc;
  3467.                   Vs^.treturnaddress.Position := FCurrentPosition;
  3468.                   Vs^.treturnaddress.StackBase := FCurrStackBase;
  3469.                   FStack.Add(Vs);
  3470.                   FCurrStackBase := FStack.Count - 1;
  3471.                   FCurrProc := u;
  3472.                   FCurrentPosition := 0;
  3473.                 end;
  3474.               end;
  3475.             cm_sp: begin
  3476.                 Vd := ReadVariable(vdFree, False);
  3477.                 if Vd = nil then
  3478.                   break;
  3479.                 if vdFree then begin
  3480.                   DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
  3481.                   CMD_Err(erInvalidOpcodeParameter);
  3482.                   break;
  3483.                 end;
  3484.                 if Vd^.FType^.BaseType <> btPointer then begin
  3485.                   CMD_Err(erInvalidOpcodeParameter);
  3486.                   break;
  3487.                 end;
  3488.                 if (Vd^.tPointer <> nil) then
  3489.                   DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd^.tPointer);
  3490.                 Vs := ReadVariable(vsFree, False);
  3491.                 if Vs = nil then begin
  3492.                   Vd^.tPointer := nil;
  3493.                 end else if vsFree then begin
  3494.                   DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vs);
  3495.                   CMD_Err(erInvalidOpcodeParameter);
  3496.                   break;
  3497.                 end else begin
  3498.                   Inc(Vs^.RefCount);
  3499.                   Vd^.tPointer := Vs;
  3500.                 end;
  3501.               end;
  3502.             cm_bn: begin
  3503.                 Vd := ReadVariable(vdFree, False);
  3504.                 if Vd = nil then
  3505.                   break;
  3506.                 if vdFree then begin
  3507.                   DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
  3508.                   CMD_Err(erInvalidOpcodeParameter);
  3509.                   break;
  3510.                 end;
  3511.                 DoBooleanNot(Vd);
  3512.               end;
  3513.             cm_vm: begin
  3514.                 Vd := ReadVariable(vdFree, False);
  3515.                 if Vd = nil then
  3516.                   break;
  3517.                 if vdFree then begin
  3518.                   DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
  3519.                   CMD_Err(erInvalidOpcodeParameter);
  3520.                   break;
  3521.                 end;
  3522.                 DoMinus(Vd);
  3523.               end;
  3524.             cm_sf:
  3525.               begin
  3526.                 vd := ReadVariable(vdFree, True);
  3527.                 if vd = nil then
  3528.                   break;
  3529.                 if vdFree then
  3530.                 begin
  3531.                   DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}vd);
  3532.                   CMD_Err(erInvalidOpcodeParameter);
  3533.                   break;
  3534.                 end;
  3535.                 if not ReadByte(p) then
  3536.                 begin
  3537.                   CMD_Err(erOutOfRange);
  3538.                   Break;
  3539.                 end;
  3540.                 case Vd^.FType^.BaseType of
  3541.                   btU8: vdFree := Vd^.tu8 <> 0;
  3542.                   btS8: vdFree := Vd^.tS8 <> 0;
  3543.                   btU16: vdFree := Vd^.tu16 <> 0;
  3544.                    btS16: vdFree := Vd^.ts16 <> 0;
  3545.                   btU32: vdFree := Vd^.tu32 <> 0;
  3546.                   btS32: vdFree := Vd^.ts32 <> 0;
  3547.                 else begin
  3548.                     CMD_Err(erInvalidType);
  3549.                     break;
  3550.                   end;
  3551.                 end;
  3552.                 if p <> 0 then
  3553.                   FJumpFlag := not vdFree
  3554.                 else
  3555.                  FJumpFlag := vdFree;
  3556.               end;
  3557.             cm_fg:
  3558.               begin
  3559.                 if not ReadLong(p) then begin
  3560.                   CMD_Err(erOutOfRange);
  3561.                   break;
  3562.                 end;
  3563.                 if FJumpFlag then
  3564.                   FCurrentPosition := FCurrentPosition + p;
  3565.               end;
  3566.             cm_puexh:
  3567.               begin
  3568.                 New(pp);
  3569.                 pp^.BasePtr :=FCurrStackBase;
  3570.                 pp^.StackSize := FStack.Count;
  3571.                 if not ReadLong(pp^.FinallyOffset) then begin
  3572.                   CMD_Err(erOutOfRange);
  3573.                   Dispose(pp);
  3574.                   Break;
  3575.                 end;
  3576.                 if not ReadLong(pp^.ExceptOffset) then begin
  3577.                   CMD_Err(erOutOfRange);
  3578.                   Dispose(pp);
  3579.                   Break;
  3580.                 end;
  3581.                 if not ReadLong(pp^.Finally2Offset) then begin
  3582.                   CMD_Err(erOutOfRange);
  3583.                   Dispose(pp);
  3584.                   Break;
  3585.                 end;
  3586.                 if not ReadLong(pp^.EndOfBlock) then begin
  3587.                   CMD_Err(erOutOfRange);
  3588.                   Dispose(pp);
  3589.                   Break;
  3590.                 end;
  3591.                 if pp^.FinallyOffset <> Cardinal(-1) then
  3592.                   pp^.FinallyOffset := pp^.FinallyOffset + FCurrentPosition;
  3593.                 if pp^.ExceptOffset <> Cardinal(-1) then
  3594.                   pp^.ExceptOffset := pp^.ExceptOffset + FCurrentPosition;
  3595.                 if pp^.Finally2Offset <> Cardinal(-1) then
  3596.                   pp^.Finally2Offset := pp^.Finally2Offset + FCurrentPosition;
  3597.                 if pp^.EndOfBlock <> Cardinal(-1) then
  3598.                   pp^.EndOfBlock := pp^.EndOfBlock + FCurrentPosition;
  3599.                 if ((pp^.FinallyOffset <> cardinal(-1)) and (pp^.FinallyOffset >= FCurrProc^.Length)) or
  3600.                   ((pp^.ExceptOffset <> cardinal(-1)) and (pp^.ExceptOffset >= FCurrProc^.Length)) or
  3601.                   ((pp^.Finally2Offset <> cardinal(-1)) and (pp^.Finally2Offset >= FCurrProc^.Length)) or
  3602.                   ((pp^.EndOfBlock <> cardinal(-1)) and (pp^.EndOfBlock >= FCurrProc^.Length)) then
  3603.                   begin
  3604.                     CMD_Err(ErOutOfRange);
  3605.                     Dispose(pp);
  3606.                     Break;
  3607.                   end;
  3608.                   FExceptionStack.Add(pp);
  3609.               end;
  3610.             cmd_poexh:
  3611.               begin
  3612.                 if not ReadByte(p) then
  3613.                 begin
  3614.                   CMD_Err(ErOutOfRange);
  3615.                   Break;
  3616.                 end;
  3617.                 case p of
  3618.                   2:
  3619.                     begin
  3620.                       ExceptionProc(Cardinal(-1), Cardinal(-1), erNoError, '');
  3621.                       pp := FExceptionStack.GetItem(FExceptionStack.Count -1);
  3622.                       if pp = nil then begin
  3623.                         cmd_err(ErOutOfRange);
  3624.                         Break;
  3625.                       end;
  3626.                       if pp^.Finally2Offset <> cardinal(-1) then
  3627.                       begin
  3628.                         FCurrentPosition := pp^.Finally2Offset;
  3629.                         pp^.Finally2Offset := cardinal(-1);
  3630.                       end else begin
  3631.                         p := pp^.EndOfBlock;
  3632.                         Dispose(pp);
  3633.                         FExceptionStack.Delete(FExceptionStack.Count -1);
  3634.                         if FExitPoint <> Cardinal(-1) then
  3635.                         begin
  3636.                           FCurrentPosition := FExitPoint;
  3637.                         end else begin
  3638.                           FCurrentPosition := p;
  3639.                         end;
  3640.                       end;
  3641.                     end;
  3642.                   0:
  3643.                     begin
  3644.                       pp := FExceptionStack.GetItem(FExceptionStack.Count -1);
  3645.                       if pp = nil then begin
  3646.                         cmd_err(ErOutOfRange);
  3647.                         Break;
  3648.                       end;
  3649.                       if pp^.FinallyOffset <> cardinal(-1) then
  3650.                       begin
  3651.                         FCurrentPosition := pp^.FinallyOffset;
  3652.                         pp^.FinallyOffset := cardinal(-1);
  3653.                       end else if pp^.Finally2Offset <> cardinal(-1) then
  3654.                       begin
  3655.                          FCurrentPosition := pp^.Finally2Offset;
  3656.                          pp^.ExceptOffset := cardinal(-1);
  3657.                       end else begin
  3658.                         p := pp^.EndOfBlock;
  3659.                         Dispose(pp);
  3660.                         FExceptionStack.Delete(FExceptionStack.Count -1);
  3661.                         if ExEx <> eNoError then
  3662.                         begin
  3663.                           ExceptionProc(ExProc, ExPos, ExEx, ExParam);
  3664.                         end else
  3665.                         if FExitPoint <> Cardinal(-1) then
  3666.                         begin
  3667.                           FCurrentPosition := FExitPoint;
  3668.                         end else begin
  3669.                           FCurrentPosition := p;
  3670.                         end;
  3671.                       end;
  3672.                     end;
  3673.                   1:
  3674.                     begin
  3675.                       pp := FExceptionStack.GetItem(FExceptionStack.Count -1);
  3676.                       if pp = nil then begin
  3677.                         cmd_err(ErOutOfRange);
  3678.                         Break;
  3679.                       end;
  3680.                       if (ExEx <> ENoError) and (pp^.ExceptOffset <> cardinal(-1)) then
  3681.                       begin
  3682.                         FCurrentPosition := pp^.ExceptOffset;
  3683.                         pp^.ExceptOffset := cardinal(-1);
  3684.                       end else if (pp^.Finally2Offset <> cardinal(-1)) then
  3685.                       begin
  3686.                         FCurrentPosition := pp^.Finally2Offset;
  3687.                         pp^.Finally2Offset := cardinal(-1);
  3688.                       end else begin
  3689.                         p := pp^.EndOfBlock;
  3690.                         Dispose(pp);
  3691.                         FExceptionStack.Delete(FExceptionStack.Count -1);
  3692.                         if ExEx <> eNoError then
  3693.                         begin
  3694.                           ExceptionProc(ExProc, ExPos, ExEx, ExParam);
  3695.                         end else
  3696.                         if FExitPoint <> Cardinal(-1) then
  3697.                         begin
  3698.                           FCurrentPosition := FExitPoint;
  3699.                         end else begin
  3700.                           FCurrentPosition := p;
  3701.                         end;
  3702.                       end;
  3703.                     end;
  3704.                   3:
  3705.                     begin
  3706.                       pp := FExceptionStack.GetItem(FExceptionStack.Count -1);
  3707.                       if pp = nil then begin
  3708.                         cmd_err(ErOutOfRange);
  3709.                         Break;
  3710.                       end;
  3711.                       p := pp^.EndOfBlock;
  3712.                       Dispose(pp);
  3713.                       FExceptionStack.Delete(FExceptionStack.Count -1);
  3714.                       if ExEx <> eNoError then
  3715.                       begin
  3716.                           ExceptionProc(ExProc, ExPos, ExEx, ExParam);
  3717.                       end else
  3718.                       if FExitPoint <> Cardinal(-1) then
  3719.                       begin
  3720.                         FCurrentPosition := FExitPoint;
  3721.                       end else begin
  3722.                         FCurrentPosition := p;
  3723.                       end;
  3724.                    end;
  3725.                 end;
  3726.               end;
  3727.           else
  3728.             CMD_Err(erInvalidOpcode); // Error
  3729.           end;
  3730.         RunLine;
  3731.       end;
  3732.     end;
  3733.   until (FExceptionStack.Count = 0) or (Fstatus <> IsRunning);
  3734.   if FStatus = isLoaded then begin
  3735.     for I := 0 to Longint(FStack.Count) - 1 do begin
  3736.       DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FStack.GetItem(I));
  3737.     end;
  3738.     FStack.Clear;
  3739.     if FCallCleanup then Cleanup;
  3740.   end;
  3741. end;
  3742.  
  3743. procedure TIFPSExec.Stop;
  3744. var
  3745.   I: Longint;
  3746. begin
  3747.   if FStatus = isRunning then
  3748.     FStatus := isLoaded
  3749.   else if FStatus = isPaused then begin
  3750.     FStatus := isLoaded;
  3751.     for I := 0 to Longint(FStack.Count) - 1 do begin
  3752.       DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FStack.GetItem(I));
  3753.     end;
  3754.     FStack.Clear;
  3755.   end;
  3756. end;
  3757.  
  3758. function TIFPSExec.ReadByte(var b: Cardinal): Boolean;
  3759. begin
  3760.   if FCurrentPosition < FCurrProc.Length then begin
  3761.     b := FCurrProc.Data^[FCurrentPosition];
  3762.     Inc(FCurrentPosition);
  3763.     Result := True;
  3764.   end
  3765.   else
  3766.     Result := False;
  3767. end;
  3768.  
  3769. function TIFPSExec.ReadLong(var b: Cardinal): Boolean;
  3770. begin
  3771.   if FCurrentPosition + 3 < FCurrProc.Length then begin
  3772.     b := Cardinal((@FCurrProc.Data^[FCurrentPosition])^);
  3773.     Inc(FCurrentPosition, 4);
  3774.     Result := True;
  3775.   end
  3776.   else
  3777.     Result := False;
  3778. end;
  3779.  
  3780. function TIFPSExec.RunProc(Params: TIfList; ProcNo: Cardinal): Boolean;
  3781. var
  3782.   I, I2: Integer;
  3783.   Vd: PIfVariant;
  3784.   Cp: PIFProcRec;
  3785.   oldStatus: TIFStatus;
  3786. begin
  3787.   if FStatus <> isNotLoaded then begin
  3788.     if ProcNo >= FProcs.Count then begin
  3789.       Result := False;
  3790.       exit;
  3791.     end;
  3792.     if PIFProcRec(FProcs.GetItem(ProcNo))^.ExternalProc then begin
  3793.       Result := False;
  3794.       exit;
  3795.     end;
  3796.     for I := 0 to Params.Count - 1 do begin
  3797.       vd := Params.GetItem(I);
  3798.       if vd = nil then
  3799.       begin
  3800.         Result := False;
  3801.         exit;
  3802.       end;
  3803.       FStack.Add(Params.GetItem(I));
  3804.     end;
  3805.     Vd := CreateVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}@ReturnAddressType);
  3806.     Cp := FCurrProc;
  3807.     Vd^.treturnaddress.ProcNo := nil;
  3808.     Vd^.treturnaddress.Position := FCurrentPosition;
  3809.     Vd^.treturnaddress.StackBase := FCurrStackBase;
  3810.     I := FStack.Count;
  3811.     FStack.Add(Vd);
  3812.     FCurrStackBase := FStack.Count - 1;
  3813.     FCurrProc := FProcs.GetItem(ProcNo);
  3814.     FCurrentPosition := 0;
  3815.     oldStatus := FStatus;
  3816.     FStatus := isPaused;
  3817.     Result := RunScript;
  3818.     if FStack.Count > Cardinal(I) then
  3819.     begin
  3820.       vd := FStack.GetItem(I);
  3821.       if (vd <> nil) and (vd^.FType = @ReturnAddressType) then begin
  3822.         for i2 := FStack.Count - 1 downto I + 1 do begin
  3823.           DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FStack.GetItem(i2));
  3824.           FStack.Delete(i2);
  3825.         end;
  3826.         FStack.Delete(I);
  3827.         FCurrentPosition := Vd^.treturnaddress.Position;
  3828.         FCurrStackBase := Vd^.treturnaddress.StackBase;
  3829.         DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}Vd);
  3830.       end;
  3831.     end;
  3832.     for I := Params.Count - 1 downto 0 do begin
  3833.       FStack.Delete(FStack.Count - 1);
  3834.     end;
  3835.     FStatus := oldStatus;
  3836.     FCurrProc := Cp;
  3837.   end else begin
  3838.     Result := False;
  3839.   end;
  3840. end;
  3841.  
  3842. function TIFPSExec.CreateIntegerVariant(FType: PIFTypeRec; Value: Longint): PIfVariant;
  3843. begin
  3844.   Result := CreateVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FType);
  3845.   if Result <> nil then begin
  3846.     case FType^.BaseType of
  3847.       btU8: Result^.tu8 := Value;
  3848.       btS8: Result^.tS8 := Value;
  3849.       btU16: Result^.tu16 := Value;
  3850.       btS16: Result^.ts16 := Value;
  3851.       btU32: Result^.tu32 := Value;
  3852.       btS32: Result^.ts32 := Value;
  3853.     end;
  3854.   end;
  3855. end;
  3856.  
  3857. function TIFPSExec.CreateStringVariant(FType: PIFTypeRec; const Value: string): PIfVariant;
  3858. begin
  3859.   Result := CreateVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FType);
  3860.   if Result <> nil then begin
  3861.     case FType^.BaseType of
  3862.       btPChar, btString: begin
  3863.           TbtString(Result^.tstring) := Value;
  3864.         end;
  3865.     end;
  3866.   end;
  3867. end;
  3868.  
  3869. function TIFPSExec.CreateFloatVariant(FType: PIFTypeRec; Value: Extended): PIfVariant;
  3870. begin
  3871.   Result := CreateVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}FType);
  3872.   if Result <> nil then begin
  3873.     case FType^.BaseType of
  3874.       btSingle: Result^.tsingle := Value;
  3875.       btDouble: Result^.tdouble := Value;
  3876.       btExtended: Result^.textended := Value;
  3877.     end;
  3878.   end;
  3879. end;
  3880.  
  3881. function TIFPSExec.FindType2(BaseType: TIFPSBaseType): PIFTypeRec;
  3882. var
  3883.   l: Cardinal;
  3884. begin
  3885.   FindType2 := FindType(0, BaseType, l);
  3886.  
  3887. end;
  3888.  
  3889. function TIFPSExec.FindType(StartAt: Cardinal; BaseType: TIFPSBaseType; var l: Cardinal): PIFTypeRec;
  3890. var
  3891.   I: Integer;
  3892.   n: PIFTypeRec;
  3893. begin
  3894.   for I := StartAt to FTypes.Count - 1 do begin
  3895.     n := FTypes.GetItem(I);
  3896.     if n^.BaseType = BaseType then begin
  3897.       l := I;
  3898.       Result := n;
  3899.       exit;
  3900.     end;
  3901.   end;
  3902.   Result := nil;
  3903. end;
  3904.  
  3905. function TIFPSExec.GetTypeNo(l: Cardinal): PIFTypeRec;
  3906. begin
  3907.   Result := FTypes.GetItem(l);
  3908. end;
  3909.  
  3910. function TIFPSExec.GetProc(const Name: string): Cardinal;
  3911. var
  3912.   MM,
  3913.     I: Longint;
  3914.   n: PIFProcRec;
  3915. begin
  3916.   MM := MakeHash(Name);
  3917.   for I := 0 to FProcs.Count - 1 do begin
  3918.     n := FProcs.GetItem(I);
  3919.     if (not n^.ExternalProc) and (Length(n^.ExportName) <> 0) and (n^.ExportNameHash = MM) and (n^.ExportName = Name) then begin
  3920.       Result := I;
  3921.       exit;
  3922.     end;
  3923.   end;
  3924.   Result := Cardinal(-1);
  3925. end;
  3926.  
  3927. function TIFPSExec.GetType(const Name: string): Cardinal;
  3928. var
  3929.   MM,
  3930.     I: Longint;
  3931.   n: PIFTypeRec;
  3932. begin
  3933.   MM := MakeHash(Name);
  3934.   for I := 0 to FTypes.Count - 1 do begin
  3935.     n := FTypes.GetItem(I);
  3936.     if (Length(n^.ExportName) <> 0) and (n^.ExportNameHash = MM) and (n^.ExportName = Name) then begin
  3937.       Result := I;
  3938.       exit;
  3939.     end;
  3940.   end;
  3941.   Result := Cardinal(-1);
  3942. end;
  3943.  
  3944.  
  3945. procedure TIFPSExec.AddResource(Proc, P: Pointer);
  3946. var
  3947.   Temp: PIFPSResource;
  3948. begin
  3949.   New(Temp);
  3950.   Temp^.Proc := Proc;
  3951.   Temp^.P := p;
  3952.   FResources.Add(temp);
  3953. end;
  3954.  
  3955. procedure TIFPSExec.DeleteResource(P: Pointer);
  3956. var
  3957.   i: Longint;
  3958. begin
  3959.   for i := Longint(FResources.Count) -1 downto 0 do
  3960.   begin
  3961.     if PIFPSResource(FResources.GetItem(I))^.P = P then
  3962.     begin
  3963.       FResources.Delete(I);
  3964.       exit;
  3965.     end;
  3966.   end;
  3967. end;
  3968.  
  3969. function TIFPSExec.FindProcResource(Proc: Pointer): Pointer;
  3970. var
  3971.   I: Longint;
  3972.   temp: PIFPSResource;
  3973. begin
  3974.   for i := Longint(FResources.Count) -1 downto 0 do
  3975.   begin
  3976.     temp := FResources.GetItem(I);
  3977.     if temp^.Proc = proc then
  3978.     begin
  3979.       Result := Temp^.P;
  3980.       exit;
  3981.     end;
  3982.   end;
  3983.   Result := nil;
  3984. end;
  3985.  
  3986. function TIFPSExec.IsValidResource(Proc, P: Pointer): Boolean;
  3987. var
  3988.   i: Longint;
  3989.   temp: PIFPSResource;
  3990. begin
  3991.   for i := 0 to Longint(FResources.Count) -1 do
  3992.   begin
  3993.     temp := FResources.GetItem(i);
  3994.     if temp^.p = p then begin
  3995.       result := temp^.Proc = Proc;
  3996.       exit;
  3997.     end;
  3998.   end;
  3999.   result := false;
  4000. end;
  4001.  
  4002. function TIFPSExec.FindProcResource2(Proc: Pointer;
  4003.   var StartAt: Longint): Pointer;
  4004. var
  4005.   I: Longint;
  4006.   temp: PIFPSResource;
  4007. begin
  4008.   if StartAt > longint(FResources.Count) -1 then 
  4009.     StartAt := longint(FResources.Count) -1;
  4010.   for i := StartAt downto 0 do
  4011.   begin
  4012.     temp := FResources.GetItem(I);
  4013.     if temp^.Proc = proc then
  4014.     begin
  4015.       Result := Temp^.P;
  4016.       StartAt := i -1;
  4017.       exit;
  4018.     end;
  4019.   end;
  4020.   StartAt := -1;
  4021.   Result := nil;
  4022. end;
  4023.  
  4024. procedure TIFPSExec.RunLine;
  4025. begin
  4026.   if @FOnRunLine <> nil then
  4027.     FOnRunLine(Self);
  4028. end;
  4029.  
  4030. procedure TIFPSExec.CMD_Err2(EC: TIFError; const Param: string);
  4031. var
  4032.   l: Longint;
  4033.   C: Cardinal;
  4034. begin
  4035.   C := Cardinal(-1);
  4036.   for l := 0 to FProcs.Count - 1 do begin
  4037.     if FProcs.GetItem(l) = FCurrProc then begin
  4038.       C := l;
  4039.       break;
  4040.     end;
  4041.   end;
  4042.   ExceptionProc(C, FCurrentPosition, EC, Param);
  4043. end;
  4044.  
  4045. procedure FreePIFVariantList({$IFNDEF NOSMARTMM}MM: Pointer; {$ENDIF}List: TIfList);
  4046. var
  4047.   I: Longint;
  4048. begin
  4049.   for I := List.Count -1 downto 0 do
  4050.   begin
  4051.     DisposeVariant({$IFNDEF NOSMARTMM}MM, {$ENDIF}List.GetItem(I));
  4052.   end;
  4053.   List.Free;
  4054. end;
  4055. procedure TIFPSExec.AddSpecialProcImport(const FName: string;
  4056.   P: TIFPSOnSpecialProcImport; Tag: Pointer);
  4057. var
  4058.   N: PSpecialProc;
  4059. begin
  4060.   New(n);
  4061.   n^.P := P;
  4062.   N^.Name := FName;
  4063.   n^.namehash := MakeHash(FName);
  4064.   n^.Tag := Tag;
  4065.   FSpecialProcList.Add(n);
  4066. end;
  4067.  
  4068. function TIFPSExec.GetVar(const Name: string): Cardinal;
  4069. var
  4070.   l: Longint;
  4071.   h: longint;
  4072. begin
  4073.   h := makehash(Name);
  4074.   for l := FExportedVars.Count - 1 downto 0 do
  4075.   begin
  4076.     if (PIFPSExportedVar(FexportedVars.GetItem(L))^.FNameHash = h) and(PIFPSExportedVar(FexportedVars.GetItem(L))^.FName=Name) then
  4077.     begin
  4078.       Result := L;
  4079.       exit;
  4080.     end;
  4081.   end;
  4082.   Result := Cardinal(-1);
  4083. end;
  4084.  
  4085. function TIFPSExec.GetVarNo(C: Cardinal): PIFVariant;
  4086. begin
  4087.   Result := FGlobalVars.GetItem(c);
  4088. end;
  4089.  
  4090. function TIFPSExec.GetVar2(const Name: string): PIFVariant;
  4091. begin
  4092.   Result := GetVarNo(GetVar(Name));
  4093. end;
  4094.  
  4095. function TIFPSExec.GetProcNo(C: Cardinal): PIFProcRec;
  4096. begin
  4097.   Result := FProcs.GetItem(c);
  4098. end;
  4099.  
  4100. end.
  4101.  
  4102.