home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 December / Chip_2001-12_cd1.bin / zkuste / delphi / kompon / d23456 / CAJSCRTP.ZIP / ifspas.pas < prev    next >
Pascal/Delphi Source File  |  2001-10-03  |  285KB  |  8,314 lines
  1. {
  2. IfPasScript
  3.  
  4. version: 2.74
  5. Last stable version: 2.73
  6.  
  7. Features:
  8.  - Support for standard types: Byte, Shortint, Char, Word, SmallInt,
  9.    Cardinal, Longint, Integer, String, Real, Double, Single, Extended,
  10.    Comp, Boolean, Array, Record, Variant, Enumerations
  11.  - Classes (Declared inside or outside script)
  12.  - Variables, Constants
  13.  - Standard statements: Begin/End, If/Then/Else, For/To/Downto/Do,
  14.    Case x Of, Repeat/Until, While, With, Uses, Try/Except/Finally,
  15.  - Exit, Continue, Break
  16.  - Functions (Declared inside or outside script)
  17.  - Array of Const parameters, Var parameters
  18.  - External modules (attached script engines)
  19.  - A lot of libraries like Databases, Forms, Dll calls, Delphi calls...
  20.  - Documentation and examples
  21. }
  22. unit ifspas;
  23. {$I ifs_def.inc}
  24. interface
  25. uses
  26.   ifs_var, ifs_utl{$IFNDEF NOCLASSES}, ifs_obj{$ENDIF}{$IFDEF VARIANTSUNIT}, Variants{$ENDIF};
  27. const
  28.   Version = '2.74';
  29.  
  30. type
  31.   TIfPasScript = class;
  32.   TIFSError = record
  33.     ErrorCode: TIfPasScriptError;
  34.     ErrorPosition: Longint;
  35.     ErrorParam: string;
  36.     ErrorModule: string;
  37.   end;
  38.   TCs2PascalScript = TIfPasScript;
  39.   TOnUses = function(id: Pointer; Sender: TIfPasScript; Name: string): TIfPasScriptError;
  40.   TOnRunLine = function(id: Pointer; Sender: TIfPasScript; Position: Longint): TIfPasScriptError;
  41.   TResourceFree = procedure(id: Pointer; Data: Pointer);
  42.   TOnExternal = function(id: Pointer; Sender: TIfPasScript; const Param, FuncName: string; Func: PProcedure; const CallingConvention: string): Boolean;
  43.   TPerformType = (PtSet, ptMinus, PtPlus, PtMul, ptDiv, PtIntDiv, PtIntMod, PtAnd, ptOr, ptXor, PtShl, PtShr, PtGreater, PtLess, PtEqual, PtNotEqual, PtGreaterEqual, PtLessEqual{$IFNDEF NOCLASSES}, ptIs, ptAs{$ENDIF});
  44.   TIfPasScript = class
  45.   Private
  46.     FUses: TIfStringList;
  47.     FFreeOnCleanup: Boolean;
  48.     FAllocatedResources: TIfList;
  49. {$IFNDEF NOCLASSES}
  50.     CreatedClasses: TIfList;
  51. {$ENDIF}
  52.     FISUnit: Boolean;
  53.     FModuleName: string;
  54.     MainOffset: Longint;
  55.     fId: Pointer;
  56.     FError: TIFSError;
  57.     FOnUses: TOnUses;
  58.     FOnRunLine: TOnRunLine;
  59.     FOnExternal: TOnExternal;
  60.     FBeginNesting: Longint;
  61.     FMaxBeginNesting: Longint;
  62.     FMaxArrayLength: Longint;
  63.     function GetIdentifier(WithList: TIfList; Vars: PVariableManager; Mode: Byte; var w: PIfVariant): Byte;
  64.     {mode 0 = normal; 1 = AsVariable; 2 = asProcPointer}
  65.     function IdentifierExists(AlsoVariables: Boolean; SubVars: PVariableManager; const s: string): Boolean;
  66.     function ProcessVars(Vars: PVariableManager): Boolean;
  67.     function ProcessConsts(Vars: PVariableManager): Boolean;
  68.     function ReadType(Parser: TIfPascalParser; AllowClasses: Boolean; const Name: string): PTypeRec;
  69.     function RunBegin(WithList: TIfList; Vars: PVariableManager; Skip: Boolean): Boolean;
  70.     function calc(WithList: TIfList; Vars: PVariableManager; res: PIfVariant; StopOn: TIfPasToken; OnlyConst: Boolean): Boolean;
  71.     function DoProc(WithList: TIfList; {$IFNDEF NOCLASSES}Myself: PCreatedClass; {$ENDIF}proc: PProcedure; Vars: PVariableManager): PIfVariant;
  72.     function ReadParams(WithList: TIfList; ProcDef: string; Vars, Params: PVariableManager): Boolean;
  73. {$IFNDEF NOCLASSES}
  74.     function DoClassConstructor(WithList: TIfList; Myclass: PTypeRec; proc: PProcedure; Vars: PVariableManager): PIfVariant;
  75. {$ENDIF}
  76.     function Perform(V1: PIfVariant; v2: PIfVariant; t: TPerformType): Boolean;
  77.     function MakeCompat(v: PIfVariant; FType: PTypeRec): Boolean;
  78.     procedure AddStandard;
  79.     function GetErrorCode: TIfPasScriptError;
  80.     function GetErrorPos: Longint;
  81.     function GetErrorString: string;
  82.     function GetErrorModule: string;
  83.     procedure LoadData;
  84.   Protected
  85.     Variables: PVariableManager;
  86.     Types: PTypeManager;
  87.     Procedures: PProcedureManager;
  88.     Parser: TIfPascalParser;
  89.     ProcStack: TIFList;
  90.     CurrVars: PVariableManager;
  91.     FAttachedOnes: TIfList;
  92.     FLastException: TIFSError;
  93.     function GetCurrProc: PProcedure;
  94.     function PopProcStack: PProcedure;
  95.     function ExecRunLine: Boolean; virtual; 
  96.   Public
  97.     procedure RunError(SE: TIfPasScript; C: TIfPasScriptError);
  98.     procedure RunError2(SE: TIfPasScript; C: TIfPasScriptError; Ext: string);
  99.  
  100.     function GetVariable(const Name: string): PIfVariant;
  101.     function GetFunction(s: string): PProcedure;
  102.     function GetType(const s: string): PTypeRec;
  103.  
  104.     function RemoveFunction(d: PProcedure): Boolean; // does not dispose it
  105.  
  106.     function AddVariable(Name, FType: string; Constant: Boolean): PIfVariant;
  107.     function AddFunction(proc: Pointer; Decl: string; Ext: Pointer): PProcedure;
  108.     function AddClassFunction(Proc: TRegisteredProcObject; Decl: string; Ext: Pointer): PProcedure;
  109.     function AddType(const Name, Decl: string): PTypeRec;
  110.     function AddTypeEx(Name: string): PTypeRec;
  111. {$IFNDEF NOCLASSES}
  112.     function AddClass(const Name, Decl: string; RegProc: Pointer): PTypeRec;
  113. {$ENDIF}
  114. {$IFDEF VARIANTSUPPORT}
  115.     function CallFunction(p: PProcedure; Params: array of Variant): Variant;
  116. {$IFNDEF NOCLASSES}
  117.     function CallMethod(p: PProcedure; Myself: PCreatedClass; Params: array of Variant): Variant;
  118. {$ENDIF}
  119. {$ENDIF}
  120.  
  121. {$IFDEF VARIANTSUPPORT}
  122.     function VariantToIFVariant(const v: Variant; res: PIfVariant): Boolean;
  123.     function IfVariantToVariant(v: PIfVariant; var res: Variant): Boolean;
  124. {$ENDIF}
  125.  
  126.     function CopyVariant(p: PIfVariant): PIfVariant;
  127.     function CreateReal(const E: Extended): PIfVariant;
  128.     function CreateString(const s: string): PIfVariant;
  129.     function CreateInteger(I: Longint): PIfVariant;
  130.     function CreateBool(b: Boolean): PIfVariant;
  131.     function CreateVarType(p: PIfVariant): PIfVariant;
  132.  
  133.     procedure Cleanup;
  134.  
  135.     procedure RunScript;
  136.     function RunScriptProc(Func: PProcedure; Parameters: PVariableManager): PIfVariant;
  137. {$IFNDEF NOCLASSES}
  138.     function RunScriptConstructor(FType: PTypeRec; Func: PProcedure; Parameters: PVariableManager): PIfVariant;
  139.     function RunInherited(proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
  140.     function SetProperty(prop, Data: PIfVariant): Boolean;
  141.     function GetProperty(prop: PIfVariant): PIfVariant; // nil = error
  142. {$ENDIF}
  143.  
  144.     function Attach(ScriptEngine: TIfPasScript): Boolean;
  145.     function Attach2(ScriptEngine: TIfPasScript; FreeOnCleanup: Boolean): Boolean;
  146.  
  147.     procedure AddResource(FreeProc: TResourceFree; Data: Pointer);
  148.     procedure RemoveResource(Data: Pointer);
  149.     function IsValidResource(FreeProc: TResourceFree; Data: Pointer): Boolean;
  150.     function FindResource(FreeProc: TResourceFree): Pointer;
  151.  
  152.     procedure SetText(const Data: string);
  153.     procedure SetPData(const Data: string);
  154.     function GetPData(var Data: string): Boolean;
  155.  
  156.     constructor Create(id: Pointer);
  157.     destructor Destroy; Override;
  158.  
  159.     property ModuleName: string Read FModuleName Write FModuleName;
  160.  
  161.     property IsUnit: Boolean Read FISUnit;
  162.     property OnRunLine: TOnRunLine Read FOnRunLine Write FOnRunLine;
  163.     property OnUses: TOnUses Read FOnUses Write FOnUses;
  164.     property OnExternal: TOnExternal Read FOnExternal Write FOnExternal;
  165.  
  166.     property ErrorCode: TCs2Error Read GetErrorCode;
  167.     property ErrorPos: Longint Read GetErrorPos;
  168.     property ErrorString: string Read GetErrorString;
  169.     property ErrorModule: string Read GetErrorModule;
  170.  
  171.     property MaxBeginNesting: Longint Read FMaxBeginNesting Write FMaxBeginNesting;
  172.     property MaxArrayLength: Longint Read FMaxArrayLength Write FMaxArrayLength;
  173.   end;
  174. {$IFNDEF NOCLASSES}
  175. function GetClassVariable(Self: PIfVariant; ProcClass: PIFSClassType; const Name: string; var thevar: PIfVariant; AlsoProtected: Boolean): Boolean;
  176. function GetClassVariable2(Self: PCreatedClass; ProcClass: PIFSClassType; const Name: string; var thevar: PIfVariant; AlsoProtected: Boolean): Boolean;
  177. function GetClassProcedure(Self: PIfVariant; ProcClass: PIFSClassType; const Name: string; var proc: PProcedure; AlsoProtected: Boolean): Boolean;
  178. function GetInheritedProc(CurrProc: PProcedure): PProcedure;
  179. {$ENDIF}
  180.  
  181. procedure SetArrayLength(FVar: PIFVariant; NewLength: Longint);
  182.  
  183. procedure RegisterStdLib(p: TIfPasScript; OnlySafe: Boolean);
  184. {If onlysafe is true, All Floating point functions are disabled (cos, sin, tan, round etc)}
  185. {Register all standard functions:}
  186. {
  187. Installs:
  188.   Function StrGet(S : String; I : Integer) : Char;
  189.   Function StrSet(c : Char; I : Integer; var s : String) : Char;
  190.   Function Chr(B : Byte) : Char;
  191.   Function StrToInt(s : string;def : Longint) : Longint;
  192.   Function IntToStr(i : Longint) : String;
  193.   Function Uppercase(s : string) : string;
  194.   Function Lowercase(s : string) : string;
  195.   Function Trim(s : string) : string;
  196.   Function Copy(S : String; Indx, Count : Integer) : String;
  197.   Procedure Delete(var S : String; Indx, Count : Integer);
  198.   Function Pos(SubStr, S : String) : Integer;
  199.   Procedure Insert(Source : String; var Dest : String; Indx : Integer);
  200.   Function Length(s : String) : Longint;
  201.   procedure SetLength(var S: String; L: Longint);
  202.   Function Sin(e : Extended) : Extended;
  203.   Function Cos(e : Extended) : Extended;
  204.   Function Sqrt(e : Extended) : Extended;
  205.   Function Round(e : Extended) : Longint;
  206.   Function Trunc(e : Extended) : Longint;
  207.   Function Int(e : Extended) : Longint;
  208.   Function Pi : Extended;
  209.   Function Abs(e : Extended) : Extended;
  210.   Function Sqrt(e : Extended) : Extended;
  211.   Function FloatToStr(e : Extended) : String;
  212.   Function Padl(s : string;I : longInt) : string;
  213.   Function Padr(s : string;I : longInt) : string;
  214.   Function Padz(s : string;I : longInt) : string;
  215.   Function Replicate(c : char;I : longInt) : string;
  216.   Function StringOfChar(c : char;I : longInt) : string;
  217.   procedure SetArrayLength(var u: array; Length: Longint);
  218.   function GetArrayLength(var u: array): Longint;
  219.   function GetType(const data): String;
  220.   function Assigned(const data): Boolean;
  221.  
  222.   Function Ord(var C) : Longint;
  223.   function Pred(var C);
  224.   function Succ(var c);
  225.   function Low(var u);
  226.   function High(var u);
  227.  
  228. Type
  229.   TObject = class
  230.   public
  231.     Constructor Create;
  232.     Destructor Destroy; virtual;
  233.     procedure Free;
  234.  
  235.     function ClassNameIs(FType: string): Boolean;
  236.     function ClassName: string;
  237.     function GetAncestors: string;
  238.   end;
  239.  
  240. }
  241.  
  242. procedure RegisterExceptionLib(Sender: TIfPasScript);
  243.  
  244. {
  245.   function GetLastErrorCode: word;
  246.   function GetLastErrorParam: string;
  247.   function GetLastErrorModule: string;
  248.   function GetLastErrorAsString: string;
  249.   function GetLastErrorPosition: Longint;
  250.   procedure RaiseError(ErrorCode: Word; Param: string);
  251.  
  252. }
  253. {$IFDEF USEIDISPATCH}
  254. type
  255.   TIDispatchToIFVariant = function(ScriptEngine: TIfPasScript; res: PIfVariant; I: IDispatch): Boolean;
  256.   TIFVariantToIDispatch = function(ScriptEngine: TIfPasScript; var res: IDispatch; I: PIfVariant): Boolean;
  257. var
  258.   IDispatchToIFVariantProc: TIDispatchToIFVariant = nil;
  259.   IFVariantToIDispatchProc: TIFVariantToIDispatch = nil;
  260. {$ENDIF}
  261.  
  262. implementation
  263.  
  264. type
  265.   PResourceData = ^TResourceData;
  266.   TResourceData = record
  267.     Data: Pointer;
  268.     FreeProc: TResourceFree;
  269.   end;
  270.  
  271. function IntProcDefParam(s: string; I: Integer): Integer;
  272. {
  273. Parse the incode-script procedure definition from a string.
  274. When I=0 this function will return the result type.
  275. When I=-1 this function will return the number of parameters.
  276. When I=1 this function will return the first parameter type.
  277. When I=2 this function will return the second parameter type.
  278. etc.
  279. }
  280. var
  281.   res: Integer;
  282. begin
  283.   if I = 0 then
  284.   {Return result-type} IntProcDefParam := StrToInt(Fw(s)) else
  285.     if I = -1 then
  286.     {Return param count} begin
  287.       res := 0;
  288.       Delete(s, 1, Length(Fw(s))); {result}
  289.       rs(s);
  290.       while Length(s) > 0 do begin
  291.         Inc(res);
  292.         Delete(s, 1, Length(Fw(s))); {Delete parameter name}
  293.         rs(s);
  294.         Delete(s, 1, Length(Fw(s))); {Delete parameter type}
  295.         rs(s);
  296.       end; {while}
  297.       IntProcDefParam := res;
  298.     end {else if} else begin
  299.       res := 0;
  300.       if I < 1 then begin
  301.         IntProcDefParam := -1;
  302.         exit;
  303.       end;
  304.       Delete(s, 1, Length(Fw(s))); {result}
  305.       rs(s);
  306.       while Length(s) > 0 do begin
  307.         Inc(res);
  308.         Delete(s, 1, Length(Fw(s))); {delete parameter name}
  309.         rs(s);
  310.         if res = I then begin
  311.           IntProcDefParam := StrToInt(Fw(s));
  312.           exit;
  313.         end;
  314.         Delete(s, 1, Length(Fw(s))); {delete type}
  315.         rs(s);
  316.       end; {while}
  317.       IntProcDefParam := 0;
  318.     end {Else Else if}
  319. end; {IntProcDefParam}
  320. //-------------------------------------------------------------------
  321.  
  322. function IntProcDefName(s: string; I: Integer): string;
  323. {
  324. Parse the incode-script procedure definition from a string.
  325. i=0 will return the procedure name
  326. I=1 will return the first one
  327. }
  328. var
  329.   res: Integer;
  330. begin
  331.   res := 0;
  332.   if I < 1 then begin
  333.     IntProcDefName := '';
  334.     exit;
  335.   end;
  336.   Delete(s, 1, Length(Fw(s))); {result}
  337.   rs(s);
  338.   while Length(s) > 0 do begin
  339.     Inc(res);
  340.     if res = I then begin
  341.       IntProcDefName := Fw(s);
  342.       exit;
  343.     end;
  344.     Delete(s, 1, Length(Fw(s))); {delete parameter name}
  345.     rs(s);
  346.     Delete(s, 1, Length(Fw(s))); {delete type}
  347.     rs(s);
  348.   end; {while}
  349.   IntProcDefName := '';
  350. end; {IntProcDefParam}
  351.  
  352. procedure DestroyWithList(I: TIfList);
  353. var
  354.   u: Integer;
  355. begin
  356.   for u := 0 to Longint(I.Count) - 1 do begin
  357.     DestroyCajVariant(I.GetItem(u));
  358.   end;
  359.   I.Free;
  360. end;
  361.  
  362. {$IFNDEF NOCLASSES}
  363.  
  364. function IsSameClassFamily(s1, s2: PIFSClassType; EnableSwitch: Boolean): Boolean;
  365. var
  366.   s3: PIFSClassType;
  367. begin
  368.   if (s1.VarNoStart > s2.VarNoStart) and EnableSwitch then begin
  369.     s3 := s1;
  370.     s1 := s2;
  371.     s2 := s3;
  372.   end;
  373.   while (s1 <> s2) do begin
  374.     if assigned(s2^.InheritsFrom) then
  375.       s2 := s2^.InheritsFrom^.Ext
  376.     else begin
  377.       s2 := nil;
  378.       break;
  379.     end;
  380.   end;
  381.   IsSameClassFamily := s2 <> nil;
  382. end;
  383.  
  384. //-------------------------------------------------------------------
  385.  
  386. function GetClassProcedure(Self: PIfVariant; ProcClass: PIFSClassType; const Name: string; var proc: PProcedure; AlsoProtected: Boolean): Boolean;
  387. var
  388.   pc: PIFSClassType;
  389.   I: Integer;
  390.  
  391.   procedure CheckForward;
  392.   var
  393.     n: TIfList;
  394.     I, I2: Integer;
  395.     E: PProcedure;
  396.   begin
  397.     if (proc^.Flags and $30) <> 0 then begin
  398.       n := TIfList.Create;
  399.       if assigned(Self) then
  400.         ProcClass := Self.CV_Class^.ClassType^.Ext;
  401.       while assigned(ProcClass) and (ProcClass <> proc^.ClassType^.Ext) do begin
  402.         n.Add(ProcClass);
  403.         if assigned(ProcClass^.InheritsFrom) then
  404.           ProcClass := ProcClass^.InheritsFrom^.Ext
  405.         else
  406.           ProcClass := nil;
  407.       end;
  408.       for I := Longint(n.Count) - 1 downto 0 do begin
  409.         ProcClass := n.GetItem(I);
  410.         for I2 := 0 to (ProcClass^.Procedures.Count) - 1 do begin
  411.           E := ProcClass^.Procedures.GetItem(I2);
  412.           if copy(E^.Name, 2, Length(E^.Name) - 1) = Name then begin
  413.             if (E^.Flags and $30) <> $20 then begin
  414.               break;
  415.             end else
  416.               proc := E;
  417.           end; {if}
  418.         end; {for}
  419.       end; {for}
  420.       n.Free;
  421.     end;
  422.   end;
  423. begin
  424.   pc := ProcClass;
  425.   while assigned(pc) do begin
  426.     for I := 0 to Longint(pc^.Procedures.Count) - 1 do begin
  427.       proc := pc^.Procedures.GetItem(I);
  428.       if copy(proc^.Name, 2, Length(proc^.Name) - 1) = Name then begin
  429.         if (proc.Flags and $3) = $2 then begin
  430.           CheckForward;
  431.           GetClassProcedure := True;
  432.           exit;
  433.         end;
  434.         if AlsoProtected then begin
  435.           if pc = ProcClass then begin
  436.             CheckForward;
  437.             GetClassProcedure := True;
  438.             exit;
  439.           end else
  440.             if (proc.Flags and $3) = $1 then begin
  441.               CheckForward;
  442.               GetClassProcedure := True;
  443.               exit;
  444.             end;
  445.           if (proc.Flags and $3) = $3 then begin
  446.             CheckForward;
  447.             GetClassProcedure := True;
  448.             exit;
  449.           end;
  450.         end;
  451.       end;
  452.     end; {for}
  453.     if assigned(pc^.InheritsFrom) then
  454.       pc := pc^.InheritsFrom^.Ext
  455.     else
  456.       pc := nil;
  457.   end; {while}
  458.   GetClassProcedure := False;
  459. end;
  460. //-------------------------------------------------------------------
  461.  
  462. function FindProc(TheClass: PTypeRec; const Name: string): PProcedure;
  463. var
  464.   Curr: PTypeRec;
  465.   res: PProcedure;
  466.  
  467.   function SearchList(List: TIfList): PProcedure;
  468.   var
  469.     I: Integer;
  470.     n: PProcedure;
  471.   begin
  472.     for I := 0 to Longint(List.Count) - 1 do begin
  473.       n := List.GetItem(I);
  474.       if n^.Name = Name then begin
  475.         SearchList := n;
  476.         exit;
  477.       end;
  478.     end;
  479.     SearchList := nil;
  480.   end; {searchlist}
  481. begin
  482.   Curr := TheClass;
  483.   res := nil;
  484.   while assigned(Curr) do begin
  485.     res := SearchList(PIFSClassType(Curr^.Ext)^.Procedures);
  486.     if res = nil then
  487.       Curr := PIFSClassType(Curr^.Ext)^.InheritsFrom
  488.     else
  489.       break;
  490.   end;
  491.   FindProc := res;
  492. end;
  493. //-------------------------------------------------------------------
  494.  
  495. function GetClassVariable(Self: PIfVariant; ProcClass: PIFSClassType; const Name: string; var thevar: PIfVariant; AlsoProtected: Boolean): Boolean;
  496. begin
  497.   GetClassVariable := GetClassVariable2(Self^.CV_Class, ProcClass, Name, thevar, AlsoProtected);
  498. end;
  499.  
  500. //-------------------------------------------------------------------
  501.  
  502. function GetClassVariable2(Self: PCreatedClass; ProcClass: PIFSClassType; const Name: string; var thevar: PIfVariant; AlsoProtected: Boolean): Boolean;
  503. var
  504.   TC: PCreatedClass;
  505.   ct: PIFSClassType;
  506.   pp: PPropertyDef;
  507.   I: Longint;
  508.   u, s: string;
  509. begin
  510.   TC := Self;
  511.   if not IsSameClassFamily(TC^.ClassType^.Ext, ProcClass, True) then begin
  512.     GetClassVariable2 := False;
  513.     exit;
  514.   end;
  515.   ct := ProcClass;
  516.   while assigned(ct) do begin
  517.     s := ct^.Variables.u;
  518.     I := ct^.VarNoStart;
  519.     while Length(s) > 0 do begin
  520.       u := Fw(s);
  521.       Rfw(s); {remove name}
  522.       Rfw(s); {remove type}
  523.       if copy(u, 2, Length(u) - 1) = Name then begin
  524.         thevar := Vm_Get(TC^.Variables, I);
  525.         if (thevar.Flags and $6) = $4 then begin
  526.           GetClassVariable2 := True;
  527.           exit;
  528.         end;
  529.         if AlsoProtected then begin
  530.           if ct = ProcClass then begin
  531.             GetClassVariable2 := True;
  532.             exit;
  533.           end else if (thevar.Flags and $6) = $6 then begin
  534.             GetClassVariable2 := True;
  535.             exit;
  536.           end;
  537.         end; {if}
  538.       end; {while}
  539.       Inc(I);
  540.     end;
  541.     for I := 0 to Longint(ct^.Properties.Count) - 1 do begin
  542.       pp := ct^.Properties.GetItem(I);
  543.       if pp^.Name = Name then begin
  544.         thevar := Vm_Get(TC^.Variables, Longint(PIFSClassType(Self^.ClassType.Ext)^.VarNoStart + PIFSClassType(Self^.ClassType.Ext)^.VarCount) + I + Longint(ct^.PropStart));
  545.         if (thevar.Flags and $6) = $4 then begin
  546.           GetClassVariable2 := True;
  547.           exit;
  548.         end;
  549.         if AlsoProtected then begin
  550.           if ct = ProcClass then begin
  551.             GetClassVariable2 := True;
  552.             exit;
  553.           end else if (thevar.Flags and $6) = $6 then begin
  554.             GetClassVariable2 := True;
  555.             exit;
  556.           end;
  557.         end;
  558.       end;
  559.     end;
  560.     if assigned(ct.InheritsFrom) then
  561.       ct := ct.InheritsFrom^.Ext
  562.     else
  563.       ct := nil;
  564.   end;
  565.   GetClassVariable2 := False;
  566. end;
  567. //-------------------------------------------------------------------
  568.  
  569. //-------------------------------------------------------------------
  570.  
  571. function TIfPasScript.SetProperty(prop, Data: PIfVariant): Boolean;
  572. var
  573.   v: PVariableManager;
  574. begin
  575.   SetProperty := False;
  576.   if (prop.CV_PropFlags and $2) = 0 then begin
  577.     RunError(Self, ECanNotWriteProperty);
  578.     exit;
  579.   end;
  580.   if (prop.CV_PropFlags and $8) <> 0 then begin
  581.     v := VM_Create;
  582.     Vm_Add(v, CreateCajVariant(PCreatedClass(prop^.CV_Self)^.ClassType), 'SELF')^.CV_Class := prop^.CV_Self;
  583.     Vm_Add(v, CopyVariant(Data), 'DATA');
  584.     DestroyCajVariant(RunScriptProc(prop.CV_PropWrite, v));
  585.     if FError.ErrorCode = EParameterError then begin
  586.       FError.ErrorCode := ENoError;
  587.       RunError(Self, ETypeMismatch);
  588.       VM_Destroy(v);
  589.       exit;
  590.     end;
  591.     VM_Destroy(v);
  592.   end else begin
  593.     if not Perform(prop.CV_PropWrite, Data, PtSet) then
  594.       exit;
  595.   end;
  596.   SetProperty := True;
  597. end;
  598. //-------------------------------------------------------------------
  599.  
  600. function TIfPasScript.GetProperty(prop: PIfVariant): PIfVariant;
  601. var
  602.   v: PVariableManager;
  603.   res: PIfVariant;
  604. begin
  605.   GetProperty := nil;
  606.   if (prop.CV_PropFlags and $1) = 0 then begin
  607.     RunError(Self, ECanNotReadProperty);
  608.     exit;
  609.   end;
  610.   if (prop.CV_PropFlags and $4) <> 0 then begin
  611.     v := VM_Create;
  612.     Vm_Add(v, CreateCajVariant(PCreatedClass(prop^.CV_Self)^.ClassType), 'SELF')^.CV_Class := prop^.CV_Self;
  613.     res := RunScriptProc(prop.CV_PropRead, v);
  614.     if FError.ErrorCode = EParameterError then begin
  615.       FError.ErrorCode := ENoError;
  616.       RunError(Self, ETypeMismatch);
  617.       VM_Destroy(v);
  618.       exit;
  619.     end;
  620.     VM_Destroy(v);
  621.     GetProperty := res;
  622.   end else begin
  623.     GetProperty := CopyVariant(prop.CV_PropRead);
  624.   end;
  625. end;
  626. //-------------------------------------------------------------------
  627. {$ENDIF}
  628.  
  629. function TIfPasScript.Perform(V1: PIfVariant; v2: PIfVariant; t: TPerformType): Boolean;
  630. var
  631.   Err: Boolean;
  632.   I: Longint;
  633.   p: PIfVariant;
  634.  
  635.   procedure AddArrayVar(var v: TIfList; I: PIfVariant);
  636.   var
  637.     n: PIfVariant;
  638.   begin
  639.     New(n);
  640.     n^.VType^.atypeid := CSV_Var;
  641.     n^.CV_Var := nil;
  642.     Perform(n, I, PtSet);
  643.   end;
  644.  
  645.   procedure MakeItReal(v: Extended);
  646.   begin
  647.     ChangeType(V1, TM_Add(Types, '', CSV_Extended, nil));
  648.     V1^.Cv_Extended := v;
  649.   end;
  650.  
  651.   procedure MakeItBool(v: Boolean);
  652.   begin
  653.     ChangeType(V1, TM_Add(Types, '', CSV_Bool, nil));
  654.     V1^.Cv_Bool := v;
  655.   end;
  656.  
  657.   procedure MakeItString(const v: string);
  658.   begin
  659.     ChangeType(V1, TM_Add(Types, '', CSV_String, nil));
  660.     V1^.Cv_Str := v;
  661.   end;
  662.  
  663. begin
  664.   V1 := GetVarLink(V1);
  665.   v2 := GetVarLink(v2);
  666. {$IFDEF VARIANTSUPPORT}
  667.   if (v2^.VType^.atypeid = CSV_Variant) and (V1^.VType^.atypeid <> CSV_Variant) then begin
  668.     v2 := v2^.CV_Variant;
  669.     if v2 = nil then begin
  670.       Perform := False;
  671.       RunError(Self, EVariantIsNil);
  672.       exit;
  673.     end;
  674.   end;
  675. {$ENDIF}
  676.   if V1^.VType^.atypeid = CSV_Record then begin
  677.     if V1.VType <> v2.VType then begin
  678.       Perform := False;
  679.       RunError(Self, ETypeMismatch);
  680.       exit;
  681.     end;
  682.   end else
  683.     if ((V1^.VType^.atypeid <> v2^.VType^.atypeid) and
  684.       not (IsIntRealType(V1) and IsIntRealType(v2)) and
  685.       not (IsStringType(V1) and IsStringType(v2)) and
  686.       not (V1^.VType^.atypeid = CSV_Var)){$IFNDEF NOCLASSES} and
  687.     not ((V1^.VType^.atypeid = CSV_Class) and (v2^.VType^.atypeid = CSV_ClassRef)
  688.       and ((t = ptAs) or (t = ptIs))){$ENDIF} and
  689. {$IFDEF VARIANTSUPPORT}
  690.     not (V1^.VType^.atypeid = CSV_Variant) and
  691. {$ENDIF}
  692.     not (((t = PtSet) or (t = PtEqual) or (t = PtNotEqual)) and
  693.       (v2^.VType^.atypeid = CSV_Special) and ((V1^.VType^.atypeid = CSV_Var){$IFNDEF NOCLASSES}
  694.       or (V1^.VType^.atypeid = CSV_Class) or
  695.       (V1^.VType^.atypeid = CSV_ClassRef){$ENDIF}
  696. {$IFDEF VARIANTSUPPORT} or (V1^.VType^.atypeid = CSV_Variant){$ENDIF}
  697.       or (V1^.VType^.atypeid = CSV_ProcVariable)))
  698.       then begin
  699.       Perform := False;
  700.       RunError(Self, ETypeMismatch);
  701.       exit;
  702.     end;
  703.   Err := False;
  704.   case t of
  705. {$IFNDEF NOCLASSES}
  706.     ptIs: begin
  707. {$IFDEF VARIANTSUPPORT}
  708.         if V1^.VType^.atypeid = CSV_Variant then begin
  709.           V1 := V1^.CV_Variant;
  710.           if V1 = nil then begin
  711.             Perform := False;
  712.             RunError(Self, EVariantIsNil);
  713.             exit;
  714.           end;
  715.           if v2^.VType^.atypeid = CSV_Variant then begin
  716.             v2 := v2^.CV_Variant;
  717.             if v2 = nil then begin
  718.               Perform := False;
  719.               RunError(Self, EVariantIsNil);
  720.               exit;
  721.             end;
  722.           end;
  723.         end;
  724. {$ENDIF}
  725.         case V1^.VType^.atypeid of
  726.           CSV_Class: begin
  727.               if not assigned(v2^.Cv_ClassRef) then begin
  728.                 MakeItBool(False);
  729.               end else begin
  730.                 if not assigned(V1^.CV_Class) then begin
  731.                   MakeItBool(False)
  732.                 end else
  733.                   if IsSameClassFamily(v2^.Cv_ClassRef^.Ext, V1^.CV_Class^.ClassType^.Ext, True) then begin
  734.                     MakeItBool(True);
  735.                   end else begin
  736.                     MakeItBool(False);
  737.                   end;
  738.               end;
  739.             end;
  740.         else begin
  741.             RunError(Self, ETypeMismatch);
  742.             Err := True;
  743.           end;
  744.         end;
  745.       end;
  746.     ptAs: begin
  747. {$IFDEF VARIANTSUPPORT}
  748.         if V1^.VType^.atypeid = CSV_Variant then begin
  749.           V1 := V1^.CV_Variant;
  750.           if V1 = nil then begin
  751.             Perform := False;
  752.             RunError(Self, EVariantIsNil);
  753.             exit;
  754.           end;
  755.           if v2^.VType^.atypeid = CSV_Variant then begin
  756.             v2 := v2^.CV_Variant;
  757.             if v2 = nil then begin
  758.               Perform := False;
  759.               RunError(Self, EVariantIsNil);
  760.               exit;
  761.             end;
  762.           end;
  763.         end;
  764. {$ENDIF}
  765.         case V1^.VType^.atypeid of
  766.           CSV_Class: begin
  767.               if not assigned(v2^.Cv_ClassRef) then begin
  768.                 Err := True;
  769.                 RunError(Self, ETypeMismatch);
  770.               end else begin
  771.                 if not assigned(V1^.CV_Class) then begin
  772.                   RunError(Self, EClassNotCreated);
  773.                   Err := True;
  774.                 end else
  775.                   if IsSameClassFamily(v2^.Cv_ClassRef^.Ext, V1^.CV_Class^.ClassType^.Ext, True) then begin
  776.                     V1^.VType := v2^.Cv_ClassRef;
  777.                   end else begin
  778.                     Err := True;
  779.                     RunError(Self, ETypeMismatch);
  780.                   end;
  781.               end;
  782.             end;
  783.         else begin
  784.             RunError(Self, ETypeMismatch);
  785.             Err := True;
  786.           end;
  787.         end;
  788.       end;
  789. {$ENDIF}
  790.     PtSet: begin
  791.         if IsIntegerType(V1) and not IsIntegerType(v2) then begin
  792.           RunError(Self, ETypeMismatch);
  793.           Err := True;
  794.         end else
  795.           case V1^.VType^.atypeid of
  796.             CSV_Enum: begin
  797.                 if V1^.VType = v2^.VType then begin
  798.                   V1^.CV_Enum := v2^.CV_Enum;
  799.                 end else begin
  800.                   RunError(Self, ETypeMismatch);
  801.                 end;
  802.               end;
  803. {$IFDEF VARIANTSUPPORT}
  804.             CSV_Variant: begin
  805.                 if v2^.VType^.atypeid = CSV_Special then begin
  806.                   if v2^.CV_Spec = 0 then begin
  807.                     DestroyCajVariant(V1^.CV_Variant);
  808.                     V1^.CV_Variant := nil;
  809.                   end;
  810.                 end else begin
  811.                   if v2^.VType^.atypeid = CSV_Variant then begin
  812.                     DestroyCajVariant(V1^.CV_Variant);
  813.                     V1^.CV_Variant := CopyVariant(v2^.CV_Variant);
  814.                   end else begin
  815.                     DestroyCajVariant(V1^.CV_Variant);
  816.                     V1^.CV_Variant := CopyVariant(v2);
  817.                   end;
  818.                 end;
  819.               end;
  820. {$ENDIF}
  821.             CSV_Special: begin
  822.                 V1^.CV_Spec := v2^.CV_Spec;
  823.               end;
  824.             CSV_ProcVariable: begin
  825.                 if v2^.VType^.atypeid = CSV_Special then begin
  826.                   if v2^.CV_Spec = 0 then { nil }  begin
  827.                     V1^.Cv_Proc := nil;
  828. {$IFNDEF NOCLASSES}V1^.Cv_ProcSelf := nil;
  829. {$ENDIF}
  830.                   end;
  831.                 end else if V1^.VType <> v2^.VType then begin
  832.                   if v2^.VType^.Ext = nil then begin
  833.                     if not assigned(v2^.Cv_Proc) then begin
  834.                       RunError(Self, ETypeMismatch);
  835.                       Err := True;
  836.                     end else begin
  837.                       if {$IFNDEF NOCLASSES}(PIFSProcType(V1^.VType^.Ext)^.Method = (PProcedure(v2^.Cv_Proc)^.ClassType = nil)) or {$ENDIF}
  838.                       (PIFSProcType(V1^.VType^.Ext)^.Decl <> PProcedure(v2^.Cv_Proc)^.Decl) then begin
  839.                         RunError(Self, ETypeMismatch);
  840.                         Err := True;
  841.                       end else begin
  842.                         V1^.Cv_Proc := v2^.Cv_Proc;
  843. {$IFNDEF NOCLASSES}V1^.Cv_ProcSelf := v2^.Cv_ProcSelf;
  844. {$ENDIF}
  845.                       end;
  846.                     end;
  847.                   end else begin
  848.                     RunError(Self, ETypeMismatch);
  849.                     Err := True;
  850.                   end;
  851.                 end else begin
  852.                   V1^.Cv_Proc := v2^.Cv_Proc;
  853. {$IFNDEF NOCLASSES}V1^.Cv_ProcSelf := v2^.Cv_ProcSelf;
  854. {$ENDIF}
  855.                 end;
  856.               end;
  857.             CSV_UByte: V1^.Cv_UByte := GetInteger(v2);
  858.             CSV_SByte: V1^.Cv_SByte := GetInteger(v2);
  859.             CSV_Char: begin
  860.                 V1^.Cv_Str := GetString(v2);
  861.                 if Length(V1^.Cv_Str) > 1 then begin
  862.                   Err := True;
  863.                   RunError(Self, ETypeMismatch);
  864.                 end else
  865.                   V1^.Cv_Char := V1^.Cv_Str[1];
  866.               end;
  867.             CSV_UInt16: V1^.Cv_UInt16 := GetInteger(v2);
  868.             CSV_SInt16: V1^.Cv_SInt16 := GetInteger(v2);
  869.             CSV_UInt32: V1^.Cv_UInt32 := GetInteger(v2);
  870.             CSV_SInt32: V1^.Cv_SInt32 := GetInteger(v2);
  871.             CSV_String: V1^.Cv_Str := GetString(v2);
  872.             CSV_Real: V1^.CV_Real := GetReal(v2);
  873.             CSV_Single: V1^.CV_Single := GetReal(v2);
  874.             CSV_Double: V1^.CV_Double := GetReal(v2);
  875.             CSV_Extended: V1^.Cv_Extended := GetReal(v2);
  876.             CSV_Comp: V1^.CV_comp := GetReal(v2);
  877. {$IFNDEF NOCLASSES}
  878.             CSV_ExternalObject: begin
  879.                 if V1^.VType <> v2^.VType then begin
  880.                   Err := True;
  881.                   RunError(Self, ETypeMismatch);
  882.                 end else begin
  883.                   V1^.CV_ExternalObject := v2^.CV_ExternalObject;
  884.                 end;
  885.               end;
  886. {$ENDIF}
  887.             CSV_Bool: begin
  888.                 if v2^.VType^.atypeid = CSV_Bool then
  889.                   V1^.Cv_Bool := v2^.Cv_Bool
  890.                 else begin
  891.                   Err := True;
  892.                   RunError(Self, ETypeMismatch);
  893.                 end;
  894.               end;
  895.             CSV_Record: begin
  896.                 for I := 0 to Longint(V1^.CV_RecItems.Count) - 1 do begin
  897.                   if not Perform(V1^.CV_RecItems.GetItem(I), v2^.CV_RecItems.GetItem(I), PtSet) then begin
  898.                     Err := True;
  899.                     RunError(Self, ETypeMismatch);
  900.                   end;
  901.                 end;
  902.               end;
  903. {$IFNDEF NOCLASSES}
  904.             CSV_Class: begin
  905.                 if v2^.VType^.atypeid = CSV_Special then begin
  906.                   if v2^.CV_Spec = 0 then { nil }  begin
  907.                     V1^.CV_Class := nil;
  908.                   end;
  909.                 end else
  910.                   if not assigned(v2^.CV_Class) then begin
  911.                     V1.CV_Class := nil;
  912.                   end else
  913.                     if IsSameClassFamily(V1^.VType^.Ext, v2^.CV_Class^.ClassType^.Ext, False) then begin
  914.                       V1^.CV_Class := v2^.CV_Class;
  915.                     end else begin
  916.                       Err := True;
  917.                       RunError(Self, ETypeMismatch);
  918.                     end;
  919.               end;
  920. {$ENDIF}
  921.             CSV_Array: begin
  922.                 for I := 0 to Longint(V1^.CV_ArrItems.Count) - 1 do begin
  923.                   DestroyCajVariant(V1^.CV_ArrItems.GetItem(I));
  924.                 end;
  925.                 V1^.CV_ArrItems.Clear;
  926.                 for I := 0 to Longint(v2^.CV_ArrItems.Count) - 1 do begin
  927.                   p := CreateCajVariant(PIfVariant(v2.CV_ArrItems.GetItem(I))^.VType);
  928.                   V1^.CV_ArrItems.Add(p);
  929.                   if not Perform(V1^.CV_ArrItems.GetItem(I), v2^.CV_ArrItems.GetItem(I), PtSet) then begin
  930.                     Err := True;
  931.                     RunError(Self, ETypeMismatch);
  932.                     break;
  933.                   end;
  934.                 end;
  935.               end;
  936.             CSV_Internal: begin
  937.                 V1^.Cv_Int1 := v2^.Cv_Int1;
  938.                 V1^.Cv_Int2 := v2^.Cv_Int2;
  939.               end;
  940. {$IFNDEF NOCLASSES}
  941.             CSV_ClassRef: begin
  942.                 if v2^.VType^.atypeid = CSV_Special then begin
  943.                   if v2^.CV_Spec = 0 then { nil }  begin
  944.                     V1^.Cv_ClassRef := nil;
  945.                   end;
  946.                 end else
  947.  
  948.                   if IsSameClassFamily(V1^.VType^.Ext, v2^.VType^.Ext, True) then
  949.                     V1^.Cv_ClassRef := v2^.Cv_ClassRef
  950.                   else begin
  951.                     RunError(Self, ETypeMismatch);
  952.                     Err := True;
  953.                   end;
  954.               end;
  955. {$ENDIF}
  956.             CSV_Var: begin
  957.                 V1^.VType := v2^.VType;
  958.                 case v2^.VType^.atypeid of
  959.                   CSV_Enum: V1^.CV_Enum := v2^.CV_Enum;
  960.                   CSV_UByte: V1^.Cv_UByte := v2^.Cv_UByte;
  961.                   CSV_SByte: V1^.Cv_SByte := v2^.Cv_SByte;
  962.                   CSV_UInt16: V1^.Cv_UInt16 := v2^.Cv_UInt16;
  963.                   CSV_SInt16: V1^.Cv_SInt16 := v2^.Cv_SInt16;
  964.                   CSV_UInt32: V1^.Cv_UInt32 := v2^.Cv_UInt32;
  965.                   CSV_SInt32: V1^.Cv_SInt32 := v2^.Cv_SInt32;
  966.                   CSV_Char: V1^.Cv_Char := v2^.Cv_Char;
  967.                   CSV_String: V1^.Cv_Str := v2^.Cv_Str;
  968.                   CSV_Real: V1^.CV_Real := v2^.CV_Real;
  969.                   CSV_Single: V1^.CV_Single := v2^.CV_Single;
  970.                   CSV_Double: V1^.CV_Double := v2^.CV_Double;
  971.                   CSV_Extended: V1^.Cv_Extended := v2^.Cv_Extended;
  972.                   CSV_Comp: V1^.CV_comp := v2^.CV_comp;
  973.                   CSV_Bool: V1^.Cv_Bool := v2^.Cv_Bool;
  974.                   CSV_Variant: begin
  975.                       if v2^.CV_Variant = nil then begin
  976.                         V1^.VType := TM_Add(Types, '', CSV_Special, nil);
  977.                         V1^.CV_Spec := 0;
  978.                       end else begin
  979.                         V1 := CopyVariant(v2);
  980.                       end;
  981.                     end;
  982.                   CSV_Record: begin
  983.                       V1^.CV_RecItems := TIfList.Create;
  984.                       for I := 0 to Longint(v2^.CV_RecItems.Count) - 1 do begin
  985.                         V1^.CV_RecItems.Add(CopyVariant(v2^.CV_RecItems.GetItem(I)));
  986.                       end;
  987.                     end;
  988.                   CSV_ProcVariable: begin
  989.                       if v2^.VType^.atypeid = CSV_Special then begin
  990.                         if v2^.CV_Spec = 0 then { nil }  begin
  991.                           V1^.Cv_Proc := nil;
  992. {$IFNDEF NOCLASSES}V1^.Cv_ProcSelf := nil;
  993. {$ENDIF}
  994.                         end;
  995.                       end else begin
  996. {$IFNDEF NOCLASSES}
  997.                         V1^.Cv_ProcSelf := v2^.Cv_ProcSelf;
  998. {$ENDIF}
  999.                         V1^.Cv_Proc := v2^.Cv_Proc;
  1000.                       end;
  1001.                     end;
  1002.                   CSV_Array: begin
  1003.                       V1^.CV_ArrItems := TIfList.Create;
  1004.                       for I := 0 to Longint(v2^.CV_ArrItems.Count) - 1 do begin
  1005.                         p := CreateCajVariant(PIfVariant(v2.CV_ArrItems.GetItem(I))^.VType);
  1006.                         V1^.CV_ArrItems.Add(p);
  1007.                         if not Perform(V1^.CV_ArrItems.GetItem(I), v2^.CV_ArrItems.GetItem(I), PtSet) then begin
  1008.                           Err := True;
  1009.                           RunError(Self, ETypeMismatch);
  1010.                           break;
  1011.                         end;
  1012.                       end;
  1013.                     end;
  1014. {$IFNDEF NOCLASSES}
  1015.                   CSV_Class: begin
  1016.                       if v2^.VType^.atypeid = CSV_Special then begin
  1017.                         if v2^.CV_Spec = 0 then { nil }  begin
  1018.                           V1^.CV_Class := nil;
  1019.                         end;
  1020.                       end else
  1021.                         V1^.CV_Class := v2^.CV_Class;
  1022.                     end;
  1023.                   CSV_ClassRef: begin
  1024.                       if v2^.VType^.atypeid = CSV_Special then begin
  1025.                         if v2^.CV_Spec = 0 then { nil }  begin
  1026.                           V1^.Cv_ClassRef := nil;
  1027.                         end;
  1028.                       end else
  1029.  
  1030.                         V1^.Cv_ClassRef := v2^.Cv_ClassRef;
  1031.                     end;
  1032.                   CSV_ExternalObject: begin
  1033.                       V1^.CV_ExternalObject := v2^.CV_ExternalObject;
  1034.                     end;
  1035. {$ENDIF}
  1036.                   CSV_Internal: begin
  1037.                       V1^.Cv_Int1 := v2^.Cv_Int1;
  1038.                       V1^.Cv_Int2 := v2^.Cv_Int2;
  1039.                     end;
  1040.                 end;
  1041.               end;
  1042.           else begin
  1043.               RunError(Self, ETypeMismatch);
  1044.               Err := True;
  1045.             end;
  1046.           end;
  1047.       end;
  1048.     ptMinus: begin
  1049. {$IFDEF VARIANTSUPPORT}
  1050.         if V1^.VType^.atypeid = CSV_Variant then begin
  1051.           V1 := V1^.CV_Variant;
  1052.           if V1 = nil then begin
  1053.             Perform := False;
  1054.             RunError(Self, EVariantIsNil);
  1055.             exit;
  1056.           end;
  1057.           if v2^.VType^.atypeid = CSV_Variant then begin
  1058.             v2 := v2^.CV_Variant;
  1059.             if v2 = nil then begin
  1060.               Perform := False;
  1061.               RunError(Self, EVariantIsNil);
  1062.               exit;
  1063.             end;
  1064.           end;
  1065.         end;
  1066. {$ENDIF}
  1067.         case V1^.VType^.atypeid of
  1068.           CSV_UByte: begin
  1069.               if IsRealType(v2) then
  1070.                 MakeItReal(V1^.Cv_UByte - GetReal(v2))
  1071.               else
  1072.                 V1^.Cv_UByte := V1^.Cv_UByte - TCSV_UByte(GetInteger(v2));
  1073.             end;
  1074.           CSV_SByte: begin
  1075.               if IsRealType(v2) then
  1076.                 MakeItReal(V1^.Cv_SByte - GetReal(v2))
  1077.               else
  1078.                 V1^.Cv_SByte := V1^.Cv_SByte - TCSV_SByte(GetInteger(v2));
  1079.             end;
  1080.           CSV_UInt16: begin
  1081.               if IsRealType(v2) then
  1082.                 MakeItReal(V1^.Cv_UInt16 - GetReal(v2))
  1083.               else
  1084.                 V1^.Cv_UInt16 := V1^.Cv_UInt16 - TCSV_UInt16(GetInteger(v2));
  1085.             end;
  1086.           CSV_SInt16: begin
  1087.               if IsRealType(v2) then
  1088.                 MakeItReal(V1^.Cv_SInt16 - GetReal(v2))
  1089.               else
  1090.                 V1^.Cv_SInt16 := V1^.Cv_SInt16 - TCSV_SInt16(GetInteger(v2));
  1091.             end;
  1092.           CSV_UInt32: begin
  1093.               if IsRealType(v2) then
  1094.                 MakeItReal(V1^.Cv_UInt32 - GetReal(v2))
  1095.               else
  1096.                 V1^.Cv_UInt32 := V1^.Cv_UInt32 - TCSV_UInt32(GetInteger(v2));
  1097.             end;
  1098.           CSV_SInt32: begin
  1099.               if IsRealType(v2) then
  1100.                 MakeItReal(V1^.Cv_SInt32 - GetReal(v2))
  1101.               else
  1102.                 V1^.Cv_SInt32 := V1^.Cv_SInt32 - TCSV_SInt32(GetInteger(v2));
  1103.             end;
  1104.           CSV_Real: begin
  1105.               V1^.CV_Real := V1^.CV_Real - GetReal(v2);
  1106.             end;
  1107.           CSV_Single: begin
  1108.               V1^.CV_Single := V1^.CV_Single - GetReal(v2);
  1109.             end;
  1110.           CSV_Double: begin
  1111.               V1^.CV_Double := V1^.CV_Double - GetReal(v2);
  1112.             end;
  1113.           CSV_Extended: begin
  1114.               V1^.Cv_Extended := V1^.Cv_Extended - GetReal(v2);
  1115.             end;
  1116.           CSV_Comp: begin
  1117.               V1^.CV_comp := V1^.CV_comp - GetReal(v2);
  1118.             end;
  1119.         else begin
  1120.             RunError(Self, ETypeMismatch);
  1121.             Err := True;
  1122.           end;
  1123.         end { CASE };
  1124.       end;
  1125.     PtPlus: begin
  1126. {$IFDEF VARIANTSUPPORT}
  1127.         if V1^.VType^.atypeid = CSV_Variant then begin
  1128.           V1 := V1^.CV_Variant;
  1129.           if V1 = nil then begin
  1130.             Perform := False;
  1131.             RunError(Self, EVariantIsNil);
  1132.             exit;
  1133.           end;
  1134.           if v2^.VType^.atypeid = CSV_Variant then begin
  1135.             v2 := v2^.CV_Variant;
  1136.             if v2 = nil then begin
  1137.               Perform := False;
  1138.               RunError(Self, EVariantIsNil);
  1139.               exit;
  1140.             end;
  1141.           end;
  1142.         end;
  1143. {$ENDIF}
  1144.         case V1^.VType^.atypeid of
  1145.           CSV_UByte: begin
  1146.               if IsRealType(v2) then
  1147.                 MakeItReal(V1^.Cv_UByte + GetReal(v2))
  1148.               else
  1149.                 V1^.Cv_UByte := V1^.Cv_UByte + TCSV_UByte(GetInteger(v2));
  1150.             end;
  1151.           CSV_SByte: begin
  1152.               if IsRealType(v2) then
  1153.                 MakeItReal(V1^.Cv_SByte + GetReal(v2))
  1154.               else
  1155.                 V1^.Cv_SByte := V1^.Cv_SByte + TCSV_SByte(GetInteger(v2));
  1156.             end;
  1157.           CSV_UInt16: begin
  1158.               if IsRealType(v2) then
  1159.                 MakeItReal(V1^.Cv_UInt16 + GetReal(v2))
  1160.               else
  1161.                 V1^.Cv_UInt16 := V1^.Cv_UInt16 + TCSV_UInt16(GetInteger(v2));
  1162.             end;
  1163.           CSV_SInt16: begin
  1164.               if IsRealType(v2) then
  1165.                 MakeItReal(V1^.Cv_SInt16 + GetReal(v2))
  1166.               else
  1167.                 V1^.Cv_SInt16 := V1^.Cv_SInt16 + TCSV_SInt16(GetInteger(v2));
  1168.             end;
  1169.           CSV_UInt32: begin
  1170.               if IsRealType(v2) then
  1171.                 MakeItReal(V1^.Cv_UInt32 + GetReal(v2))
  1172.               else
  1173.                 V1^.Cv_UInt32 := V1^.Cv_UInt32 + TCSV_UInt32(GetInteger(v2));
  1174.             end;
  1175.           CSV_SInt32: begin
  1176.               if IsRealType(v2) then
  1177.                 MakeItReal(V1^.Cv_SInt32 + GetReal(v2))
  1178.               else
  1179.                 V1^.Cv_SInt32 := V1^.Cv_SInt32 + TCSV_SInt32(GetInteger(v2));
  1180.             end;
  1181.           CSV_Real: begin
  1182.               V1^.CV_Real := V1^.CV_Real + GetReal(v2);
  1183.             end;
  1184.           CSV_Single: begin
  1185.               V1^.CV_Single := V1^.CV_Single + GetReal(v2);
  1186.             end;
  1187.           CSV_Double: begin
  1188.               V1^.CV_Double := V1^.CV_Double + GetReal(v2);
  1189.             end;
  1190.           CSV_Extended: begin
  1191.               V1^.Cv_Extended := V1^.Cv_Extended + GetReal(v2);
  1192.             end;
  1193.           CSV_Comp: begin
  1194.               V1^.CV_comp := V1^.CV_comp + GetReal(v2);
  1195.             end;
  1196.           CSV_Char: begin
  1197.               MakeItString(V1^.Cv_Char + GetString(v2));
  1198.             end;
  1199.           CSV_String: begin
  1200.               V1^.Cv_Str := V1^.Cv_Str + GetString(v2);
  1201.             end;
  1202.         else begin
  1203.             Err := True;
  1204.             RunError(Self, ETypeMismatch);
  1205.           end;
  1206.         end { CASE };
  1207.       end;
  1208.     PtMul: begin
  1209. {$IFDEF VARIANTSUPPORT}
  1210.         if V1^.VType^.atypeid = CSV_Variant then begin
  1211.           V1 := V1^.CV_Variant;
  1212.           if V1 = nil then begin
  1213.             Perform := False;
  1214.             RunError(Self, EVariantIsNil);
  1215.             exit;
  1216.           end;
  1217.           if v2^.VType^.atypeid = CSV_Variant then begin
  1218.             v2 := v2^.CV_Variant;
  1219.             if v2 = nil then begin
  1220.               Perform := False;
  1221.               RunError(Self, EVariantIsNil);
  1222.               exit;
  1223.             end;
  1224.           end;
  1225.         end;
  1226. {$ENDIF}
  1227.         case V1^.VType^.atypeid of
  1228.           CSV_UByte: begin
  1229.               if IsRealType(v2) then
  1230.                 MakeItReal(V1^.Cv_UByte * GetReal(v2))
  1231.               else
  1232.                 V1^.Cv_UByte := V1^.Cv_UByte * TCSV_UByte(GetInteger(v2));
  1233.             end;
  1234.           CSV_SByte: begin
  1235.               if IsRealType(v2) then
  1236.                 MakeItReal(V1^.Cv_SByte * GetReal(v2))
  1237.               else
  1238.                 V1^.Cv_SByte := V1^.Cv_SByte * TCSV_SByte(GetInteger(v2));
  1239.             end;
  1240.           CSV_UInt16: begin
  1241.               if IsRealType(v2) then
  1242.                 MakeItReal(V1^.Cv_UInt16 * GetReal(v2))
  1243.               else
  1244.                 V1^.Cv_UInt16 := V1^.Cv_UInt16 * TCSV_UInt16(GetInteger(v2));
  1245.             end;
  1246.           CSV_SInt16: begin
  1247.               if IsRealType(v2) then
  1248.                 MakeItReal(V1^.Cv_SInt16 * GetReal(v2))
  1249.               else
  1250.                 V1^.Cv_SInt16 := V1^.Cv_SInt16 * TCSV_SInt16(GetInteger(v2));
  1251.             end;
  1252.           CSV_UInt32: begin
  1253.               if IsRealType(v2) then
  1254.                 MakeItReal(V1^.Cv_UInt32 * GetReal(v2))
  1255.               else
  1256.                 V1^.Cv_UInt32 := V1^.Cv_UInt32 * TCSV_UInt32(GetInteger(v2));
  1257.             end;
  1258.           CSV_SInt32: begin
  1259.               if IsRealType(v2) then
  1260.                 MakeItReal(V1^.Cv_SInt32 * GetReal(v2))
  1261.               else
  1262.                 V1^.Cv_SInt32 := V1^.Cv_SInt32 * TCSV_SInt32(GetInteger(v2));
  1263.             end;
  1264.           CSV_Real: begin
  1265.               V1^.CV_Real := V1^.CV_Real * GetReal(v2);
  1266.             end;
  1267.           CSV_Single: begin
  1268.               V1^.CV_Single := V1^.CV_Single * GetReal(v2);
  1269.             end;
  1270.           CSV_Double: begin
  1271.               V1^.CV_Double := V1^.CV_Double * GetReal(v2);
  1272.             end;
  1273.           CSV_Extended: begin
  1274.               V1^.Cv_Extended := V1^.Cv_Extended * GetReal(v2);
  1275.             end;
  1276.           CSV_Comp: begin
  1277.               V1^.CV_comp := V1^.CV_comp * GetReal(v2);
  1278.             end;
  1279.         else begin
  1280.             Err := True;
  1281.             RunError(Self, ETypeMismatch);
  1282.           end;
  1283.         end { CASE };
  1284.       end;
  1285.     ptDiv: begin
  1286. {$IFDEF VARIANTSUPPORT}
  1287.         if V1^.VType^.atypeid = CSV_Variant then begin
  1288.           V1 := V1^.CV_Variant;
  1289.           if V1 = nil then begin
  1290.             Perform := False;
  1291.             RunError(Self, EVariantIsNil);
  1292.             exit;
  1293.           end;
  1294.           if v2^.VType^.atypeid = CSV_Variant then begin
  1295.             v2 := v2^.CV_Variant;
  1296.             if v2 = nil then begin
  1297.               Perform := False;
  1298.               RunError(Self, EVariantIsNil);
  1299.               exit;
  1300.             end;
  1301.           end;
  1302.         end;
  1303. {$ENDIF}
  1304.         if GetReal(v2) = 0 then begin
  1305.           RunError(Self, EDivideByZero);
  1306.           Err := True;
  1307.         end else
  1308.           case V1^.VType^.atypeid of
  1309.             CSV_UByte: begin
  1310.                 MakeItReal(V1^.Cv_UByte / GetReal(v2));
  1311.               end;
  1312.             CSV_SByte: begin
  1313.                 MakeItReal(V1^.Cv_SByte / GetReal(v2));
  1314.               end;
  1315.             CSV_UInt16: begin
  1316.                 MakeItReal(V1^.Cv_UInt16 / GetReal(v2));
  1317.               end;
  1318.             CSV_SInt16: begin
  1319.                 MakeItReal(V1^.Cv_SInt16 / GetReal(v2));
  1320.               end;
  1321.             CSV_UInt32: begin
  1322.                 MakeItReal(V1^.Cv_UInt32 / GetReal(v2));
  1323.               end;
  1324.             CSV_SInt32: begin
  1325.                 MakeItReal(V1^.Cv_SInt32 / GetReal(v2));
  1326.               end;
  1327.             CSV_Real: begin
  1328.                 V1^.CV_Real := V1^.CV_Real / GetReal(v2);
  1329.               end;
  1330.             CSV_Single: begin
  1331.                 V1^.CV_Single := V1^.CV_Single / GetReal(v2);
  1332.               end;
  1333.             CSV_Double: begin
  1334.                 V1^.CV_Double := V1^.CV_Double / GetReal(v2);
  1335.               end;
  1336.             CSV_Extended: begin
  1337.                 V1^.Cv_Extended := V1^.Cv_Extended / GetReal(v2);
  1338.               end;
  1339.             CSV_Comp: begin
  1340.                 V1^.CV_comp := V1^.CV_comp / GetReal(v2);
  1341.               end;
  1342.           else begin
  1343.               Err := True;
  1344.               RunError(Self, ETypeMismatch);
  1345.             end;
  1346.           end { CASE };
  1347.       end; { begin }
  1348.     PtIntDiv: begin
  1349. {$IFDEF VARIANTSUPPORT}
  1350.         if V1^.VType^.atypeid = CSV_Variant then begin
  1351.           V1 := V1^.CV_Variant;
  1352.           if V1 = nil then begin
  1353.             Perform := False;
  1354.             RunError(Self, EVariantIsNil);
  1355.             exit;
  1356.           end;
  1357.           if v2^.VType^.atypeid = CSV_Variant then begin
  1358.             v2 := v2^.CV_Variant;
  1359.             if v2 = nil then begin
  1360.               Perform := False;
  1361.               RunError(Self, EVariantIsNil);
  1362.               exit;
  1363.             end;
  1364.           end;
  1365.         end;
  1366. {$ENDIF}
  1367.         if not IsIntegerType(v2) then begin
  1368.           RunError(Self, ETypeMismatch);
  1369.           Perform := False;
  1370.           exit;
  1371.         end;
  1372.         if GetInteger(v2) = 0 then begin
  1373.           RunError(Self, EDivideByZero);
  1374.           Perform := False;
  1375.           exit;
  1376.         end;
  1377.         case V1^.VType^.atypeid of
  1378.           CSV_UByte: begin
  1379.               V1^.Cv_UByte := V1^.Cv_UByte div TCSV_UByte(GetInteger(v2));
  1380.             end;
  1381.           CSV_SByte: begin
  1382.               V1^.Cv_SByte := V1^.Cv_SByte div TCSV_SByte(GetInteger(v2));
  1383.             end;
  1384.           CSV_UInt16: begin
  1385.               V1^.Cv_UInt16 := V1^.Cv_UInt16 div TCSV_UInt16(GetInteger(v2));
  1386.             end;
  1387.           CSV_SInt16: begin
  1388.               V1^.Cv_SInt16 := V1^.Cv_SInt16 div TCSV_SInt16(GetInteger(v2));
  1389.             end;
  1390.           CSV_UInt32: begin
  1391.               V1^.Cv_UInt32 := V1^.Cv_UInt32 div TCSV_UInt32(GetInteger(v2));
  1392.             end;
  1393.           CSV_SInt32: begin
  1394.               V1^.Cv_SInt32 := V1^.Cv_SInt32 div TCSV_SInt32(GetInteger(v2));
  1395.             end;
  1396.         else begin
  1397.             Err := True;
  1398.             RunError(Self, ETypeMismatch);
  1399.           end;
  1400.         end;
  1401.       end;
  1402.     PtIntMod: begin
  1403. {$IFDEF VARIANTSUPPORT}
  1404.         if V1^.VType^.atypeid = CSV_Variant then begin
  1405.           V1 := V1^.CV_Variant;
  1406.           if V1 = nil then begin
  1407.             Perform := False;
  1408.             RunError(Self, EVariantIsNil);
  1409.             exit;
  1410.           end;
  1411.           if v2^.VType^.atypeid = CSV_Variant then begin
  1412.             v2 := v2^.CV_Variant;
  1413.             if v2 = nil then begin
  1414.               Perform := False;
  1415.               RunError(Self, EVariantIsNil);
  1416.               exit;
  1417.             end;
  1418.           end;
  1419.         end;
  1420. {$ENDIF}
  1421.         if not IsIntegerType(v2) then begin
  1422.           Perform := False;
  1423.           RunError(Self, ETypeMismatch);
  1424.           exit;
  1425.         end;
  1426.         case V1^.VType^.atypeid of
  1427.           CSV_UByte: begin
  1428.               V1^.Cv_UByte := V1^.Cv_UByte mod TCSV_UByte(GetInteger(v2));
  1429.             end;
  1430.           CSV_SByte: begin
  1431.               V1^.Cv_SByte := V1^.Cv_SByte mod TCSV_SByte(GetInteger(v2));
  1432.             end;
  1433.           CSV_UInt16: begin
  1434.               V1^.Cv_UInt16 := V1^.Cv_UInt16 mod TCSV_UInt16(GetInteger(v2));
  1435.             end;
  1436.           CSV_SInt16: begin
  1437.               V1^.Cv_SInt16 := V1^.Cv_SInt16 mod TCSV_SInt16(GetInteger(v2));
  1438.             end;
  1439.           CSV_UInt32: begin
  1440.               V1^.Cv_UInt32 := V1^.Cv_UInt32 mod TCSV_UInt32(GetInteger(v2));
  1441.             end;
  1442.           CSV_SInt32: begin
  1443.               V1^.Cv_SInt32 := V1^.Cv_SInt32 mod TCSV_SInt32(GetInteger(v2));
  1444.             end;
  1445.         else begin
  1446.             Err := True;
  1447.             RunError(Self, ETypeMismatch);
  1448.           end;
  1449.         end;
  1450.       end;
  1451.     PtAnd: begin
  1452. {$IFDEF VARIANTSUPPORT}
  1453.         if V1^.VType^.atypeid = CSV_Variant then begin
  1454.           V1 := V1^.CV_Variant;
  1455.           if V1 = nil then begin
  1456.             Perform := False;
  1457.             RunError(Self, EVariantIsNil);
  1458.             exit;
  1459.           end;
  1460.           if v2^.VType^.atypeid = CSV_Variant then begin
  1461.             v2 := v2^.CV_Variant;
  1462.             if v2 = nil then begin
  1463.               Perform := False;
  1464.               RunError(Self, EVariantIsNil);
  1465.               exit;
  1466.             end;
  1467.           end;
  1468.         end;
  1469. {$ENDIF}
  1470.         if (not IsIntegerType(v2)) and (not ISBooleanType(v2)) then begin
  1471.           RunError(Self, ETypeMismatch);
  1472.           Perform := False;
  1473.           exit;
  1474.         end;
  1475.         case V1^.VType^.atypeid of
  1476.           CSV_UByte: begin
  1477.               V1^.Cv_UByte := V1^.Cv_UByte and TCSV_UByte(GetInteger(v2));
  1478.             end;
  1479.           CSV_SByte: begin
  1480.               V1^.Cv_SByte := V1^.Cv_SByte and TCSV_SByte(GetInteger(v2));
  1481.             end;
  1482.           CSV_UInt16: begin
  1483.               V1^.Cv_UInt16 := V1^.Cv_UInt16 and TCSV_UInt16(GetInteger(v2));
  1484.             end;
  1485.           CSV_SInt16: begin
  1486.               V1^.Cv_SInt16 := V1^.Cv_SInt16 and TCSV_SInt16(GetInteger(v2));
  1487.             end;
  1488.           CSV_UInt32: begin
  1489.               V1^.Cv_UInt32 := V1^.Cv_UInt32 and TCSV_UInt32(GetInteger(v2));
  1490.             end;
  1491.           CSV_SInt32: begin
  1492.               V1^.Cv_SInt32 := V1^.Cv_SInt32 and TCSV_SInt32(GetInteger(v2));
  1493.             end;
  1494.           CSV_Bool: begin
  1495.               V1^.Cv_Bool := V1^.Cv_Bool and GetBoolean(v2);
  1496.             end;
  1497.         else begin
  1498.             Err := True;
  1499.             RunError(Self, ETypeMismatch);
  1500.           end;
  1501.         end;
  1502.       end;
  1503.     ptOr: begin
  1504. {$IFDEF VARIANTSUPPORT}
  1505.         if V1^.VType^.atypeid = CSV_Variant then begin
  1506.           V1 := V1^.CV_Variant;
  1507.           if V1 = nil then begin
  1508.             Perform := False;
  1509.             RunError(Self, EVariantIsNil);
  1510.             exit;
  1511.           end;
  1512.           if v2^.VType^.atypeid = CSV_Variant then begin
  1513.             v2 := v2^.CV_Variant;
  1514.             if v2 = nil then begin
  1515.               Perform := False;
  1516.               RunError(Self, EVariantIsNil);
  1517.               exit;
  1518.             end;
  1519.           end;
  1520.         end;
  1521. {$ENDIF}
  1522.         if (not IsIntegerType(v2)) and (not ISBooleanType(v2)) then begin
  1523.           RunError(Self, ETypeMismatch);
  1524.           Perform := False;
  1525.           exit;
  1526.         end;
  1527.         case V1^.VType^.atypeid of
  1528.           CSV_UByte: begin
  1529.               V1^.Cv_UByte := V1^.Cv_UByte or TCSV_UByte(GetInteger(v2));
  1530.             end;
  1531.           CSV_SByte: begin
  1532.               V1^.Cv_SByte := V1^.Cv_SByte or TCSV_SByte(GetInteger(v2));
  1533.             end;
  1534.           CSV_UInt16: begin
  1535.               V1^.Cv_UInt16 := V1^.Cv_UInt16 or TCSV_UInt16(GetInteger(v2));
  1536.             end;
  1537.           CSV_SInt16: begin
  1538.               V1^.Cv_SInt16 := V1^.Cv_SInt16 or TCSV_SInt16(GetInteger(v2));
  1539.             end;
  1540.           CSV_UInt32: begin
  1541.               V1^.Cv_UInt32 := V1^.Cv_UInt32 or TCSV_UInt32(GetInteger(v2));
  1542.             end;
  1543.           CSV_SInt32: begin
  1544.               V1^.Cv_SInt32 := V1^.Cv_SInt32 or TCSV_SInt32(GetInteger(v2));
  1545.             end;
  1546.           CSV_Bool: begin
  1547.               V1^.Cv_Bool := V1^.Cv_Bool or GetBoolean(v2);
  1548.             end;
  1549.         else begin
  1550.             Err := True;
  1551.             RunError(Self, ETypeMismatch);
  1552.  
  1553.           end;
  1554.         end;
  1555.       end;
  1556.     ptXor: begin
  1557. {$IFDEF VARIANTSUPPORT}
  1558.         if V1^.VType^.atypeid = CSV_Variant then begin
  1559.           V1 := V1^.CV_Variant;
  1560.           if V1 = nil then begin
  1561.             Perform := False;
  1562.             RunError(Self, EVariantIsNil);
  1563.             exit;
  1564.           end;
  1565.           if v2^.VType^.atypeid = CSV_Variant then begin
  1566.             v2 := v2^.CV_Variant;
  1567.             if v2 = nil then begin
  1568.               Perform := False;
  1569.               RunError(Self, EVariantIsNil);
  1570.               exit;
  1571.             end;
  1572.           end;
  1573.         end;
  1574. {$ENDIF}
  1575.         if (not IsIntegerType(v2)) and (not ISBooleanType(v2)) then begin
  1576.           Perform := False;
  1577.           RunError(Self, ETypeMismatch);
  1578.           exit;
  1579.         end;
  1580.         case V1^.VType^.atypeid of
  1581.           CSV_UByte: begin
  1582.               V1^.Cv_UByte := V1^.Cv_UByte xor TCSV_UByte(GetInteger(v2));
  1583.             end;
  1584.           CSV_SByte: begin
  1585.               V1^.Cv_SByte := V1^.Cv_SByte xor TCSV_SByte(GetInteger(v2));
  1586.             end;
  1587.           CSV_UInt16: begin
  1588.               V1^.Cv_UInt16 := V1^.Cv_UInt16 xor TCSV_UInt16(GetInteger(v2));
  1589.             end;
  1590.           CSV_SInt16: begin
  1591.               V1^.Cv_SInt16 := V1^.Cv_SInt16 xor TCSV_SInt16(GetInteger(v2));
  1592.             end;
  1593.           CSV_UInt32: begin
  1594.               V1^.Cv_UInt32 := V1^.Cv_UInt32 xor TCSV_UInt32(GetInteger(v2));
  1595.             end;
  1596.           CSV_SInt32: begin
  1597.               V1^.Cv_SInt32 := V1^.Cv_SInt32 xor TCSV_SInt32(GetInteger(v2));
  1598.             end;
  1599.           CSV_Bool: begin
  1600.               V1^.Cv_Bool := V1^.Cv_Bool xor GetBoolean(v2);
  1601.             end;
  1602.         else begin
  1603.             Err := True;
  1604.             RunError(Self, ETypeMismatch);
  1605.           end;
  1606.         end;
  1607.       end;
  1608.     PtShr: begin
  1609. {$IFDEF VARIANTSUPPORT}
  1610.         if V1^.VType^.atypeid = CSV_Variant then begin
  1611.           V1 := V1^.CV_Variant;
  1612.           if V1 = nil then begin
  1613.             Perform := False;
  1614.             RunError(Self, EVariantIsNil);
  1615.             exit;
  1616.           end;
  1617.           if v2^.VType^.atypeid = CSV_Variant then begin
  1618.             v2 := v2^.CV_Variant;
  1619.             if v2 = nil then begin
  1620.               Perform := False;
  1621.               RunError(Self, EVariantIsNil);
  1622.               exit;
  1623.             end;
  1624.           end;
  1625.         end;
  1626. {$ENDIF}
  1627.         if not IsIntegerType(v2) then begin
  1628.           Perform := True;
  1629.           RunError(Self, ETypeMismatch);
  1630.           exit;
  1631.         end;
  1632.         case V1^.VType^.atypeid of
  1633.           CSV_UByte: begin
  1634.               V1^.Cv_UByte := V1^.Cv_UByte shr TCSV_UByte(GetInteger(v2));
  1635.             end;
  1636.           CSV_SByte: begin
  1637.               V1^.Cv_SByte := V1^.Cv_SByte shr TCSV_SByte(GetInteger(v2));
  1638.             end;
  1639.           CSV_UInt16: begin
  1640.               V1^.Cv_UInt16 := V1^.Cv_UInt16 shr TCSV_UInt16(GetInteger(v2));
  1641.             end;
  1642.           CSV_SInt16: begin
  1643.               V1^.Cv_SInt16 := V1^.Cv_SInt16 shr TCSV_SInt16(GetInteger(v2));
  1644.             end;
  1645.           CSV_UInt32: begin
  1646.               V1^.Cv_UInt32 := V1^.Cv_UInt32 shr TCSV_UInt32(GetInteger(v2));
  1647.             end;
  1648.           CSV_SInt32: begin
  1649.               V1^.Cv_SInt32 := V1^.Cv_SInt32 shr TCSV_SInt32(GetInteger(v2));
  1650.             end;
  1651.         else begin
  1652.             Err := True;
  1653.             RunError(Self, ETypeMismatch);
  1654.           end;
  1655.         end;
  1656.       end;
  1657.     PtShl: begin
  1658. {$IFDEF VARIANTSUPPORT}
  1659.         if V1^.VType^.atypeid = CSV_Variant then begin
  1660.           V1 := V1^.CV_Variant;
  1661.           if V1 = nil then begin
  1662.             Perform := False;
  1663.             RunError(Self, EVariantIsNil);
  1664.             exit;
  1665.           end;
  1666.           if v2^.VType^.atypeid = CSV_Variant then begin
  1667.             v2 := v2^.CV_Variant;
  1668.             if v2 = nil then begin
  1669.               Perform := False;
  1670.               RunError(Self, EVariantIsNil);
  1671.               exit;
  1672.             end;
  1673.           end;
  1674.         end;
  1675. {$ENDIF}
  1676.         if not IsIntegerType(v2) then begin
  1677.           Perform := True;
  1678.           RunError(Self, ETypeMismatch);
  1679.           exit;
  1680.         end;
  1681.         case V1^.VType^.atypeid of
  1682.           CSV_UByte: begin
  1683.               V1^.Cv_UByte := V1^.Cv_UByte shl TCSV_UByte(GetInteger(v2));
  1684.             end;
  1685.           CSV_SByte: begin
  1686.               V1^.Cv_SByte := V1^.Cv_SByte shl TCSV_SByte(GetInteger(v2));
  1687.             end;
  1688.           CSV_UInt16: begin
  1689.               V1^.Cv_UInt16 := V1^.Cv_UInt16 shl TCSV_UInt16(GetInteger(v2));
  1690.             end;
  1691.           CSV_SInt16: begin
  1692.               V1^.Cv_SInt16 := V1^.Cv_SInt16 shl TCSV_SInt16(GetInteger(v2));
  1693.             end;
  1694.           CSV_UInt32: begin
  1695.               V1^.Cv_UInt32 := V1^.Cv_UInt32 shl TCSV_UInt32(GetInteger(v2));
  1696.             end;
  1697.           CSV_SInt32: begin
  1698.               V1^.Cv_SInt32 := V1^.Cv_SInt32 shl TCSV_SInt32(GetInteger(v2));
  1699.             end;
  1700.         else begin
  1701.             Err := True;
  1702.             RunError(Self, ETypeMismatch);
  1703.           end;
  1704.         end;
  1705.       end;
  1706.     PtGreater: begin
  1707. {$IFDEF VARIANTSUPPORT}
  1708.         if (V1^.VType^.atypeid = CSV_Variant) and (V1^.CV_Variant = nil) then begin
  1709.           Perform := False;
  1710.           RunError(Self, EVariantIsNil);
  1711.           exit;
  1712.         end;
  1713.         if (v2^.VType^.atypeid = CSV_Variant) and (v2^.CV_Variant = nil) then begin
  1714.           Perform := False;
  1715.           RunError(Self, EVariantIsNil);
  1716.           exit;
  1717.         end;
  1718. {$ENDIF}
  1719.         case V1^.VType^.atypeid of
  1720.           CSV_Enum: begin
  1721.               if v2^.VType = V1^.VType then begin
  1722.                 MakeItBool(V1^.CV_Enum > v2^.CV_Enum);
  1723.               end else begin
  1724.                 Err := True;
  1725.                 RunError(Self, ETypeMismatch);
  1726.               end;
  1727.             end;
  1728.           CSV_UByte: if IsRealType(v2) then
  1729.               MakeItBool(V1^.Cv_UByte > GetReal(v2))
  1730.             else
  1731.               MakeItBool(V1^.Cv_UByte > TCSV_UByte(GetInteger(v2)));
  1732.           CSV_SByte: if IsRealType(v2) then
  1733.               MakeItBool(V1^.Cv_SByte > GetReal(v2))
  1734.             else
  1735.               MakeItBool(V1^.Cv_SByte > TCSV_SByte(GetInteger(v2)));
  1736.           CSV_Char: if v2^.VType^.atypeid = CSV_Char then
  1737.               MakeItBool(V1^.Cv_Char > v2^.Cv_Char)
  1738.             else if (v2^.Vtype^.ATypeid = CSV_String) and (Length(v2^.CV_Str) = 1) then
  1739.             begin
  1740.               MakeItBool(V1^.CV_Char > v2^.CV_Str[1]);
  1741.             end else begin
  1742.               Err := True;
  1743.               RunError(Self, ETypeMismatch);
  1744.             end;
  1745.           CSV_UInt16: if IsRealType(v2) then
  1746.               MakeItBool(V1^.Cv_UInt16 > GetReal(v2))
  1747.             else
  1748.               MakeItBool(V1^.Cv_UInt16 > TCSV_UInt16(GetInteger(v2)));
  1749.           CSV_SInt16: if IsRealType(v2) then
  1750.               MakeItBool(V1^.Cv_SInt16 > GetReal(v2))
  1751.             else
  1752.               MakeItBool(V1^.Cv_SInt16 > TCSV_SInt16(GetInteger(v2)));
  1753.           CSV_UInt32: if IsRealType(v2) then
  1754.               MakeItBool(V1^.Cv_UInt32 > GetReal(v2))
  1755.             else
  1756.               MakeItBool(V1^.Cv_UInt32 > TCSV_UInt32(GetInteger(v2)));
  1757.           CSV_SInt32: if IsRealType(v2) then
  1758.               MakeItBool(V1^.Cv_SInt32 > GetReal(v2))
  1759.             else
  1760.               MakeItBool(V1^.Cv_SInt32 > TCSV_SInt32(GetInteger(v2)));
  1761.           CSV_Real: MakeItBool(V1^.CV_Real > GetReal(v2));
  1762.           CSV_Single: MakeItBool(V1^.CV_Single > GetReal(v2));
  1763.           CSV_Double: MakeItBool(V1^.CV_Double > GetReal(v2));
  1764.           CSV_Extended: MakeItBool(V1^.Cv_Extended > GetReal(v2));
  1765.           CSV_Comp: MakeItBool(V1^.CV_comp > GetReal(v2));
  1766.           CSV_Bool: MakeItBool(V1^.Cv_Bool > v2^.Cv_Bool);
  1767.           CSV_String: MakeItBool(V1^.Cv_Str > v2^.Cv_Str);
  1768.         else begin
  1769.             Err := True;
  1770.             RunError(Self, ETypeMismatch);
  1771.           end;
  1772.         end; {case item}
  1773.       end;
  1774.     PtLess: begin
  1775. {$IFDEF VARIANTSUPPORT}
  1776.         if (V1^.VType^.atypeid = CSV_Variant) and (V1^.CV_Variant = nil) then begin
  1777.           Perform := False;
  1778.           RunError(Self, EVariantIsNil);
  1779.           exit;
  1780.         end;
  1781.         if (v2^.VType^.atypeid = CSV_Variant) and (v2^.CV_Variant = nil) then begin
  1782.           Perform := False;
  1783.           RunError(Self, EVariantIsNil);
  1784.           exit;
  1785.         end;
  1786. {$ENDIF}
  1787.         case V1^.VType^.atypeid of
  1788.           CSV_Enum: begin
  1789.               if v2^.VType = V1^.VType then begin
  1790.                 MakeItBool(V1^.CV_Enum < v2^.CV_Enum);
  1791.               end else begin
  1792.                 Err := True;
  1793.                 RunError(Self, ETypeMismatch);
  1794.               end;
  1795.             end;
  1796.           CSV_UByte: if IsRealType(v2) then
  1797.               MakeItBool(V1^.Cv_UByte < GetReal(v2))
  1798.             else
  1799.               MakeItBool(V1^.Cv_UByte < TCSV_UByte(GetInteger(v2)));
  1800.           CSV_SByte: if IsRealType(v2) then
  1801.               MakeItBool(V1^.Cv_SByte < GetReal(v2))
  1802.             else
  1803.               MakeItBool(V1^.Cv_SByte < TCSV_SByte(GetInteger(v2)));
  1804.           CSV_Char: if v2^.VType^.atypeid = CSV_Char then
  1805.               MakeItBool(V1^.Cv_Char < v2^.Cv_Char)
  1806.             else if (v2^.Vtype^.ATypeid = CSV_String) and (Length(v2^.CV_Str) = 1) then
  1807.             begin
  1808.               MakeItBool(V1^.CV_Char < v2^.CV_Str[1]);
  1809.             end
  1810.             else begin
  1811.               Err := True;
  1812.               RunError(Self, ETypeMismatch);
  1813.             end;
  1814.  
  1815.           CSV_UInt16: if IsRealType(v2) then
  1816.               MakeItBool(V1^.Cv_UInt16 < GetReal(v2))
  1817.             else
  1818.               MakeItBool(V1^.Cv_UInt16 < TCSV_UInt16(GetInteger(v2)));
  1819.           CSV_SInt16: if IsRealType(v2) then
  1820.               MakeItBool(V1^.Cv_SInt16 < GetReal(v2))
  1821.             else
  1822.               MakeItBool(V1^.Cv_SInt16 < TCSV_SInt16(GetInteger(v2)));
  1823.           CSV_UInt32: if IsRealType(v2) then
  1824.               MakeItBool(V1^.Cv_UInt32 < GetReal(v2))
  1825.             else
  1826.               MakeItBool(V1^.Cv_UInt32 < TCSV_UInt32(GetInteger(v2)));
  1827.           CSV_SInt32: if IsRealType(v2) then
  1828.               MakeItBool(V1^.Cv_SInt32 < GetReal(v2))
  1829.             else
  1830.               MakeItBool(V1^.Cv_SInt32 < TCSV_SInt32(GetInteger(v2)));
  1831.           CSV_Real: MakeItBool(V1^.CV_Real < GetReal(v2));
  1832.           CSV_Single: MakeItBool(V1^.CV_Single < GetReal(v2));
  1833.           CSV_Double: MakeItBool(V1^.CV_Double < GetReal(v2));
  1834.           CSV_Extended: MakeItBool(V1^.Cv_Extended < GetReal(v2));
  1835.           CSV_Comp: MakeItBool(V1^.CV_comp < GetReal(v2));
  1836.           CSV_Bool: MakeItBool(V1^.Cv_Bool < v2^.Cv_Bool);
  1837.           CSV_String: MakeItBool(V1^.Cv_Str < v2^.Cv_Str);
  1838.         else begin
  1839.             Err := True;
  1840.             RunError(Self, ETypeMismatch);
  1841.           end;
  1842.         end; {case item}
  1843.       end;
  1844.     PtGreaterEqual: begin
  1845. {$IFDEF VARIANTSUPPORT}
  1846.         if (V1^.VType^.atypeid = CSV_Variant) and (V1^.CV_Variant = nil) then begin
  1847.           Perform := False;
  1848.           RunError(Self, EVariantIsNil);
  1849.           exit;
  1850.         end;
  1851.         if (v2^.VType^.atypeid = CSV_Variant) and (v2^.CV_Variant = nil) then begin
  1852.           Perform := False;
  1853.           RunError(Self, EVariantIsNil);
  1854.           exit;
  1855.         end;
  1856. {$ENDIF}
  1857.         case V1^.VType^.atypeid of
  1858.           CSV_Enum: begin
  1859.               if v2^.VType = V1^.VType then begin
  1860.                 MakeItBool(V1^.CV_Enum >= v2^.CV_Enum);
  1861.               end else begin
  1862.                 Err := True;
  1863.                 RunError(Self, ETypeMismatch);
  1864.               end;
  1865.             end;
  1866.           CSV_UByte: if IsRealType(v2) then
  1867.               MakeItBool(V1^.Cv_UByte >= GetReal(v2))
  1868.             else
  1869.               MakeItBool(V1^.Cv_UByte >= TCSV_UByte(GetInteger(v2)));
  1870.           CSV_SByte: if IsRealType(v2) then
  1871.               MakeItBool(V1^.Cv_SByte >= GetReal(v2))
  1872.             else
  1873.               MakeItBool(V1^.Cv_SByte >= TCSV_SByte(GetInteger(v2)));
  1874.           CSV_Char: if v2^.VType^.atypeid = CSV_Char then
  1875.               MakeItBool(V1^.Cv_Char >= v2^.Cv_Char)
  1876.             else if (v2^.Vtype^.ATypeid = CSV_String) and (Length(v2^.CV_Str) = 1) then
  1877.             begin
  1878.               MakeItBool(V1^.CV_Char >= v2^.CV_Str[1]);
  1879.             end
  1880.             else begin
  1881.               Err := True;
  1882.               RunError(Self, ETypeMismatch);
  1883.             end;
  1884.           CSV_UInt16: if IsRealType(v2) then
  1885.               MakeItBool(V1^.Cv_UInt16 >= GetReal(v2))
  1886.             else
  1887.               MakeItBool(V1^.Cv_UInt16 >= TCSV_UInt16(GetInteger(v2)));
  1888.           CSV_SInt16: if IsRealType(v2) then
  1889.               MakeItBool(V1^.Cv_SInt16 >= GetReal(v2))
  1890.             else
  1891.               MakeItBool(V1^.Cv_SInt16 >= TCSV_SInt16(GetInteger(v2)));
  1892.           CSV_UInt32: if IsRealType(v2) then
  1893.               MakeItBool(V1^.Cv_UInt32 >= GetReal(v2))
  1894.             else
  1895.               MakeItBool(V1^.Cv_UInt32 >= TCSV_UInt32(GetInteger(v2)));
  1896.           CSV_SInt32: if IsRealType(v2) then
  1897.               MakeItBool(V1^.Cv_SInt32 >= GetReal(v2))
  1898.             else
  1899.               MakeItBool(V1^.Cv_SInt32 >= TCSV_SInt32(GetInteger(v2)));
  1900.           CSV_Real: MakeItBool(V1^.CV_Real >= GetReal(v2));
  1901.           CSV_Single: MakeItBool(V1^.CV_Single >= GetReal(v2));
  1902.           CSV_Double: MakeItBool(V1^.CV_Double >= GetReal(v2));
  1903.           CSV_Extended: MakeItBool(V1^.Cv_Extended >= GetReal(v2));
  1904.           CSV_Comp: MakeItBool(V1^.CV_comp >= GetReal(v2));
  1905.           CSV_Bool: MakeItBool(V1^.Cv_Bool >= v2^.Cv_Bool);
  1906.           CSV_String: MakeItBool(V1^.Cv_Str >= v2^.Cv_Str);
  1907.         else begin
  1908.             Err := True;
  1909.             RunError(Self, ETypeMismatch);
  1910.           end;
  1911.         end; {case item}
  1912.       end;
  1913.     PtLessEqual: begin
  1914. {$IFDEF VARIANTSUPPORT}
  1915.         if (V1^.VType^.atypeid = CSV_Variant) and (V1^.CV_Variant = nil) then begin
  1916.           Perform := False;
  1917.           RunError(Self, EVariantIsNil);
  1918.           exit;
  1919.         end;
  1920.         if (v2^.VType^.atypeid = CSV_Variant) and (v2^.CV_Variant = nil) then begin
  1921.           Perform := False;
  1922.           RunError(Self, EVariantIsNil);
  1923.           exit;
  1924.         end;
  1925. {$ENDIF}
  1926.         case V1^.VType^.atypeid of
  1927.           CSV_Enum: begin
  1928.               if v2^.VType = V1^.VType then begin
  1929.                 MakeItBool(V1^.CV_Enum <= v2^.CV_Enum);
  1930.               end else begin
  1931.                 Err := True;
  1932.                 RunError(Self, ETypeMismatch);
  1933.               end;
  1934.             end;
  1935.           CSV_UByte: if IsRealType(v2) then
  1936.               MakeItBool(V1^.Cv_UByte <= GetReal(v2))
  1937.             else
  1938.               MakeItBool(V1^.Cv_UByte <= TCSV_UByte(GetInteger(v2)));
  1939.           CSV_SByte: if IsRealType(v2) then
  1940.               MakeItBool(V1^.Cv_SByte <= GetReal(v2))
  1941.             else
  1942.               MakeItBool(V1^.Cv_SByte <= TCSV_SByte(GetInteger(v2)));
  1943.           CSV_Char: if v2^.VType^.atypeid = CSV_Char then
  1944.               MakeItBool(V1^.Cv_Char <= v2^.Cv_Char)
  1945.             else if (v2^.Vtype^.ATypeid = CSV_String) and (Length(v2^.CV_Str) = 1) then
  1946.             begin
  1947.               MakeItBool(V1^.CV_Char <= v2^.CV_Str[1]);
  1948.             end
  1949.             else begin
  1950.               Err := True;
  1951.               RunError(Self, ETypeMismatch);
  1952.             end;
  1953.           CSV_UInt16: if IsRealType(v2) then
  1954.               MakeItBool(V1^.Cv_UInt16 <= GetReal(v2))
  1955.             else
  1956.               MakeItBool(V1^.Cv_UInt16 <= TCSV_UInt16(GetInteger(v2)));
  1957.           CSV_SInt16: if IsRealType(v2) then
  1958.               MakeItBool(V1^.Cv_SInt16 <= GetReal(v2))
  1959.             else
  1960.               MakeItBool(V1^.Cv_SInt16 <= TCSV_SInt16(GetInteger(v2)));
  1961.           CSV_UInt32: if IsRealType(v2) then
  1962.               MakeItBool(V1^.Cv_UInt32 <= GetReal(v2))
  1963.             else
  1964.               MakeItBool(V1^.Cv_UInt32 <= TCSV_UInt32(GetInteger(v2)));
  1965.           CSV_SInt32: if IsRealType(v2) then
  1966.               MakeItBool(V1^.Cv_SInt32 <= GetReal(v2))
  1967.             else
  1968.               MakeItBool(V1^.Cv_SInt32 <= TCSV_SInt32(GetInteger(v2)));
  1969.           CSV_Real: MakeItBool(V1^.CV_Real <= GetReal(v2));
  1970.           CSV_Single: MakeItBool(V1^.CV_Single <= GetReal(v2));
  1971.           CSV_Double: MakeItBool(V1^.CV_Double <= GetReal(v2));
  1972.           CSV_Extended: MakeItBool(V1^.Cv_Extended <= GetReal(v2));
  1973.           CSV_Comp: MakeItBool(V1^.CV_comp <= GetReal(v2));
  1974.           CSV_Bool: MakeItBool(V1^.Cv_Bool <= v2^.Cv_Bool);
  1975.           CSV_String: MakeItBool(V1^.Cv_Str <= v2^.Cv_Str);
  1976.         else begin
  1977.             Err := True;
  1978.             RunError(Self, ETypeMismatch);
  1979.           end;
  1980.         end; {case item}
  1981.       end;
  1982.     PtEqual: begin
  1983.         case V1^.VType^.atypeid of
  1984. {$IFDEF VARIANTSUPPORT}
  1985.           CSV_Variant: begin
  1986.               if v2^.VType^.atypeid = CSV_Variant then begin
  1987.                 if (V1^.CV_Variant = nil) or (v2^.CV_Variant = nil) then begin
  1988.                   MakeItBool(V1^.CV_Variant = v2^.CV_Variant);
  1989.                 end else begin
  1990.                   Err := not Perform(V1^.CV_Variant, v2^.CV_Variant, t);
  1991.                 end;
  1992.               end else begin
  1993.                 if v2^.VType^.atypeid = CSV_Special then begin
  1994.                   if v2^.CV_Spec = 0 then begin
  1995.                     MakeItBool(V1^.CV_Variant = nil);
  1996.                   end;
  1997.                 end else if not assigned(V1^.CV_Variant) then begin
  1998.                   RunError(Self, EVariantIsNil);
  1999.                   Perform := False;
  2000.                   exit;
  2001.                 end else
  2002.                   Err := not Perform(V1^.CV_Variant, v2, t);
  2003.               end;
  2004.             end;
  2005. {$ENDIF}
  2006.           CSV_Enum: begin
  2007.               if v2^.VType = V1^.VType then begin
  2008.                 MakeItBool(V1^.CV_Enum = v2^.CV_Enum);
  2009.               end else begin
  2010.                 Err := True;
  2011.                 RunError(Self, ETypeMismatch);
  2012.               end;
  2013.             end;
  2014.           CSV_UByte: if IsRealType(v2) then
  2015.               MakeItBool(V1^.Cv_UByte = GetReal(v2))
  2016.             else
  2017.               MakeItBool(V1^.Cv_UByte = TCSV_UByte(GetInteger(v2)));
  2018.           CSV_SByte: if IsRealType(v2) then
  2019.               MakeItBool(V1^.Cv_SByte = GetReal(v2))
  2020.             else
  2021.               MakeItBool(V1^.Cv_SByte = TCSV_SByte(GetInteger(v2)));
  2022.           CSV_Char: if v2^.VType^.atypeid = CSV_Char then
  2023.               MakeItBool(V1^.Cv_Char = v2^.Cv_Char)
  2024.             else if (v2^.Vtype^.ATypeid = CSV_String) and (Length(v2^.CV_Str) = 1) then
  2025.             begin
  2026.               MakeItBool(V1^.CV_Char = v2^.CV_Str[1]);
  2027.             end
  2028.             else begin
  2029.               Err := True;
  2030.               RunError(Self, ETypeMismatch);
  2031.             end;
  2032.           CSV_UInt16: if IsRealType(v2) then
  2033.               MakeItBool(V1^.Cv_UInt16 = GetReal(v2))
  2034.             else
  2035.               MakeItBool(V1^.Cv_UInt16 = TCSV_UInt16(GetInteger(v2)));
  2036.           CSV_SInt16: if IsRealType(v2) then
  2037.               MakeItBool(V1^.Cv_SInt16 = GetReal(v2))
  2038.             else
  2039.               MakeItBool(V1^.Cv_SInt16 = TCSV_SInt16(GetInteger(v2)));
  2040.           CSV_UInt32: if IsRealType(v2) then
  2041.               MakeItBool(V1^.Cv_UInt32 = GetReal(v2))
  2042.             else
  2043.               MakeItBool(V1^.Cv_UInt32 = TCSV_UInt32(GetInteger(v2)));
  2044.           CSV_SInt32: if IsRealType(v2) then
  2045.               MakeItBool(V1^.Cv_SInt32 = GetReal(v2))
  2046.             else
  2047.               MakeItBool(V1^.Cv_SInt32 = TCSV_SInt32(GetInteger(v2)));
  2048.           CSV_Real: MakeItBool(V1^.CV_Real = GetReal(v2));
  2049.           CSV_Single: MakeItBool(V1^.CV_Single = GetReal(v2));
  2050.           CSV_Double: MakeItBool(V1^.CV_Double = GetReal(v2));
  2051.           CSV_Extended: MakeItBool(V1^.Cv_Extended = GetReal(v2));
  2052.           CSV_Comp: MakeItBool(V1^.CV_comp = GetReal(v2));
  2053.           CSV_Bool: MakeItBool(V1^.Cv_Bool = v2^.Cv_Bool);
  2054.           CSV_String: MakeItBool(V1^.Cv_Str = v2^.Cv_Str);
  2055.           CSV_Special: MakeItBool(V1^.CV_Spec = v2^.CV_Spec);
  2056. {$IFNDEF NOCLASSES}
  2057.           CSV_Class: begin
  2058.               if v2^.VType^.atypeid = CSV_Special then begin
  2059.                 if v2^.CV_Spec = 0 then { nil }  begin
  2060.                   MakeItBool(V1^.CV_Class = nil);
  2061.                 end;
  2062.               end else
  2063.                 MakeItBool(V1^.CV_Class = v2^.CV_Class);
  2064.             end;
  2065.           CSV_ClassRef: begin
  2066.               if v2^.VType^.atypeid = CSV_Special then begin
  2067.                 if v2^.CV_Spec = 0 then { nil }  begin
  2068.                   MakeItBool(V1^.Cv_ClassRef = nil);
  2069.                 end;
  2070.               end else
  2071.                 MakeItBool(V1^.Cv_ClassRef = v2^.Cv_ClassRef);
  2072.             end;
  2073. {$ENDIF}
  2074.           CSV_ProcVariable: begin
  2075.               if v2^.VType^.atypeid = CSV_Special then begin
  2076.                 if v2^.CV_Spec = 0 then { nil }  begin
  2077.                   MakeItBool(V1^.Cv_Proc = nil);
  2078.                 end;
  2079.               end else
  2080.                 MakeItBool((V1^.Cv_Proc = v2^.Cv_Proc){$IFNDEF NOCLASSES} and (V1^.Cv_ProcSelf = v2^.Cv_ProcSelf){$ENDIF});
  2081.             end;
  2082.         else begin
  2083.             Err := True;
  2084.             RunError(Self, ETypeMismatch);
  2085.           end;
  2086.         end; {case item}
  2087.       end;
  2088.     PtNotEqual: begin
  2089.         case V1^.VType^.atypeid of
  2090. {$IFDEF VARIANTSUPPORT}
  2091.           CSV_Variant: begin
  2092.               if v2^.VType^.atypeid = CSV_Variant then begin
  2093.                 if (V1^.CV_Variant = nil) or (v2^.CV_Variant = nil) then begin
  2094.                   MakeItBool(V1^.CV_Variant <> v2^.CV_Variant);
  2095.                 end else begin
  2096.                   Err := not Perform(V1^.CV_Variant, v2^.CV_Variant, t);
  2097.                 end;
  2098.               end else begin
  2099.                 if v2^.VType^.atypeid = CSV_Special then begin
  2100.                   if v2^.CV_Spec = 0 then begin
  2101.                     MakeItBool(V1^.CV_Variant <> nil);
  2102.                   end;
  2103.                 end else if not assigned(V1^.CV_Variant) then begin
  2104.                   RunError(Self, EVariantIsNil);
  2105.                   Perform := False;
  2106.                   exit;
  2107.                 end else
  2108.                   Err := not Perform(V1^.CV_Variant, v2, t);
  2109.               end;
  2110.             end;
  2111. {$ENDIF}
  2112.           CSV_Enum: begin
  2113.               if v2^.VType = V1^.VType then begin
  2114.                 MakeItBool(V1^.CV_Enum <> v2^.CV_Enum);
  2115.               end else begin
  2116.                 Err := True;
  2117.                 RunError(Self, ETypeMismatch);
  2118.               end;
  2119.             end;
  2120.           CSV_UByte: if IsRealType(v2)
  2121.             then MakeItBool(V1^.Cv_UByte <> GetReal(v2))
  2122.             else MakeItBool(V1^.Cv_UByte <> TCSV_UByte(GetInteger(v2)));
  2123.           CSV_SByte: if IsRealType(v2)
  2124.             then MakeItBool(V1^.Cv_SByte <> GetReal(v2))
  2125.             else MakeItBool(V1^.Cv_SByte <> TCSV_SByte(GetInteger(v2)));
  2126.           CSV_Char: if v2^.VType^.atypeid = CSV_Char
  2127.             then MakeItBool(V1^.Cv_Char <> v2^.Cv_Char)
  2128.             else if (v2^.Vtype^.ATypeid = CSV_String) and (Length(v2^.CV_Str) = 1) then
  2129.             begin
  2130.               MakeItBool(V1^.CV_Char <> v2^.CV_Str[1]);
  2131.             end
  2132.             else begin
  2133.               Err := True;
  2134.               RunError(Self, ETypeMismatch);
  2135.             end;
  2136.           CSV_UInt16: if IsRealType(v2)
  2137.             then MakeItBool(V1^.Cv_UInt16 <> GetReal(v2))
  2138.             else MakeItBool(V1^.Cv_UInt16 <> TCSV_UInt16(GetInteger(v2)));
  2139.           CSV_SInt16: if IsRealType(v2)
  2140.             then MakeItBool(V1^.Cv_SInt16 <> GetReal(v2))
  2141.             else MakeItBool(V1^.Cv_SInt16 <> TCSV_SInt16(GetInteger(v2)));
  2142.           CSV_UInt32: if IsRealType(v2)
  2143.             then MakeItBool(V1^.Cv_UInt32 <> GetReal(v2))
  2144.             else MakeItBool(V1^.Cv_UInt32 <> TCSV_UInt32(GetInteger(v2)));
  2145.           CSV_SInt32: if IsRealType(v2)
  2146.             then MakeItBool(V1^.Cv_SInt32 <> GetReal(v2))
  2147.             else MakeItBool(V1^.Cv_SInt32 <> TCSV_SInt32(GetInteger(v2)));
  2148.           CSV_Real: MakeItBool(V1^.CV_Real <> GetReal(v2));
  2149.           CSV_Single: MakeItBool(V1^.CV_Single <> GetReal(v2));
  2150.           CSV_Double: MakeItBool(V1^.CV_Double <> GetReal(v2));
  2151.           CSV_Extended: MakeItBool(V1^.Cv_Extended <> GetReal(v2));
  2152.           CSV_Comp: MakeItBool(V1^.CV_comp <> GetReal(v2));
  2153.           CSV_Bool: MakeItBool(V1^.Cv_Bool <> v2^.Cv_Bool);
  2154.           CSV_String: MakeItBool(V1^.Cv_Str <> v2^.Cv_Str);
  2155.           CSV_Special: MakeItBool(V1^.CV_Spec <> v2^.CV_Spec);
  2156. {$IFNDEF NOCLASSES}
  2157.           CSV_Class: begin
  2158.               if v2^.VType^.atypeid = CSV_Special then begin
  2159.                 if v2^.CV_Spec = 0 then { nil }  begin
  2160.                   MakeItBool(V1^.CV_Class <> nil);
  2161.                 end;
  2162.               end else
  2163.                 MakeItBool(V1^.CV_Class <> v2^.CV_Class);
  2164.             end;
  2165.           CSV_ClassRef: begin
  2166.               if v2^.VType^.atypeid = CSV_Special then begin
  2167.                 if v2^.CV_Spec = 0 then { nil }  begin
  2168.                   MakeItBool(V1^.Cv_ClassRef <> nil);
  2169.                 end;
  2170.               end else
  2171.                 MakeItBool(V1^.Cv_ClassRef <> v2^.Cv_ClassRef);
  2172.             end;
  2173. {$ENDIF}
  2174.           CSV_ProcVariable: begin
  2175.               if v2^.VType^.atypeid = CSV_Special then begin
  2176.                 if v2^.CV_Spec = 0 then { nil }  begin
  2177.                   MakeItBool(V1^.Cv_Proc <> nil);
  2178.                 end;
  2179.               end else
  2180.                 MakeItBool((V1^.Cv_Proc <> v2^.Cv_Proc){$IFNDEF NOCLASSES} or (V1^.Cv_ProcSelf <> v2^.Cv_ProcSelf){$ENDIF});
  2181.             end;
  2182.         else begin
  2183.             Err := True;
  2184.             RunError(Self, ETypeMismatch);
  2185.           end;
  2186.         end; {case item}
  2187.       end;
  2188.   end;
  2189.   Perform := not Err;
  2190. end;
  2191.  
  2192. //-------------------------------------------------------------------
  2193.  
  2194. function TIfPasScript.ReadType(Parser: TIfPascalParser; AllowClasses: Boolean; const Name: string): PTypeRec;
  2195. var
  2196.   Ex: Pointer;
  2197.  
  2198.   function ReadRecord: PTypeRec;
  2199.   var
  2200.     Exu: PIFSRecordType;
  2201.     s, CurrNames: string;
  2202.  
  2203.     function IsDuplicate(p: string): Boolean;
  2204.     begin
  2205.       IsDuplicate := False;
  2206.       if (Pos(p + ' ', s) = 1) or (Pos(' ' + p + ' ', s) <> 0) then
  2207.         IsDuplicate := True;
  2208.       if (Pos(p + ' ', CurrNames) = 1) or (Pos(' ' + p + ' ', CurrNames) <> 0) then
  2209.         IsDuplicate := True;
  2210.     end;
  2211.   begin
  2212.     Parser.Next;
  2213.     s := '';
  2214.     while Parser.CurrTokenId <> CSTII_End do begin
  2215.       CurrNames := '';
  2216.       repeat
  2217.         if Parser.CurrTokenId <> CSTI_Identifier then begin
  2218.           RunError(Self, EIdentifierExpected);
  2219.           ReadRecord := nil;
  2220.           exit;
  2221.         end;
  2222.         if IsDuplicate(Parser.GetToken) then begin
  2223.           RunError(Self, EDuplicateIdentifier);
  2224.           ReadRecord := nil;
  2225.           exit;
  2226.         end else
  2227.           CurrNames := CurrNames + Parser.GetToken + ' ';
  2228.         Parser.Next;
  2229.         if (Parser.CurrTokenId = CSTI_Comma) then begin
  2230.           Parser.Next;
  2231.         end else if (Parser.CurrTokenId = CSTI_Colon) then begin
  2232.           break;
  2233.         end else begin
  2234.           RunError(Self, EColonExpected);
  2235.           ReadRecord := nil;
  2236.           exit;
  2237.         end;
  2238.       until False;
  2239.       Parser.Next;
  2240.       Ex := ReadType(Parser, False, '');
  2241.       if Ex = nil then begin
  2242.         ReadRecord := nil;
  2243.         exit;
  2244.       end;
  2245.       if (Parser.CurrTokenId <> CSTI_Semicolon) and (Parser.CurrTokenId <> CSTII_End) then begin
  2246.         RunError(Self, ESemiColonExpected);
  2247.         ReadRecord := nil;
  2248.         exit;
  2249.       end;
  2250.       while Length(CurrNames) > 0 do begin
  2251.         s := s + copy(CurrNames, 1, Pos(' ', CurrNames) - 1) + ' ' + inttostr(Longint(Ex)) + ' ';
  2252.         Delete(CurrNames, 1, Pos(' ', CurrNames));
  2253.       end;
  2254.       if Parser.CurrTokenId = CSTI_Semicolon then
  2255.         Parser.Next;
  2256.     end;
  2257.     Parser.Next;
  2258.     New(Exu);
  2259.     Exu^.u := s;
  2260.     ReadRecord := TM_Add(Types, Name, CSV_Record, Exu);
  2261.   end; // readclass
  2262. {$IFNDEF NOCLASSES}
  2263.  
  2264.   function ReadClass: PTypeRec;
  2265.   type
  2266.     TClassPlace = (cpPrivate, cpPublic, cpProtected);
  2267.   var
  2268.     I, Nc: PTypeRec;
  2269.     CurrPlace: TClassPlace;
  2270.     AllowVars: Boolean;
  2271.  
  2272.     Myclass: PIFSClassType;
  2273.  
  2274.     function CheckDuplicate(const s: string): Boolean;
  2275.     var
  2276.       u: string;
  2277.       I: Integer;
  2278.  
  2279.       function Rf(const s: string): string;
  2280.       begin
  2281.         Rf := copy(s, 2, Length(s) - 1);
  2282.       end;
  2283.     begin
  2284.       if s = 'SELF' then begin
  2285.         CheckDuplicate := True;
  2286.         exit;
  2287.       end;
  2288.       u := Myclass.Variables.u;
  2289.       while Length(u) > 0 do begin
  2290.         if Rf(Fw(u)) = s then begin
  2291.           CheckDuplicate := True;
  2292.           exit;
  2293.         end;
  2294.         Rfw(u);
  2295.         Rfw(u);
  2296.       end;
  2297.       for I := 0 to Longint(Myclass.Properties.Count) - 1 do begin
  2298.         if PPropertyDef(Myclass.Properties.GetItem(I))^.Name = s then begin
  2299.           CheckDuplicate := True;
  2300.           exit;
  2301.         end;
  2302.       end;
  2303.       for I := 0 to Longint(Myclass.Procedures.Count) - 1 do begin
  2304.         u := PProcedure(Myclass.Procedures.GetItem(I))^.Name;
  2305.         if Pos('!', u) = 1 then begin
  2306.           Delete(u, 1, 1);
  2307.           if s = u then begin
  2308.             CheckDuplicate := True;
  2309.             exit;
  2310.           end;
  2311.         end;
  2312.       end;
  2313.       CheckDuplicate := False;
  2314.     end;
  2315.  
  2316.     function AddProc: Boolean;
  2317.     var
  2318.       p: PProcedure;
  2319.       IsFunc: Boolean;
  2320.       t: PTypeRec;
  2321.       iv: Byte;
  2322.       vn: string;
  2323.  
  2324.       function CheckOverridable(InhClass: PTypeRec): Boolean;
  2325.  
  2326.         function SearchList(List: TIfList): Byte;
  2327.         var
  2328.           I: Integer;
  2329.           n: PProcedure;
  2330.         begin
  2331.           for I := 0 to Longint(List.Count) - 1 do begin
  2332.             n := List.GetItem(I);
  2333.             if n^.Name = p^.Name then begin
  2334.               if (n^.Decl = p^.Decl) and ((n^.Flags and not $30) = (p^.Flags and not $30)) and ((n^.Flags or $30) <> 0) then begin
  2335.                 SearchList := 1;
  2336.                 exit;
  2337.               end;
  2338.               SearchList := 2;
  2339.               exit;
  2340.             end;
  2341.           end;
  2342.           SearchList := 0;
  2343.         end; {searchlist}
  2344.       begin
  2345.         CheckOverridable := False;
  2346.         while assigned(InhClass) do begin
  2347.           case SearchList(PIFSClassType(InhClass^.Ext)^.Procedures) of
  2348.             0: InhClass := PIFSClassType(InhClass^.Ext)^.InheritsFrom;
  2349.             1: begin
  2350.                 CheckOverridable := True;
  2351.                 exit;
  2352.               end;
  2353.             2: exit;
  2354.           end; {case}
  2355.         end; {if}
  2356.       end; {checkoverridable}
  2357.  
  2358.       function PCheckDuplic(const n: string): Boolean;
  2359.       var
  2360.         u, a: string;
  2361.       begin
  2362.         PCheckDuplic := False;
  2363.         if n = p^.Name then PCheckDuplic := True else begin
  2364.           u := p^.Decl;
  2365.           rs(u);
  2366.           while Length(u) > 0 do begin
  2367.             a := Fw(u);
  2368.             Rfw(u); {remove name}
  2369.             Rfw(u); {remove type}
  2370.             if Pos('!', a) = 1 then
  2371.               Delete(a, 1, 1);
  2372.             if a = n then begin
  2373.               PCheckDuplic := True;
  2374.               exit;
  2375.             end;
  2376.           end;
  2377.           u := vn;
  2378.           while Length(u) > 0 do begin
  2379.             a := Fw(u);
  2380.             Rfw(u); {remove name}
  2381.             if a = n then begin
  2382.               PCheckDuplic := True;
  2383.               exit;
  2384.             end;
  2385.           end;
  2386.         end;
  2387.       end;
  2388.  
  2389.     begin
  2390.       New(p);
  2391.       p^.FScriptEngine := Self;
  2392.       p^.Mode := 0;
  2393.       p^.offset := -1;
  2394.       p^.ClassType := Nc;
  2395.       case CurrPlace of
  2396.         cpPrivate: p^.Flags := $1;
  2397.         cpPublic: p^.Flags := $2;
  2398.         cpProtected: p^.Flags := $3;
  2399.       end;
  2400.       if Parser.CurrTokenId = CSTII_Constructor then begin
  2401.         IsFunc := False;
  2402.         p^.Flags := p^.Flags or $40
  2403.       end else if Parser.CurrTokenId = CSTII_Destructor then begin
  2404.         IsFunc := False;
  2405.         p^.Flags := p^.Flags or $80
  2406.       end else if Parser.CurrTokenId = CSTII_Function then begin
  2407.         IsFunc := True;
  2408.       end else
  2409.         IsFunc := False; {procedure}
  2410.       Parser.Next;
  2411.       if Parser.CurrTokenId <> CSTI_Identifier then begin
  2412.         RunError(Self, EIdentifierExpected);
  2413.         Dispose(p);
  2414.         AddProc := False;
  2415.         exit;
  2416.       end;
  2417.       if CheckDuplicate(Parser.GetToken) then begin
  2418.         RunError(Self, EDuplicateIdentifier);
  2419.         AddProc := False;
  2420.         Dispose(p);
  2421.         exit;
  2422.       end;
  2423.       p^.Name := '!' + Parser.GetToken;
  2424.       Parser.Next;
  2425.       if Parser.CurrTokenId = CSTI_OpenRound then begin
  2426.         Parser.Next;
  2427.         if Parser.CurrTokenId = CSTI_CloseRound then begin
  2428.           Parser.Next;
  2429.         end else begin
  2430.           repeat
  2431.             if Parser.CurrTokenId = CSTII_Var then begin
  2432.               Parser.Next;
  2433.               iv := 1; {var}
  2434.             end else if Parser.CurrTokenId = CSTII_Const then begin
  2435.               Parser.Next;
  2436.               iv := 2; {const}
  2437.             end else iv := 0; {normal}
  2438.             if Parser.CurrTokenId <> CSTI_Identifier then begin
  2439.               RunError(Self, EIdentifierExpected);
  2440.               AddProc := False;
  2441.               Dispose(p);
  2442.               exit;
  2443.             end; {if}
  2444.             vn := '';
  2445.             if CheckDuplicate(Parser.GetToken) or PCheckDuplic(Parser.GetToken) then begin
  2446.               RunError(Self, EDuplicateIdentifier);
  2447.               AddProc := False;
  2448.               Dispose(p);
  2449.               exit;
  2450.             end;
  2451.             vn := Parser.GetToken;
  2452.             Parser.Next;
  2453.             while Parser.CurrTokenId = CSTI_Comma do begin
  2454.               Parser.Next;
  2455.               if Parser.CurrTokenId <> CSTI_Identifier then begin
  2456.                 RunError(Self, EIdentifierExpected);
  2457.                 AddProc := False;
  2458.                 Dispose(p);
  2459.                 exit;
  2460.               end; {if}
  2461.               if (CheckDuplicate(Parser.GetToken)) or PCheckDuplic(Parser.GetToken) then begin
  2462.                 RunError(Self, EDuplicateIdentifier);
  2463.                 AddProc := False;
  2464.                 Dispose(p);
  2465.                 exit;
  2466.               end; {if}
  2467.               vn := vn + ' ' + Parser.GetToken;
  2468.               Parser.Next;
  2469.             end; {while}
  2470.             if Parser.CurrTokenId <> CSTI_Colon then begin
  2471.               RunError(Self, EColonExpected);
  2472.               AddProc := False;
  2473.               Dispose(p);
  2474.               exit;
  2475.             end;
  2476.             Parser.Next;
  2477.             t := GetTypeLink(TM_Get(Types, Parser.GetToken));
  2478.             if t = nil then begin
  2479.               RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  2480.               Dispose(p);
  2481.               AddProc := False;
  2482.               exit;
  2483.             end;
  2484.             if iv = 0 then begin
  2485.               while Length(vn) > 0 do begin
  2486.                 p^.Decl := p^.Decl + ' ' + Fw(vn) + ' ' + inttostr(Longint(t));
  2487.                 Rfw(vn);
  2488.               end;
  2489.             end else if iv = 1 then begin {var}
  2490.               while Length(vn) > 0 do begin
  2491.                 p^.Decl := p^.Decl + ' !' + Fw(vn) + ' ' + inttostr(Longint(t));
  2492.                 Rfw(vn);
  2493.               end;
  2494.             end else begin {const}
  2495.               while Length(vn) > 0 do begin
  2496.                 p^.Decl := p^.Decl + ' ^' + Fw(vn) + ' ' + inttostr(Longint(t));
  2497.                 Rfw(vn);
  2498.               end;
  2499.             end;
  2500.             Parser.Next;
  2501.             if Parser.CurrTokenId = CSTI_Semicolon then begin
  2502.               Parser.Next;
  2503.             end else
  2504.               if (Parser.CurrTokenId <> CSTI_CloseRound) then begin
  2505.                 RunError(Self, ESemiColonExpected);
  2506.                 Dispose(p);
  2507.                 AddProc := False;
  2508.                 exit;
  2509.               end else
  2510.                 break;
  2511.           until False;
  2512.           Parser.Next;
  2513.         end;
  2514.       end;
  2515.       if IsFunc then begin
  2516.         if Parser.CurrTokenId <> CSTI_Colon then begin
  2517.           RunError(Self, EColonExpected);
  2518.           Dispose(p);
  2519.           AddProc := False;
  2520.           exit;
  2521.         end;
  2522.         Parser.Next;
  2523.         t := GetTypeLink(TM_Get(Types, Parser.GetToken));
  2524.         if t = nil then begin
  2525.           RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  2526.           Dispose(p);
  2527.           AddProc := False;
  2528.           exit;
  2529.         end;
  2530.         p^.Decl := inttostr(Longint(t)) + p^.Decl;
  2531.         Parser.Next;
  2532.       end else
  2533.         p^.Decl := '0' + p^.Decl;
  2534.  
  2535.       if Parser.CurrTokenId <> CSTI_Semicolon then begin
  2536.         RunError(Self, ESemiColonExpected);
  2537.         AddProc := False;
  2538.         Dispose(p);
  2539.         exit;
  2540.       end;
  2541.       Parser.Next;
  2542.       if Parser.CurrTokenId = CSTII_Virtual then begin
  2543.         p^.Flags := p^.Flags or $10;
  2544.         Parser.Next;
  2545.         if Parser.CurrTokenId <> CSTI_Semicolon then begin
  2546.           RunError(Self, ESemiColonExpected);
  2547.           AddProc := False;
  2548.           Dispose(p);
  2549.           exit;
  2550.         end;
  2551.         Parser.Next;
  2552.       end else if Parser.CurrTokenId = CSTII_Override then begin
  2553.         if not CheckOverridable(I) then begin
  2554.           RunError(Self, ECanNotOverride);
  2555.           AddProc := False;
  2556.           Dispose(p);
  2557.           exit;
  2558.         end;
  2559.         p^.Flags := p^.Flags or $20;
  2560.         Parser.Next;
  2561.         if Parser.CurrTokenId <> CSTI_Semicolon then begin
  2562.           RunError(Self, ESemiColonExpected);
  2563.           AddProc := False;
  2564.           Dispose(p);
  2565.           exit;
  2566.         end;
  2567.         Parser.Next;
  2568.       end;
  2569.       Procedures.Add(p);
  2570.       Myclass.Procedures.Add(p);
  2571.       AddProc := True;
  2572.     end; //addproc
  2573.  
  2574.     function AddVar: Boolean;
  2575.  
  2576.       procedure ReallyAddVar(const Name: string; FType: PTypeRec);
  2577.       begin
  2578.         case CurrPlace of
  2579.           cpPrivate: Myclass.Variables.u := Myclass.Variables.u + '1' + Name + ' ' + inttostr(Longint(FType)) + ' ';
  2580.           cpPublic: Myclass.Variables.u := Myclass.Variables.u + '2' + Name + ' ' + inttostr(Longint(FType)) + ' ';
  2581.           cpProtected: Myclass.Variables.u := Myclass.Variables.u + '3' + Name + ' ' + inttostr(Longint(FType)) + ' ';
  2582.         end;
  2583.         Inc(Myclass.VarCount);
  2584.       end;
  2585.     var
  2586.       Vars: string;
  2587.       FType: PTypeRec;
  2588.  
  2589.       function IVarCheck(const s: string): Boolean;
  2590.       var
  2591.         u: string;
  2592.       begin
  2593.         u := Vars;
  2594.         while Length(u) > 0 do begin
  2595.           if Fw(u) = s then begin
  2596.             IVarCheck := True;
  2597.             exit;
  2598.           end;
  2599.           Rfw(u);
  2600.         end;
  2601.         IVarCheck := False;
  2602.       end;
  2603.  
  2604.     begin
  2605.       if CheckDuplicate(Parser.GetToken) or (IVarCheck(Parser.GetToken)) then begin
  2606.         RunError(Self, EDuplicateIdentifier);
  2607.         AddVar := False;
  2608.         exit;
  2609.       end; {if}
  2610.       Vars := Parser.GetToken;
  2611.       Parser.Next;
  2612.       while Parser.CurrTokenId = CSTI_Comma do begin
  2613.         Parser.Next;
  2614.         if Parser.CurrTokenId <> CSTI_Identifier then begin
  2615.           RunError(Self, EIdentifierExpected);
  2616.           AddVar := False;
  2617.           exit;
  2618.         end; {if}
  2619.         if CheckDuplicate(Parser.GetToken) or (IVarCheck(Parser.GetToken)) then begin
  2620.           RunError(Self, EDuplicateIdentifier);
  2621.           AddVar := False;
  2622.           exit;
  2623.         end; {if}
  2624.         Vars := Vars + ' ' + Parser.GetToken;
  2625.         Parser.Next;
  2626.       end; {if}
  2627.       if Parser.CurrTokenId <> CSTI_Colon then begin
  2628.         RunError(Self, EColonExpected);
  2629.         AddVar := False;
  2630.         exit;
  2631.       end; {if}
  2632.       Parser.Next;
  2633.       FType := ReadType(Parser, False, '');
  2634.       if FType = nil then begin
  2635.         RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  2636.         AddVar := False;
  2637.         exit;
  2638.       end;
  2639.       if Parser.CurrTokenId <> CSTI_Semicolon then begin
  2640.         RunError(Self, ESemiColonExpected);
  2641.         AddVar := False;
  2642.         exit;
  2643.       end;
  2644.       Parser.Next;
  2645.       while Length(Vars) > 0 do begin
  2646.         ReallyAddVar(Fw(Vars), FType);
  2647.         Rfw(Vars);
  2648.       end;
  2649.       AddVar := True;
  2650.     end; // addvar
  2651.  
  2652.     function AddProperty: Boolean;
  2653.     var
  2654.       p: PPropertyDef;
  2655.       proc: PProcedure;
  2656.       FType: PTypeRec;
  2657.  
  2658.       function FindProc(const Name: string): Boolean;
  2659.       var
  2660.         I: Integer;
  2661.       begin
  2662.         for I := 0 to Longint(Myclass.Procedures.Count) - 1 do begin
  2663.           if PProcedure(Myclass.Procedures.GetItem(I))^.Name = '!' + Name then begin
  2664.             proc := Myclass.Procedures.GetItem(I);
  2665.             FindProc := True;
  2666.             exit;
  2667.           end;
  2668.         end;
  2669.         FindProc := False;
  2670.       end;
  2671.  
  2672.       function CheckProc(read: Boolean): Boolean;
  2673.       var
  2674.         s: string;
  2675.       begin
  2676.         CheckProc := False;
  2677.         s := proc.Decl;
  2678.         if read then begin
  2679.           if Fw(s) <> inttostr(Longint(FType)) then begin
  2680.             exit;
  2681.           end;
  2682.           Rfw(s);
  2683.           if s <> '' then
  2684.             exit;
  2685.         end else begin
  2686.           if Fw(s) <> '0' then
  2687.             exit;
  2688.           Rfw(s);
  2689.           Rfw(s);
  2690.           if Fw(s) <> inttostr(Longint(FType)) then
  2691.             exit;
  2692.           Rfw(s);
  2693.           if s <> '' then
  2694.             exit;
  2695.         end;
  2696.         CheckProc := True;
  2697.       end;
  2698.  
  2699.       function CheckVariable(const Name: string): Longint;
  2700.       var
  2701.         s: string;
  2702.         I: Integer;
  2703.       begin
  2704.         s := Myclass^.Variables.u;
  2705.         CheckVariable := -1;
  2706.         I := 0;
  2707.         while Length(s) > 0 do begin
  2708.           if copy(Fw(s), 2, Length(Fw(s)) - 1) = Name then begin
  2709.             Rfw(s);
  2710.             if Fw(s) <> inttostr(Longint(FType)) then begin
  2711.               RunError(Self, ETypeMismatch);
  2712.               exit;
  2713.             end;
  2714.             CheckVariable := I;
  2715.             exit;
  2716.           end;
  2717.           Rfw(s);
  2718.           Rfw(s);
  2719.           Inc(I);
  2720.         end;
  2721.         RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  2722.       end;
  2723.     begin
  2724.       Parser.Next;
  2725.       if Parser.CurrTokenId <> CSTI_Identifier then begin
  2726.         RunError(Self, EIdentifierExpected);
  2727.         AddProperty := False;
  2728.         exit;
  2729.       end;
  2730.       New(p);
  2731.       if CheckDuplicate(Parser.GetToken) then begin
  2732.         RunError(Self, EDuplicateIdentifier);
  2733.         Dispose(p);
  2734.         AddProperty := False;
  2735.         exit;
  2736.       end;
  2737.       p^.Name := Parser.GetToken;
  2738.       case CurrPlace of
  2739.         cpPrivate: p^.CV_PropFlags := $10;
  2740.         cpPublic: p^.CV_PropFlags := $20;
  2741.         cpProtected: p^.CV_PropFlags := $30;
  2742.       end;
  2743.       Parser.Next;
  2744.       if Parser.CurrTokenId <> CSTI_Colon then begin
  2745.         RunError(Self, EColonExpected);
  2746.         Dispose(p);
  2747.         AddProperty := False;
  2748.         exit;
  2749.       end;
  2750.       Parser.Next;
  2751.       FType := GetTypeLink(TM_Get(Types, Parser.GetToken));
  2752.       p^.CV_Type := FType;
  2753.  
  2754.       if FType = nil then begin
  2755.         RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  2756.         Dispose(p);
  2757.         AddProperty := False;
  2758.         exit;
  2759.       end;
  2760.       Parser.Next;
  2761.       if Parser.GetToken = 'READ' then begin
  2762.         Parser.Next;
  2763.         if FindProc(Parser.GetToken) then begin
  2764.           if not CheckProc(True) then begin
  2765.             RunError(Self, ETypeMismatch);
  2766.             Dispose(p);
  2767.             AddProperty := False;
  2768.             exit;
  2769.           end;
  2770.           p^.CV_PropFlags := p^.CV_PropFlags or 5;
  2771.           p^.CV_PropRead := proc;
  2772.         end else begin
  2773.           p.CV_PropRead := Pointer(CheckVariable(Parser.GetToken));
  2774.           if Longint(p^.CV_PropRead) = -1 then begin
  2775.             Dispose(p);
  2776.             AddProperty := False;
  2777.             exit;
  2778.           end;
  2779.           p^.CV_PropFlags := p^.CV_PropFlags or 1;
  2780.         end;
  2781.         Parser.Next;
  2782.       end;
  2783.       if Parser.GetToken = 'WRITE' then begin
  2784.         Parser.Next;
  2785.         if FindProc(Parser.GetToken) then begin
  2786.           if not CheckProc(False) then begin
  2787.             RunError(Self, ETypeMismatch);
  2788.             Dispose(p);
  2789.             AddProperty := False;
  2790.             exit;
  2791.           end;
  2792.           p^.CV_PropFlags := p^.CV_PropFlags or 10;
  2793.           p^.CV_PropWrite := proc;
  2794.         end else begin
  2795.           p.CV_PropWrite := Pointer(CheckVariable(Parser.GetToken));
  2796.           if Longint(p^.CV_PropWrite) = -1 then begin
  2797.             Dispose(p);
  2798.             AddProperty := False;
  2799.             exit;
  2800.           end;
  2801.           p^.CV_PropFlags := p^.CV_PropFlags or 2;
  2802.         end;
  2803.         Parser.Next;
  2804.       end;
  2805.       if Parser.CurrTokenId <> CSTI_Semicolon then begin
  2806.         RunError(Self, ESemiColonExpected);
  2807.         Dispose(p);
  2808.         AddProperty := False;
  2809.         exit;
  2810.       end;
  2811.       Parser.Next;
  2812.       if (p^.CV_PropFlags and $3) = 0 then begin
  2813.         RunError(Self, ECanNotReadOrWriteProperty);
  2814.         Dispose(p);
  2815.         AddProperty := False;
  2816.         exit;
  2817.       end;
  2818.       AddProperty := True;
  2819.       Myclass.Properties.Add(p);
  2820.     end;
  2821.   begin
  2822.     CurrPlace := cpPublic;
  2823.     AllowVars := True; // No vars are allowed after a procedure definition
  2824.     Parser.Next;
  2825.     if Parser.CurrTokenId = CSTI_OpenRound then begin
  2826.       Parser.Next;
  2827.       I := GetTypeLink(TM_Get(Types, Parser.GetToken));
  2828.       if not assigned(I) then begin
  2829.         RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  2830.         ReadClass := nil;
  2831.         exit;
  2832.       end; {if}
  2833.       if I.atypeid <> CSV_Class then begin
  2834.         RunError(Self, EClassTypeExpected);
  2835.         ReadClass := nil;
  2836.         exit;
  2837.       end; {if}
  2838.       Parser.Next;
  2839.       if Parser.CurrTokenId <> CSTI_CloseRound then begin
  2840.         RunError(Self, ECloseRoundExpected);
  2841.         ReadClass := nil;
  2842.         exit;
  2843.       end; {if}
  2844.       Parser.Next;
  2845.     end else {if}  begin
  2846.       if Parser.CurrTokenId = CSTII_Of then begin
  2847.         Parser.Next;
  2848.         if Parser.CurrTokenId <> CSTI_Identifier then begin
  2849.           RunError(Self, EIdentifierExpected);
  2850.           ReadClass := nil;
  2851.           exit;
  2852.         end;
  2853.         I := GetTypeLink(TM_Get(Types, Parser.GetToken));
  2854.         if I^.atypeid <> CSV_Class then begin
  2855.           RunError(Self, EClassTypeExpected);
  2856.           ReadClass := nil;
  2857.           exit;
  2858.         end;
  2859.         ReadClass := TM_Add(Types, Name, CSV_ClassRef, I);
  2860.         exit;
  2861.       end;
  2862.       I := GetTypeLink(TM_Get(Types, 'TOBJECT'));
  2863.       if not assigned(I) then begin
  2864.         RunError(Self, EClassTypeExpected);
  2865.         ReadClass := nil;
  2866.         exit;
  2867.       end; {if}
  2868.     end; {else if}
  2869.     New(Myclass);
  2870.     Myclass^.InheritsFrom := I;
  2871.     Myclass^.VarNoStart := PIFSClassType(Myclass^.InheritsFrom^.Ext)^.VarNoStart + PIFSClassType(Myclass^.InheritsFrom^.Ext)^.VarCount;
  2872.     Myclass^.PropStart := PIFSClassType(Myclass^.InheritsFrom^.Ext)^.PropStart + PIFSClassType(Myclass^.InheritsFrom^.Ext)^.Properties.Count;
  2873.     Myclass^.VarCount := 0;
  2874.     Myclass^.Variables.u := '';
  2875.     Myclass^.Procedures := TIfList.Create;
  2876.     Myclass^.Properties := TIfList.Create;
  2877.     Nc := TM_Add(Types, Name, CSV_Class, Myclass);
  2878.     while Parser.CurrTokenId <> CSTII_End do begin
  2879.       if Parser.CurrTokenId = CSTII_Private then begin
  2880.         CurrPlace := cpPrivate;
  2881.         Parser.Next;
  2882.         AllowVars := True;
  2883.       end else if Parser.CurrTokenId = CSTII_Public then begin
  2884.         CurrPlace := cpPublic;
  2885.         Parser.Next;
  2886.         AllowVars := True;
  2887.       end else if Parser.CurrTokenId = CSTII_Published then begin
  2888.         CurrPlace := cpPublic;
  2889.         Parser.Next;
  2890.         AllowVars := True;
  2891.       end else if Parser.CurrTokenId = CSTII_Protected then begin
  2892.         CurrPlace := cpProtected;
  2893.         Parser.Next;
  2894.         AllowVars := True;
  2895.       end else if (Parser.CurrTokenId = CSTII_Property) then begin
  2896.         if not AddProperty then begin
  2897.           ReadClass := nil;
  2898.           exit;
  2899.         end;
  2900.       end else if (Parser.CurrTokenId = CSTII_Procedure) or
  2901.         (Parser.CurrTokenId = CSTII_Function) or
  2902.         (Parser.CurrTokenId = CSTII_Constructor) or
  2903.         (Parser.CurrTokenId = CSTII_Destructor) then begin
  2904.         if not AddProc then begin
  2905.           ReadClass := nil;
  2906.           exit;
  2907.         end;
  2908.         AllowVars := False;
  2909.       end else if Parser.CurrTokenId = CSTI_Identifier then begin
  2910.         if not AllowVars then begin
  2911.           RunError(Self, EEndExpected);
  2912.           ReadClass := nil;
  2913.           exit;
  2914.         end;
  2915.         if not AddVar then begin
  2916.           ReadClass := nil;
  2917.           exit;
  2918.         end;
  2919.       end else begin
  2920.         RunError(Self, EEndExpected);
  2921.         ReadClass := nil;
  2922.         exit;
  2923.       end;
  2924.     end;
  2925.     Parser.Next;
  2926.     ReadClass := Nc;
  2927.   end; {ReadClass}
  2928. {$ENDIF}
  2929.  
  2930.   function ReadProcedure: PTypeRec;
  2931.   var
  2932.     Func: Boolean;
  2933.     Data: PIFSProcType;
  2934.     vn: string;
  2935.     iv: Byte;
  2936.     t: PTypeRec;
  2937.  
  2938.     function PCheckDuplic(const n: string): Boolean;
  2939.     var
  2940.       u, a: string;
  2941.     begin
  2942.       PCheckDuplic := False;
  2943.       u := Data^.Decl;
  2944.       rs(u);
  2945.       while Length(u) > 0 do begin
  2946.         a := Fw(u);
  2947.         Rfw(u); {remove name}
  2948.         Rfw(u); {remove type}
  2949.         if Pos('!', a) = 1 then
  2950.           Delete(a, 1, 1);
  2951.         if a = n then begin
  2952.           PCheckDuplic := True;
  2953.           exit;
  2954.         end;
  2955.       end;
  2956.       u := vn;
  2957.       while Length(u) > 0 do begin
  2958.         a := Fw(u);
  2959.         Rfw(u); {remove name}
  2960.         if a = n then begin
  2961.           PCheckDuplic := True;
  2962.           exit;
  2963.         end;
  2964.       end;
  2965.     end;
  2966.   begin
  2967.     ReadProcedure := nil;
  2968.     Func := Parser.CurrTokenId = CSTII_Function;
  2969.     Parser.Next;
  2970.     New(Data);
  2971.     Data^.Decl := '';
  2972.     Data^.Method := False;
  2973.     if Parser.CurrTokenId = CSTI_OpenRound then begin
  2974.       Parser.Next;
  2975.       if Parser.CurrTokenId = CSTI_CloseRound then begin
  2976.         Parser.Next;
  2977.       end else begin
  2978.         repeat
  2979.           if Parser.CurrTokenId = CSTII_Var then begin
  2980.             Parser.Next;
  2981.             iv := 1; {var}
  2982.           end else iv := 0; {normal}
  2983.           if Parser.CurrTokenId <> CSTI_Identifier then begin
  2984.             RunError(Self, EIdentifierExpected);
  2985.             Dispose(Data);
  2986.             exit;
  2987.           end; {if}
  2988.           vn := '';
  2989.           if PCheckDuplic(Parser.GetToken) then begin
  2990.             RunError(Self, EDuplicateIdentifier);
  2991.             Dispose(Data);
  2992.             exit;
  2993.           end;
  2994.           vn := Parser.GetToken;
  2995.           Parser.Next;
  2996.           while Parser.CurrTokenId = CSTI_Comma do begin
  2997.             Parser.Next;
  2998.             if Parser.CurrTokenId <> CSTI_Identifier then begin
  2999.               RunError(Self, EIdentifierExpected);
  3000.               Dispose(Data);
  3001.               exit;
  3002.             end; {if}
  3003.             if PCheckDuplic(Parser.GetToken) then begin
  3004.               RunError(Self, EDuplicateIdentifier);
  3005.               Dispose(Data);
  3006.               exit;
  3007.             end; {if}
  3008.             vn := vn + ' ' + Parser.GetToken;
  3009.             Parser.Next;
  3010.           end; {while}
  3011.           if Parser.CurrTokenId <> CSTI_Colon then begin
  3012.             RunError(Self, EColonExpected);
  3013.             Dispose(Data);
  3014.             exit;
  3015.           end;
  3016.           Parser.Next;
  3017.           t := GetTypeLink(TM_Get(Types, Parser.GetToken));
  3018.           if t = nil then begin
  3019.             RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3020.             Dispose(Data);
  3021.             exit;
  3022.           end;
  3023.           if iv = 0 then begin
  3024.             while Length(vn) > 0 do begin
  3025.               Data^.Decl := Data^.Decl + ' ' + Fw(vn) + ' ' + inttostr(Longint(t));
  3026.               Rfw(vn);
  3027.             end;
  3028.           end else
  3029.             if iv = 1 then begin
  3030.               while Length(vn) > 0 do begin
  3031.                 Data^.Decl := Data^.Decl + ' !' + Fw(vn) + ' ' + inttostr(Longint(t));
  3032.                 Rfw(vn);
  3033.               end;
  3034.             end;
  3035.           Parser.Next;
  3036.           if Parser.CurrTokenId = CSTI_Semicolon then begin
  3037.             Parser.Next;
  3038.           end else
  3039.             if (Parser.CurrTokenId <> CSTI_CloseRound) then begin
  3040.               RunError(Self, ESemiColonExpected);
  3041.               Dispose(Data);
  3042.               exit;
  3043.             end else
  3044.               break;
  3045.         until False;
  3046.         Parser.Next;
  3047.       end;
  3048.     end;
  3049.     if Func then begin
  3050.       if Parser.CurrTokenId <> CSTI_Colon then begin
  3051.         RunError(Self, EColonExpected);
  3052.         Dispose(Data);
  3053.         exit;
  3054.       end;
  3055.       Parser.Next;
  3056.       t := GetTypeLink(TM_Get(Types, Parser.GetToken));
  3057.       if t = nil then begin
  3058.         RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3059.         Dispose(Data);
  3060.         exit;
  3061.       end;
  3062.       Data^.Decl := inttostr(Longint(t)) + Data^.Decl;
  3063.       Parser.Next;
  3064.     end else
  3065.       Data^.Decl := '0' + Data^.Decl;
  3066. {$IFNDEF NOCLASSES}
  3067.     if Parser.CurrTokenId = CSTII_Of then begin
  3068.       Parser.Next;
  3069.       if Parser.GetToken <> 'OBJECT' then begin
  3070.         RunError(Self, EObjectExpected);
  3071.         Dispose(Data);
  3072.         exit;
  3073.       end;
  3074.       Parser.Next;
  3075.       Data^.Method := True;
  3076.     end;
  3077. {$ENDIF}
  3078.     Result := TM_Add(Types, Name, CSV_ProcVariable, Data);
  3079.   end; // readprocedure
  3080.  
  3081.   function ReadEnum: PTypeRec;
  3082.   var
  3083.     VarName: string;
  3084.     p: PTypeRec;
  3085.     P2: PIfVariant;
  3086.     I: Longint;
  3087.   begin
  3088.     p := TM_Add(Types, Name, CSV_Enum, nil);
  3089.     ReadEnum := nil;
  3090.     Parser.Next; // skip CSTI_OpenRound
  3091.     I := 0;
  3092.     repeat
  3093.       if Parser.CurrTokenId <> CSTI_Identifier then begin
  3094.         RunError(Self, EIdentifierExpected);
  3095.         exit;
  3096.       end;
  3097.       VarName := Parser.GetToken;
  3098.       if IdentifierExists(True, nil, VarName) then begin
  3099.         RunError(Self, EDuplicateIdentifier);
  3100.         exit;
  3101.       end;
  3102.       P2 := Vm_Add(Variables, CreateCajVariant(p), VarName);
  3103.       P2^.CV_Enum := I;
  3104.       P2^.Flags := P2^.Flags or 1;
  3105.       I := I + 1;
  3106.       Parser.Next;
  3107.       if Parser.CurrTokenId = CSTI_CloseRound then break;
  3108.       if Parser.CurrTokenId <> CSTI_Comma then begin
  3109.         RunError(Self, ECloseRoundExpected);
  3110.         exit;
  3111.       end;
  3112.       Parser.Next;
  3113.     until False;
  3114.     Longint(p^.Ext) := I - 1; // max
  3115.     Parser.Next;
  3116.     ReadEnum := p;
  3117.   end;
  3118. begin
  3119.   if (Parser.CurrTokenId = CSTII_Procedure) or (Parser.CurrTokenId = CSTII_Function) then begin
  3120.     ReadType := ReadProcedure;
  3121.   end else if Parser.CurrTokenId = CSTI_OpenRound then begin
  3122.     ReadType := ReadEnum;
  3123.   end else {$IFNDEF NOCLASSES}if Parser.CurrTokenId = CSTII_Class then begin
  3124.       if not AllowClasses then begin
  3125.         RunError(Self, EClassNotAllowedHere);
  3126.         ReadType := nil;
  3127.         exit;
  3128.       end;
  3129.       ReadType := ReadClass;
  3130.     end else {$ENDIF}if Parser.CurrTokenId = CSTII_Array then begin
  3131.         Parser.Next;
  3132.         if Parser.CurrTokenId <> CSTII_Of then begin
  3133.           RunError(Self, EOfExpected);
  3134.           ReadType := nil;
  3135.           exit;
  3136.         end;
  3137.         Parser.Next;
  3138.         if Parser.CurrTokenId = CSTII_Const then begin
  3139.           ReadType := TM_Add(Types, Name, CSV_Array, TM_Add(Types, '', CSV_Var, nil));
  3140.           Parser.Next;
  3141.         end else begin
  3142.           Ex := ReadType(Parser, False, '');
  3143.           if Ex <> nil then
  3144.             ReadType := TM_Add(Types, Name, CSV_Array, Ex)
  3145.           else begin
  3146.             ReadType := nil;
  3147.             RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3148.           end;
  3149.         end;
  3150.       end else if Parser.CurrTokenId = CSTII_Record then begin
  3151.         ReadType := ReadRecord;
  3152.       end else begin
  3153.         Ex := GetTypeLink(TM_Get(Types, Parser.GetToken));
  3154.         Parser.Next;
  3155.         if Ex = nil then begin
  3156.           RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3157.           ReadType := nil;
  3158.           exit;
  3159.         end;
  3160.         if PTypeRec(Ex)^.Ident = '' then begin
  3161.           PTypeRec(Ex)^.Ident := Name;
  3162.           ReadType := Ex;
  3163.  
  3164.         end else begin
  3165.           if Name = '' then
  3166.             ReadType := Ex
  3167.           else
  3168.             ReadType := TM_Add(Types, Name, CSV_TypeCopy, Ex);
  3169.         end;
  3170.       end;
  3171. end;
  3172. //-------------------------------------------------------------------
  3173. {$IFNDEF NOCLASSES}
  3174.  
  3175. function TIfPasScript.AddClass(const Name, Decl: string; RegProc: Pointer): PTypeRec;
  3176. var
  3177.   p: PTypeRec;
  3178.   I: Integer;
  3179.   proc: PProcedure;
  3180. begin
  3181.   p := AddType(Name, Decl);
  3182.   if p = nil then begin
  3183.     AddClass := nil;
  3184.     exit;
  3185.   end;
  3186.   for I := 0 to Longint(PIFSClassType(p^.Ext)^.Procedures.Count) - 1 do begin
  3187.     proc := PIFSClassType(p^.Ext)^.Procedures.GetItem(I);
  3188.     proc^.Mode := 1;
  3189.     proc^.proc1 := RegProc;
  3190.   end;
  3191.   AddClass := p;
  3192. end;
  3193. {$ENDIF}
  3194. //-------------------------------------------------------------------
  3195.  
  3196. function TIfPasScript.AddTypeEx(Name: string): PTypeRec;
  3197. begin
  3198.   Result := TM_Add(Types, FastUppercase(Name), CSV_Var, nil);
  3199. end;
  3200. //-------------------------------------------------------------------
  3201.  
  3202. function TIfPasScript.AddType(const Name, Decl: string): PTypeRec;
  3203. var
  3204.   Parser: TIfPascalParser;
  3205.   E: TIFPARSERERROR;
  3206.   p: PTypeRec;
  3207. begin
  3208.   Parser := TIfPascalParser.Create;
  3209.   if not Parser.SetText(Decl, E) then begin
  3210.     AddType := nil;
  3211.     Parser.Free;
  3212.     exit;
  3213.   end;
  3214.   p := ReadType(Parser, True, FastUppercase(Name));
  3215.   if p = nil then begin
  3216.     AddType := nil;
  3217.     RunError(Self, ENoError);
  3218.   end else
  3219.     AddType := p;
  3220.   Parser.Free;
  3221. end; {AddType}
  3222. //-------------------------------------------------------------------
  3223.  
  3224. function TIfPasScript.GetIdentifier(WithList: TIfList; Vars: PVariableManager; Mode: Byte; var w: PIfVariant): Byte;
  3225. {
  3226. When it returns nil in W and Result = True then a procedure is called
  3227. that has no result.
  3228.  
  3229. returns:
  3230.   2: Successful returns variant that needs to be freed.
  3231.   1: Successful returns variant and need assignment.
  3232.   False: Not
  3233.  
  3234. }
  3235.  
  3236.   function GetRecordSubVar(p: PIfVariant; const Name: string): PIfVariant;
  3237.   var
  3238.     s: string;
  3239.     I: Integer;
  3240.   begin
  3241.     s := PIFSRecordType(p.VType.Ext)^.u;
  3242.     I := 0;
  3243.     while Length(s) > 0 do begin
  3244.       if Fw(s) = Name then begin
  3245.         GetRecordSubVar := p.CV_RecItems.GetItem(I);
  3246.         exit;
  3247.       end;
  3248.       Rfw(s); {Remove name}
  3249.       Rfw(s); {Remove type}
  3250.       Inc(I);
  3251.     end;
  3252.     GetRecordSubVar := nil;
  3253.   end;
  3254.  
  3255. var
  3256. {$IFNDEF NOCLASSES}
  3257.   TempType: PTypeRec;
  3258.   VM: PVariableManager;
  3259.   AL: Longint;
  3260. {$ENDIF}
  3261.   p: PProcedure;
  3262.   C, c2: PIfVariant;
  3263.   AssignmentNeeded: Boolean;
  3264. begin
  3265.   GetIdentifier := 0;
  3266.   AssignmentNeeded := False;
  3267. {$IFNDEF NOCLASSES}
  3268.   if Parser.CurrTokenId = CSTII_Inherited then begin
  3269.     if Mode <> 0 then begin
  3270.       RunError(Self, EVariableExpected);
  3271.       exit;
  3272.     end;
  3273.     if (GetCurrProc() = nil) or (GetCurrProc()^.ClassType = nil) then begin
  3274.       RunError(Self, ENoInheritedAllowedHere);
  3275.       exit;
  3276.     end;
  3277.     Parser.Next;
  3278.     if Parser.CurrTokenId = CSTI_Semicolon then begin
  3279.       if IntProcDefParam(GetCurrProc^.Decl, 0) <> 0 then begin
  3280.         C := CreateCajVariant(Pointer(IntProcDefParam(GetCurrProc^.Decl, 0)));
  3281.       end else
  3282.         C := nil;
  3283.       RunInherited(GetCurrProc, Vars, C);
  3284.       if FError.ErrorCode <> 0 then begin
  3285.         exit;
  3286.       end;
  3287.       DestroyCajVariant(C);
  3288.     end else begin
  3289.       if Parser.CurrTokenId <> CSTI_Identifier then begin
  3290.         RunError(Self, EIdentifierExpected);
  3291.         exit;
  3292.       end;
  3293.       if not GetClassProcedure(nil, GetCurrProc^.ClassType^.Ext, Parser.GetToken, p, True) then begin
  3294.         RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3295.         exit;
  3296.       end;
  3297.       p := GetInheritedProc(p);
  3298.       if not assigned(p) then begin
  3299.         RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3300.         exit;
  3301.       end;
  3302.       Parser.Next;
  3303.       w := DoProc(WithList, GetVarLink(Vm_Get(Vars, VM_Find(Vars, 'SELF')))^.CV_Class, p, Vars);
  3304.       if ErrorCode <> 0 then begin
  3305.         exit;
  3306.       end;
  3307.       if w = nil then begin
  3308.         GetIdentifier := 2;
  3309.         exit;
  3310.       end;
  3311.     end;
  3312.   end {CSTII_Inherited} else {$ENDIF}
  3313.     if Parser.CurrTokenId = CSTI_OpenRound then begin
  3314.       if Mode = 1 then begin
  3315.         RunError(Self, EVariableExpected);
  3316.         exit;
  3317.       end;
  3318.       Parser.Next;
  3319.       w := CreateVarType(nil);
  3320.       if not calc(WithList, Vars, w, CSTI_CloseRound, False) then begin
  3321.         DestroyCajVariant(w);
  3322.         exit;
  3323.       end;
  3324.       if Parser.CurrTokenId <> CSTI_CloseRound then begin
  3325.         RunError(Self, ECloseRoundExpected);
  3326.         DestroyCajVariant(w);
  3327.         exit;
  3328.       end;
  3329.       Parser.Next;
  3330.     end {CSTI_OpenRound} else if Parser.CurrTokenId = CSTI_Identifier then begin
  3331. {$IFNDEF NOCLASSES}
  3332.       w := nil;
  3333.       if WithList.Count > 0 then begin
  3334.         for AL := 0 to Longint(WithList.Count) - 1 do begin
  3335.           if GetVarLink(WithList.GetItem(AL))^.VType.atypeid = CSV_Class then begin
  3336.             if GetClassVariable2(GetVarLink(WithList.GetItem(AL))^.CV_Class, GetVarLink(WithList.GetItem(AL))^.VType^.Ext, Parser.GetToken, w, True) then begin
  3337.               AssignmentNeeded := True;
  3338.               Parser.Next;
  3339.               break;
  3340.             end else if GetClassProcedure(nil, GetVarLink(WithList.GetItem(AL))^.VType^.Ext, Parser.GetToken, p, True) then begin
  3341.               if Mode = 1 then begin
  3342.                 RunError(Self, EVariableExpected);
  3343.                 exit;
  3344.               end;
  3345.               Parser.Next;
  3346.               if Mode = 2 then begin
  3347.                 w := CreateCajVariant(TM_Add(Types, '', CSV_ProcVariable, nil));
  3348.                 w^.Cv_Proc := p;
  3349.                 w^.Cv_ProcSelf := GetVarLink(WithList.GetItem(AL))^.CV_Class;
  3350.               end else begin
  3351.                 if (p = GetCurrProc()) and (assigned(Vars)) and (IntProcDefParam(p^.Decl, 0) <> 0) and (Parser.CurrTokenId <> CSTI_OpenRound) then begin
  3352.                   w := Vm_Get(Vars, VM_Find(Vars, 'RESULT'));
  3353.                   AssignmentNeeded := True;
  3354.                 end else begin
  3355.                   w := DoProc(WithList, GetVarLink(WithList.GetItem(AL))^.CV_Class, p, Vars);
  3356.                   if ErrorCode <> 0 then begin
  3357.                     exit;
  3358.                   end;
  3359.                 end;
  3360.               end;
  3361.               if w = nil then begin
  3362.                 GetIdentifier := 2;
  3363.                 exit;
  3364.               end;
  3365.               break;
  3366.             end else w := nil;
  3367.           end else if GetVarLink(WithList.GetItem(AL))^.VType.atypeid = CSV_Record then
  3368.           begin
  3369.             w := GetRecordSubVar(GetVarLink(WithList.GetItem(AL)), Parser.GetToken);
  3370.             if w <> nil then
  3371.             begin
  3372.               Parser.Next;
  3373.               AssignmentNeeded := True;
  3374.             end;
  3375.           end;
  3376.         end;
  3377.       end;
  3378.       if not assigned(w) then
  3379.         if (TM_Get(Types, Parser.GetToken) <> nil) and not (PM_Find(Procedures, Parser.GetToken) <> -1) then begin
  3380.           if Mode = 1 then begin
  3381.             RunError(Self, EVariableExpected);
  3382.             exit;
  3383.           end;
  3384.           TempType := GetTypeLink(TM_Get(Types, Parser.GetToken));
  3385.           if TempType^.atypeid <> CSV_Class then begin
  3386.             RunError(Self, EClassTypeExpected);
  3387.             exit;
  3388.           end;
  3389.           Parser.Next;
  3390.           if Parser.CurrTokenId = CSTI_Period then begin
  3391.             if Mode = 2 then begin
  3392.               RunError(Self, EVariableExpected);
  3393.               exit;
  3394.             end;
  3395.             Parser.Next;
  3396.             if Parser.CurrTokenId <> CSTI_Identifier then begin
  3397.               RunError(Self, EIdentifierExpected);
  3398.               exit;
  3399.             end;
  3400.             p := FindProc(TempType, '!' + Parser.GetToken);
  3401.             if p = nil then begin
  3402.               RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3403.               exit;
  3404.             end;
  3405.             w := DoClassConstructor(WithList, TempType, p, Vars);
  3406.             if FError.ErrorCode <> 0 then begin
  3407.               exit;
  3408.             end;
  3409.           end else if Parser.CurrTokenId = CSTI_OpenRound then begin
  3410.             Parser.Next;
  3411.             w := CreateCajVariant(TempType);
  3412.             if not calc(WithList, Vars, w, CSTI_CloseRound, False) then begin
  3413.               DestroyCajVariant(w);
  3414.               exit;
  3415.             end;
  3416.             if Parser.CurrTokenId <> CSTI_CloseRound then begin
  3417.               RunError(Self, ECloseRoundExpected);
  3418.               DestroyCajVariant(w);
  3419.               exit;
  3420.             end;
  3421.             Parser.Next;
  3422.           end else begin
  3423.             w := CreateCajVariant(TM_Add(Types, '', CSV_ClassRef, TempType));
  3424.             w^.Cv_ClassRef := TempType;
  3425.           end;
  3426.         end else
  3427. {$ENDIF}
  3428.           if assigned(Vars) and (VM_Find(Vars, Parser.GetToken) <> -1) then begin
  3429.             AssignmentNeeded := True;
  3430.             w := Vm_Get(Vars, VM_Find(Vars, Parser.GetToken));
  3431.             Parser.Next;
  3432.           end else if VM_Find(Variables, Parser.GetToken) <> -1 then begin
  3433.             AssignmentNeeded := True;
  3434.             w := Vm_Get(Variables, VM_Find(Variables, Parser.GetToken));
  3435.             Parser.Next;
  3436.           end else if PM_Find(Procedures, Parser.GetToken) <> -1 then begin
  3437.             if Mode = 1 then begin
  3438.               RunError(Self, EVariableExpected);
  3439.               exit;
  3440.             end;
  3441.             p := PM_Get(Procedures, PM_Find(Procedures, Parser.GetToken));
  3442.             Parser.Next;
  3443.             if Mode = 2 then begin
  3444.               w := CreateCajVariant(TM_Add(Types, '', CSV_ProcVariable, nil));
  3445.               w^.Cv_Proc := p;
  3446. {$IFNDEF NOCLASSES}w^.Cv_ProcSelf := nil;
  3447. {$ENDIF}
  3448.             end else begin
  3449.               if (p = GetCurrProc()) and (assigned(Vars)) and (IntProcDefParam(p^.Decl, 0) <> 0) and (Parser.CurrTokenId <> CSTI_OpenRound) then begin
  3450.                 w := Vm_Get(Vars, VM_Find(Vars, 'RESULT'));
  3451.                 AssignmentNeeded := True;
  3452.               end else begin
  3453.                 w := DoProc(WithList, {$IFNDEF NOCLASSES}nil, {$ENDIF}p, Vars);
  3454.                 if ErrorCode <> 0 then begin
  3455.                   exit;
  3456.                 end;
  3457.               end;
  3458.             end;
  3459.             if w = nil then begin
  3460.               GetIdentifier := 2;
  3461.               exit;
  3462.             end;
  3463.           end else begin
  3464.             RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3465.             exit;
  3466.           end;
  3467.     end else begin
  3468.       RunError(Self, EIdentifierExpected);
  3469.       exit;
  3470.     end;
  3471.   if (Parser.CurrTokenId = CSTI_DEREFERENCE) and (w^.VType^.atypeid = CSV_ProcVariable) then begin
  3472.     if Mode <> 0 then begin
  3473.       if not AssignmentNeeded then DestroyCajVariant(w);
  3474.       RunError(Self, EVariableExpected);
  3475.       exit;
  3476.     end;
  3477.     Parser.Next;
  3478.     C := w;
  3479.     w := DoProc(WithList, {$IFNDEF NOCLASSES}w^.Cv_ProcSelf, {$ENDIF}w^.Cv_Proc, Vars);
  3480.     if not AssignmentNeeded then DestroyCajVariant(C);
  3481.     if ErrorCode <> ENoError then begin
  3482.       exit;
  3483.     end;
  3484.     if w = nil then begin
  3485.       GetIdentifier := 2;
  3486.       exit;
  3487.     end;
  3488.   end;
  3489.   while (Parser.CurrTokenId = CSTI_OpenBlock) or (Parser.CurrTokenId = CSTI_Period) do begin
  3490.     w := GetVarLink(w);
  3491. {$IFNDEF NOCLASSES}
  3492.     if (w^.VType^.atypeid = CSV_Property) then begin
  3493.       if Mode = 1 then begin
  3494.         if AssignmentNeeded then DestroyCajVariant(w);
  3495.         RunError(Self, EVariableExpected);
  3496.         exit;
  3497.       end;
  3498.       C := w;
  3499.       w := GetProperty(w);
  3500.       if not AssignmentNeeded then begin
  3501.         DestroyCajVariant(C);
  3502.       end;
  3503.       if w = nil then begin
  3504.         exit;
  3505.       end;
  3506.       AssignmentNeeded := False;
  3507.     end;
  3508.     if (w^.VType^.atypeid = CSV_ExternalObjectProperty) then begin
  3509.       if Mode = 1 then begin
  3510.         if AssignmentNeeded then DestroyCajVariant(w);
  3511.         RunError(Self, EVariableExpected);
  3512.         exit;
  3513.       end;
  3514.       C := w;
  3515.       if (not assigned(w^.CV_ExtObj)) or (PCreatedCustomObject(w^.CV_ExtObj)^.AlreadyFreed) then begin
  3516.         RunError(Self, EClassNotCreated);
  3517.         if AssignmentNeeded then DestroyCajVariant(C);
  3518.         exit;
  3519.       end;
  3520.       w := CreateCajVariant(PCreatedCustomObject(C^.CV_ExtObj).p.GetPropertyType(C^.CV_PropertyNo));
  3521.       if not PCreatedCustomObject(C^.CV_ExtObj).p.GetProperty(C^.CV_PropertyNo, w) then begin
  3522.         RunError(Self, ECanNotReadProperty);
  3523.         DestroyCajVariant(w);
  3524.         if AssignmentNeeded then DestroyCajVariant(C);
  3525.         exit;
  3526.       end;
  3527.       if not AssignmentNeeded then DestroyCajVariant(C);
  3528.       if w = nil then begin
  3529.         RunError(Self, ETypeMismatch);
  3530.         exit;
  3531.       end;
  3532.       AssignmentNeeded := False;
  3533.     end;
  3534. {$ENDIF}
  3535.     if Parser.CurrTokenId = CSTI_OpenBlock then begin
  3536.       Parser.Next;
  3537.       if not AssignmentNeeded then begin
  3538.         RunError(Self, ETypeMismatch);
  3539.         DestroyCajVariant(w);
  3540.         exit;
  3541.       end;
  3542.       while True do begin
  3543.         if w^.VType^.atypeid <> CSV_Array then begin
  3544.           RunError(Self, ETypeMismatch);
  3545.           exit;
  3546.         end; {if}
  3547.         C := CreateCajVariant(TM_Add(Types, '', CSV_SInt32, nil));
  3548.         if not calc(WithList, Vars, C, CSTI_CloseBlock, False) then begin
  3549.           DestroyCajVariant(C);
  3550.           exit;
  3551.         end; {if}
  3552.         w := w^.CV_ArrItems.GetItem(C^.Cv_SInt32);
  3553.         DestroyCajVariant(C);
  3554.         if w = nil then
  3555.         begin
  3556.           RunError(Self, EOutOfRange);
  3557.           exit;
  3558.         end;
  3559.         if Parser.CurrTokenId = CSTI_CloseBlock then begin
  3560.           Parser.Next;
  3561.           break;
  3562.         end;
  3563.         if Parser.CurrTokenId = CSTI_Comma then begin
  3564.           Parser.Next;
  3565.         end else begin
  3566.           RunError(Self, ECloseBlockExpected);
  3567.           exit;
  3568.         end;
  3569.       end;
  3570.     end else if Parser.CurrTokenId = CSTI_Period then begin
  3571.       Parser.Next;
  3572.       if w^.VType^.atypeid = CSV_Record then begin
  3573.         if Parser.CurrTokenId <> CSTI_Identifier then begin
  3574.           RunError(Self, EIdentifierExpected);
  3575.           exit;
  3576.         end;
  3577.         if AssignmentNeeded then begin
  3578.           w := GetRecordSubVar(w, Parser.GetToken);
  3579.           if w = nil then begin
  3580.             RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3581.             exit;
  3582.           end;
  3583.           Parser.Next;
  3584.         end else begin
  3585.           c2 := w;
  3586.           w := GetRecordSubVar(w, Parser.GetToken);
  3587.           if w = nil then begin
  3588.             RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3589.             DestroyCajVariant(c2);
  3590.             exit;
  3591.           end;
  3592.           Parser.Next;
  3593.         end;
  3594.       end{$IFNDEF NOCLASSES} else if w^.VType^.atypeid = CSV_Class then begin
  3595.         if Mode = 1 then begin
  3596.           if not AssignmentNeeded then DestroyCajVariant(w);
  3597.           RunError(Self, EVariableExpected);
  3598.           exit;
  3599.         end;
  3600.         if not assigned(w^.CV_Class) or (w^.CV_Class^.AlreadyFreed) then begin
  3601.           if not AssignmentNeeded then DestroyCajVariant(w);
  3602.           if not assigned(w^.CV_Class) then
  3603.             RunError(Self, EClassNotCreated)
  3604.           else
  3605.             RunError(Self, EClassAlreadyFreed);
  3606.           exit;
  3607.         end;
  3608.         if Mode = 1 then begin
  3609.           RunError(Self, EVariableExpected);
  3610.           if not AssignmentNeeded then DestroyCajVariant(C);
  3611.           exit;
  3612.         end;
  3613.         if not GetClassVariable2(w^.CV_Class, w^.VType^.Ext, Parser.GetToken, C, False) then begin
  3614.           if GetClassProcedure(w, w^.VType^.Ext, Parser.GetToken, p, False) then begin
  3615.             C := w;
  3616.             Parser.Next;
  3617.             if Mode = 2 then begin
  3618.               w := CreateCajVariant(TM_Add(Types, '', CSV_ProcVariable, nil));
  3619.               w^.Cv_Proc := p;
  3620.               w^.Cv_ProcSelf := C^.CV_Class;
  3621.               if not AssignmentNeeded then DestroyCajVariant(C);
  3622.               AssignmentNeeded := False;
  3623.             end else begin
  3624.               w := DoProc(WithList, w^.CV_Class, p, Vars);
  3625.               if not AssignmentNeeded then begin
  3626.                 DestroyCajVariant(C);
  3627.               end;
  3628.               if ErrorCode <> 0 then begin
  3629.                 exit;
  3630.               end else
  3631.                 AssignmentNeeded := False;
  3632.             end;
  3633.             if w = nil then begin
  3634.               GetIdentifier := 2;
  3635.               exit;
  3636.             end;
  3637.           end else begin
  3638.             RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3639.             if not AssignmentNeeded then DestroyCajVariant(C);
  3640.             exit;
  3641.           end;
  3642.         end else begin
  3643.           if not AssignmentNeeded then DestroyCajVariant(w);
  3644.           w := C;
  3645.           AssignmentNeeded := True;
  3646.           Parser.Next;
  3647.         end;
  3648.       end else if w^.VType^.atypeid = CSV_ClassRef then begin
  3649.         if w^.Cv_ClassRef = nil then begin
  3650.           RunError(Self, EClassReferenceNotAssigned);
  3651.           if not AssignmentNeeded then DestroyCajVariant(w);
  3652.           exit;
  3653.         end;
  3654.         if not GetClassProcedure(nil, w^.Cv_ClassRef^.Ext, Parser.GetToken, p, False) then begin
  3655.           RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3656.           if not AssignmentNeeded then DestroyCajVariant(w);
  3657.           exit;
  3658.         end;
  3659.         if (p^.Flags and $40) = 0 then begin
  3660.           RunError(Self, EConstructorExpected);
  3661.           if not AssignmentNeeded then DestroyCajVariant(w);
  3662.           exit;
  3663.         end;
  3664.         C := w;
  3665.         w := DoClassConstructor(WithList, w^.Cv_ClassRef, p, Vars);
  3666.         if not AssignmentNeeded then DestroyCajVariant(C);
  3667.         if FError.ErrorCode <> 0 then begin
  3668.           exit;
  3669.         end;
  3670.         AssignmentNeeded := False;
  3671.       end else if w^.VType^.atypeid = CSV_ExternalObject then begin
  3672.         if Mode = 1 then begin
  3673.           if not AssignmentNeeded then DestroyCajVariant(w);
  3674.           RunError(Self, EVariableExpected);
  3675.           exit;
  3676.         end;
  3677.         if not assigned(w^.CV_ExternalObject) then begin
  3678.           RunError(Self, EClassNotCreated);
  3679.           if not AssignmentNeeded then DestroyCajVariant(w);
  3680.           exit;
  3681.         end;
  3682.         if PCreatedCustomObject(w^.CV_ExternalObject)^.AlreadyFreed then begin
  3683.           RunError(Self, EClassAlreadyFreed);
  3684.           if not AssignmentNeeded then DestroyCajVariant(w);
  3685.           exit;
  3686.         end;
  3687.         if PCreatedCustomObject(w^.CV_ExternalObject)^.p.FindProperty(Parser.GetToken) <> -1 then begin
  3688.           AL := PCreatedCustomObject(w^.CV_ExternalObject)^.p.FindProperty(Parser.GetToken);
  3689.           Parser.Next;
  3690.           C := w;
  3691.           w := CreateCajVariant(TM_Add(Types, '', CSV_ExternalObjectProperty, nil));
  3692.           w^.CV_ExtObj := C^.CV_ExternalObject;
  3693.           w^.CV_PropertyNo := AL;
  3694.           if not AssignmentNeeded then DestroyCajVariant(C);
  3695.           AssignmentNeeded := False;
  3696.         end else if PCreatedCustomObject(w^.CV_ExternalObject)^.p.FindProc(Parser.GetToken) <> -1 then begin
  3697.           AL := PCreatedCustomObject(w^.CV_ExternalObject)^.p.FindProc(Parser.GetToken);
  3698.           VM := VM_Create;
  3699.           Parser.Next;
  3700.           if not ReadParams(WithList, PCreatedCustomObject(w^.CV_ExternalObject)^.p.GetProcHeader(AL), Vars, VM) then begin
  3701.             if not AssignmentNeeded then DestroyCajVariant(w);
  3702.             VM_Destroy(VM);
  3703.             exit;
  3704.           end;
  3705.           C := w;
  3706.           w := PCreatedCustomObject(w^.CV_ExternalObject)^.p.CallProc(AL, VM);
  3707.           if not AssignmentNeeded then DestroyCajVariant(C);
  3708.           AssignmentNeeded := False;
  3709.           VM_Destroy(VM);
  3710.           if w = nil then begin
  3711.             GetIdentifier := 2;
  3712.             exit;
  3713.           end;
  3714.         end else begin
  3715.           RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3716.           if not AssignmentNeeded then DestroyCajVariant(w);
  3717.           exit;
  3718.         end;
  3719.       end{$ENDIF} else begin
  3720.         RunError(Self, ETypeMismatch);
  3721.       end;
  3722.     end else begin
  3723.       if not AssignmentNeeded then DestroyCajVariant(w);
  3724.       RunError(Self, ENotSupported);
  3725.       exit;
  3726.     end;
  3727.     if (Parser.CurrTokenId = CSTI_DEREFERENCE) and (w^.VType^.atypeid = CSV_ProcVariable) then begin
  3728.       if Mode <> 0 then begin
  3729.         if not AssignmentNeeded then DestroyCajVariant(w);
  3730.         RunError(Self, EVariableExpected);
  3731.         exit;
  3732.       end;
  3733.       Parser.Next;
  3734.       C := w;
  3735.       w := DoProc(WithList, {$IFNDEF NOCLASSES}w^.Cv_ProcSelf, {$ENDIF}w^.Cv_Proc, Vars);
  3736.       if not AssignmentNeeded then DestroyCajVariant(C);
  3737.       if ErrorCode <> ENoError then begin
  3738.         exit;
  3739.       end;
  3740.       if w = nil then begin
  3741.         GetIdentifier := 2;
  3742.         exit;
  3743.       end;
  3744.     end;
  3745.   end; {while}
  3746.   if AssignmentNeeded then
  3747.     GetIdentifier := 1
  3748.   else
  3749.     GetIdentifier := 2;
  3750. end; {GetIdentifier}
  3751. //-------s------------------------------------------------------------
  3752.  
  3753. function TIfPasScript.IdentifierExists(AlsoVariables: Boolean; SubVars: PVariableManager; const s: string): Boolean;
  3754. { Check if an identifier exists }
  3755.  
  3756.   function UsesExists(s: string): Boolean;
  3757.   var
  3758.     I: Integer;
  3759.   begin
  3760.     UsesExists := False;
  3761.     for I := 0 to Longint(FUses.Count) - 1 do
  3762.       if FUses.GetItem(I) = s then begin
  3763.         UsesExists := True;
  3764.         break;
  3765.       end;
  3766.   end; { UsesExists }
  3767. begin
  3768.   IdentifierExists := False;
  3769. {$IFNDEF NOCLASSES}
  3770.   if s = 'SELF' then
  3771.     IdentifierExists := True
  3772.   else {$ENDIF}if UsesExists(s) then
  3773.       IdentifierExists := True
  3774.     else if PM_Find(Procedures, s) <> -1 then
  3775.       IdentifierExists := True
  3776.     else if AlsoVariables and (VM_Find(Variables, s) <> -1) then
  3777.       IdentifierExists := True
  3778.     else if TM_Get(Types, s) <> nil then
  3779.       IdentifierExists := True
  3780.     else if assigned(SubVars) and (VM_Find(SubVars, s) <> -1) then
  3781.       IdentifierExists := True
  3782. end; {IdentifierExists}
  3783.  
  3784. //-------------------------------------------------------------------
  3785.  
  3786. function TIfPasScript.GetPData(var Data: string): Boolean;
  3787. begin
  3788.   GetPData := Parser.GETDATA(Data);
  3789. end;
  3790. //-------------------------------------------------------------------
  3791.  
  3792. procedure TIfPasScript.SetText(const Data: string);
  3793. var
  3794.   E: TIFPARSERERROR;
  3795. begin
  3796.   if not Parser.SetText(Data, E) then begin
  3797.     case E.KIND of
  3798.       ICOMMENTERROR: RunError(Self, ECommentError);
  3799.       ISTRINGERROR: RunError(Self, EStringError);
  3800.       ICHARERROR: RunError(Self, ECharError);
  3801.     else
  3802.       RunError(Self, ESyntaxError);
  3803.     end;
  3804.     FError.ErrorPosition := E.Position;
  3805.     exit;
  3806.   end;
  3807.   LoadData;
  3808. end;
  3809.  
  3810. procedure TIfPasScript.SetPData(const Data: string);
  3811. begin
  3812.   if not Parser.SetData(Data) then begin
  3813.     RunError2(Self, ECustomError, 'Could not load PData');
  3814.     exit;
  3815.   end;
  3816.   LoadData;
  3817. end;
  3818.  
  3819. //-------------------------------------------------------------------
  3820.  
  3821. procedure TIfPasScript.LoadData;
  3822. { Assign a text to the script engine, this also checks for uses and variables. }
  3823. var
  3824.   HaveHadProgram,
  3825.     HaveHadUnit,
  3826.     HaveHadUses: Boolean;
  3827.  
  3828.   function ProcessUses: Boolean;
  3829.   {Process Uses block}
  3830.   var
  3831.     I: Integer;
  3832.   begin
  3833.     ProcessUses := False;
  3834.     while Parser.CurrTokenId <> CSTI_EOF do begin
  3835.       if Parser.CurrTokenId <> CSTI_Identifier then begin
  3836.         RunError(Self, EIdentifierExpected);
  3837.         exit;
  3838.       end; {If}
  3839.       if IdentifierExists(True, nil, Parser.GetToken) then begin
  3840.         RunError(Self, EDuplicateIdentifier);
  3841.         exit;
  3842.       end; {If}
  3843.       FUses.Add(Parser.GetToken);
  3844.       if assigned(OnUses) then begin
  3845.         I := OnUses(fId, Self, Parser.GetToken);
  3846.         if I <> ENoError then begin
  3847.           RunError(Self, I);
  3848.           exit;
  3849.         end; {If}
  3850.       end {If}
  3851.       else begin
  3852.         RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3853.         exit;
  3854.       end; {Else if}
  3855.       Parser.Next;
  3856.       if (Parser.CurrTokenId = CSTI_Semicolon) then begin
  3857.         Parser.Next;
  3858.         break;
  3859.       end {if}
  3860.       else if (Parser.CurrTokenId <> CSTI_Comma) then begin
  3861.         RunError(Self, ESemiColonExpected);
  3862.         exit;
  3863.       end else {Else if}  begin
  3864.         Parser.Next;
  3865.       end;
  3866.     end;
  3867.     if Parser.CurrTokenId = CSTI_EOF then begin
  3868.       RunError(Self, EUnexpectedEndOfFile);
  3869.     end {If}
  3870.     else begin
  3871.       ProcessUses := True;
  3872.     end; {Else If}
  3873.   end; {ProcessUses}
  3874.  
  3875.   function DoFuncHeader: Boolean;
  3876.   var
  3877.     FuncParam: string;
  3878.     FuncName: string;
  3879.     CurrVar: string;
  3880.     CurrType: Pointer;
  3881.     FuncRes: Pointer;
  3882.     PT: Byte;
  3883.     Cp: PProcedure;
  3884.     Temp: PIfVariant;
  3885.   {$IFNDEF NOCLASSES}
  3886.     Myclass: PTypeRec;
  3887.  
  3888.     function GetclassProc: Boolean;
  3889.     var
  3890.       I: Integer;
  3891.       p: PProcedure;
  3892.     begin
  3893.       for I := 0 to Longint(PIFSClassType(Myclass.Ext)^.Procedures.Count) - 1 do begin
  3894.         p := PIFSClassType(Myclass.Ext)^.Procedures.GetItem(I);
  3895.         if (Pos('!', p^.Name) = 1) and (copy(p^.Name, 2, Length(p^.Name) - 1) = FuncName) then begin
  3896.           if (p^.Mode <> 0) or (p^.offset <> -1) then begin
  3897.             RunError(Self, EDuplicateIdentifier);
  3898.             Result := False;
  3899.             exit;
  3900.           end else begin
  3901.             Cp := p;
  3902.             Result := True;
  3903.             exit;
  3904.           end;
  3905.         end;
  3906.       end;
  3907.       RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  3908.       Result := False;
  3909.     end;
  3910.   {$ENDIF}
  3911.  
  3912.     function MKString(const s: string): string;
  3913.     begin
  3914.       MKString := copy(s, 2, Length(s) - 2);
  3915.     end;
  3916.  
  3917.     function Duplic(s: string): Boolean;
  3918.     var
  3919.       s2, s3: string;
  3920.       I: Integer;
  3921.     begin
  3922.       if s = FuncName then begin
  3923.         Duplic := True;
  3924.         exit;
  3925.       end; {if}
  3926.       if (FuncRes <> nil) and (s = 'RESULT') then begin
  3927.         Duplic := True;
  3928.         exit;
  3929.       end;
  3930.       s2 := CurrVar;
  3931.       while Pos('|', s2) > 0 do begin
  3932.         if Pos('!', s2) = 1 then
  3933.           Delete(s2, 1, 1);
  3934.         if copy(s2, 1, Pos('|', s2) - 1) = s then begin
  3935.           Duplic := True;
  3936.           exit;
  3937.         end; {if}
  3938.         Delete(s2, 1, Pos('|', s2));
  3939.       end; {while}
  3940.       s2 := '0 ' + FuncParam;
  3941.       for I := 1 to IntProcDefParam(s2, -1) do begin
  3942.         s3 := IntProcDefName(s2, 0);
  3943.         if Pos('!', s2) = 1 then
  3944.           Delete(s2, 1, 1);
  3945.         if s3 = s then begin
  3946.           Duplic := True;
  3947.           exit;
  3948.         end; {if}
  3949.       end; {for}
  3950.       Duplic := False;
  3951.     end; {duplic}
  3952.   begin
  3953.     DoFuncHeader := False;
  3954.     if Parser.CurrTokenId = CSTII_Procedure then begin
  3955.       PT := 0;
  3956.       FuncRes := nil
  3957.     end else
  3958.       if Parser.CurrTokenId = CSTII_Constructor then begin
  3959.         PT := 2;
  3960.         FuncRes := nil
  3961.       end else
  3962.         if Parser.CurrTokenId = CSTII_Destructor then begin
  3963.           PT := 3;
  3964.           FuncRes := nil
  3965.         end else begin
  3966.           PT := 1;
  3967.           FuncRes := Pointer(1);
  3968.         end;
  3969.     Parser.Next;                                 
  3970.     if Parser.CurrTokenId <> CSTI_Identifier then begin
  3971.       RunError(Self, EIdentifierExpected);
  3972.       exit;
  3973.     end; {if}
  3974.     cp := nil;
  3975.     if IdentifierExists(True, nil, Parser.GetToken) then begin
  3976. {$IFNDEF NOCLASSES}     
  3977.       Myclass := GetTypeLink(TM_Get(Types, Parser.GetToken));
  3978.       if not assigned(Myclass) or (Myclass^.atypeid <> CSV_Class) then begin
  3979. {$ENDIF}
  3980.         cp := Procedures.GetItem(PM_Find(Procedures, Parser.GetToken));
  3981.         if (cp^.Mode <> 0) or (cp^.Offset <> -1) then
  3982.         begin
  3983.           RunError(Self, EDuplicateIdentifier);
  3984.           exit;
  3985.         end;
  3986. {$IFNDEF NOCLASSES}
  3987.       end else begin
  3988.         Parser.Next;
  3989.         if Parser.CurrTokenId <> CSTI_Period then begin
  3990.           RunError(Self, EPeriodExpected);
  3991.           exit;
  3992.         end;
  3993.         Parser.Next;
  3994.       end;
  3995. {$ENDIF}
  3996.     end{$IFNDEF NOCLASSES} else Myclass := nil{$ENDIF}; {if}
  3997.     FuncName := Parser.GetToken;
  3998. {$IFNDEF NOCLASSES}
  3999.     if assigned(Myclass) then begin
  4000.       if not GetclassProc then
  4001.         exit;
  4002.       if ((Cp^.Flags and $40) <> 0) then begin
  4003.         if (PT <> 2) then begin
  4004.           RunError(Self, EParameterError);
  4005.           exit;
  4006.         end;
  4007.       end else if ((Cp^.Flags and $80) <> 0) then begin
  4008.         if (PT <> 3) then begin
  4009.           RunError(Self, EParameterError);
  4010.           exit;
  4011.         end;
  4012.       end else if (Fw(Cp^.Decl) = '0') then begin
  4013.         if PT <> 0 then begin
  4014.           RunError(Self, EParameterError);
  4015.           exit;
  4016.         end;
  4017.       end else begin
  4018.         if PT <> 1 then begin
  4019.           RunError(Self, EParameterError);
  4020.           exit;
  4021.         end;
  4022.       end;
  4023.     end else begin
  4024. {$ENDIF}
  4025.       if (PT <> 0) and (PT <> 1) then begin
  4026.         RunError(Self, EIdentifierExpected);
  4027.         exit;
  4028.       end;
  4029. {$IFNDEF NOCLASSES} end;
  4030. {$ENDIF}
  4031.     FuncParam := '';
  4032.     CurrVar := '';
  4033.     Parser.Next;
  4034.     if Parser.CurrTokenId = CSTI_OpenRound then begin
  4035.       Parser.Next;
  4036.       if Parser.CurrTokenId = CSTI_CloseRound then begin
  4037.         Parser.Next;
  4038.       end else begin
  4039.         while True do begin
  4040.           if Parser.CurrTokenId = CSTII_Var then begin
  4041.             CurrVar := '!';
  4042.             Parser.Next;
  4043.           end else {if}
  4044.             if Parser.CurrTokenId = CSTII_Const then begin
  4045.               CurrVar := '^';
  4046.               Parser.Next;
  4047.             end; {if}
  4048.           while True do begin
  4049.             if Parser.CurrTokenId <> CSTI_Identifier then begin
  4050.               RunError(Self, EIdentifierExpected);
  4051.               exit;
  4052.             end; {if}
  4053.             if IdentifierExists(True, nil, Parser.GetToken) or Duplic(Parser.GetToken)
  4054.               then begin
  4055.               RunError(Self, EDuplicateIdentifier);
  4056.               exit;
  4057.             end; {if}
  4058.             CurrVar := CurrVar + Parser.GetToken + '|';
  4059.             Parser.Next;
  4060.             if Parser.CurrTokenId = CSTI_Colon then
  4061.               break;
  4062.             if Parser.CurrTokenId <> CSTI_Comma then begin
  4063.               RunError(Self, ECommaExpected);
  4064.               exit;
  4065.             end; {if}
  4066.             Parser.Next;
  4067.           end; {while}
  4068.           Parser.Next;
  4069.           CurrType := ReadType(Parser, False, '');
  4070.           if CurrType = nil then begin
  4071.             RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  4072.             exit;
  4073.           end; {if}
  4074.           if Pos('^', CurrVar) = 1 then begin
  4075.             Delete(CurrVar, 1, 1);
  4076.             while Pos('|', CurrVar) > 0 do begin
  4077.               FuncParam := FuncParam + ' ^' + copy(CurrVar, 1, Pos('|', CurrVar) - 1) + ' ' + inttostr(Longint(CurrType));
  4078.               Delete(CurrVar, 1, Pos('|', CurrVar));
  4079.             end; {while}
  4080.           end else if Pos('!', CurrVar) = 1 then begin
  4081.             Delete(CurrVar, 1, 1);
  4082.             while Pos('|', CurrVar) > 0 do begin
  4083.               FuncParam := FuncParam + ' !' + copy(CurrVar, 1, Pos('|', CurrVar) - 1) + ' ' + inttostr(Longint(CurrType));
  4084.               Delete(CurrVar, 1, Pos('|', CurrVar));
  4085.             end; {while}
  4086.           end else begin
  4087.             while Pos('|', CurrVar) > 0 do begin
  4088.               FuncParam := FuncParam + ' ' + copy(CurrVar, 1, Pos('|', CurrVar) - 1) + ' ' + inttostr(Longint(CurrType));
  4089.               Delete(CurrVar, 1, Pos('|', CurrVar));
  4090.             end; {while}
  4091.           end; {if}
  4092.           if Parser.CurrTokenId = CSTI_CloseRound then begin
  4093.             Parser.Next;
  4094.             break;
  4095.           end; {if}
  4096.           if Parser.CurrTokenId <> CSTI_Semicolon then begin
  4097.             RunError(Self, ESemiColonExpected);
  4098.             exit;
  4099.           end; {if}
  4100.           Parser.Next;
  4101.         end; {while}
  4102.       end; {else if}
  4103.     end; {if}
  4104.     if FuncRes <> nil then begin
  4105.       if Parser.CurrTokenId <> CSTI_Colon then begin
  4106.         RunError(Self, EColonExpected);
  4107.         exit;
  4108.       end;
  4109.       Parser.Next;
  4110.       FuncRes := ReadType(Parser, False, '');
  4111.       if FuncRes = nil then begin
  4112.         RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  4113.         exit;
  4114.       end;
  4115.     end;
  4116.     FuncParam := inttostr(Longint(FuncRes)) + FuncParam;
  4117.     if Parser.CurrTokenId <> CSTI_Semicolon then begin
  4118.       RunError(Self, ESemiColonExpected);
  4119.       exit;
  4120.     end;
  4121.     Parser.Next;
  4122.     if assigned(cp) then begin
  4123.       if Cp.Decl <> FuncParam then begin
  4124.         RunError(Self, EParameterError);
  4125.         exit;
  4126.       end; {if}
  4127.       Cp.offset := Parser.CurrTokenPos;
  4128.       if Parser.CurrTokenId = CSTII_Var then begin
  4129.         while (Parser.CurrTokenId <> CSTII_Begin) and (Parser.CurrTokenId <> CSTI_EOF) do
  4130.           Parser.Next;
  4131.       end;
  4132.       RunBegin(nil, nil, True);
  4133.       if Parser.CurrTokenId <> CSTI_Semicolon then begin
  4134.         RunError(Self, ESemiColonExpected);
  4135.         exit;
  4136.       end;
  4137.       Parser.Next;
  4138.       DoFuncHeader := True;
  4139.     end else begin
  4140.       Cp := PM_AddInt(Procedures, Self, FuncName, FuncParam, {$IFNDEF NOCLASSES}nil, {$ENDIF}nil, Parser.CurrTokenPos);
  4141.       if Parser.CurrTokenId = CSTII_External then begin
  4142.   {$IFNDEF NOCLASSES}
  4143.         if assigned(Myclass) then begin
  4144.           RunError(Self, EBeginExpected);
  4145.           exit;
  4146.         end;
  4147.   {$ENDIF}
  4148.         Parser.Next;
  4149.         if Parser.CurrTokenId = CSTI_Identifier then begin
  4150.           Temp := Vm_Get(Variables, VM_Find(Variables, Parser.GetToken));
  4151.           if Temp = nil then begin
  4152.             RunError(Self, EUnknownIdentifier);
  4153.             exit;
  4154.           end;
  4155.           if Temp^.VType^.atypeid <> CSV_String then begin
  4156.             RunError(Self, EStringExpected);
  4157.             exit;
  4158.           end;
  4159.           FuncParam := Temp^.Cv_Str;
  4160.           Parser.Next;
  4161.         end else if Parser.CurrTokenId = CSTI_String then begin
  4162.           FuncParam := MKString(Parser.GetToken);
  4163.           Parser.Next;
  4164.         end else begin
  4165.           RunError(Self, EStringExpected);
  4166.           exit;
  4167.         end;
  4168.         if Parser.CurrTokenId = CSTI_Identifier then begin
  4169.           if Parser.GetToken <> 'NAME' then begin
  4170.             RunError(Self, ESemiColonExpected);
  4171.             exit;
  4172.           end;
  4173.           Parser.Next;
  4174.           if Parser.CurrTokenId = CSTI_Identifier then begin
  4175.             Temp := Vm_Get(Variables, VM_Find(Variables, Parser.GetToken));
  4176.             if Temp = nil then begin
  4177.               RunError(Self, EUnknownIdentifier);
  4178.               exit;
  4179.             end;
  4180.             if Temp^.VType^.atypeid <> CSV_String then begin
  4181.               RunError(Self, EStringExpected);
  4182.               exit;
  4183.             end;
  4184.             FuncName := Temp^.Cv_Str;
  4185.             Parser.Next;
  4186.           end else if Parser.CurrTokenId = CSTI_String then begin
  4187.             FuncName := MKString(Parser.GetToken);
  4188.             Parser.Next;
  4189.           end else begin
  4190.             RunError(Self, EStringExpected);
  4191.             exit;
  4192.           end;
  4193.         end;
  4194.         if Parser.CurrTokenId <> CSTI_Semicolon then begin
  4195.           RunError(Self, ESemiColonExpected);
  4196.           exit;
  4197.         end;
  4198.         Parser.Next;
  4199.         if Parser.CurrTokenId = CSTI_Identifier then begin
  4200.           CurrVar := Parser.GetToken;
  4201.           Parser.Next;
  4202.           if Parser.CurrTokenId <> CSTI_Semicolon then begin
  4203.             RunError(Self, ESemiColonExpected);
  4204.             exit;
  4205.           end;
  4206. //          Parser.Next;
  4207.         end else CurrVar := '';
  4208.         if @FOnExternal = nil then begin
  4209.           RunError(Self, EUnknownIdentifier);
  4210.           exit;
  4211.         end;
  4212.         if not FOnExternal(fId, Self, FuncParam, FuncName, Cp, CurrVar) then begin
  4213.           RunError(Self, EUnknownIdentifier);
  4214.           exit;
  4215.         end;
  4216.         DoFuncHeader := True;
  4217.       end else if Parser.CurrTokenId = CSTII_Forward then
  4218.       begin
  4219.   {$IFNDEF NOCLASSES}
  4220.         if assigned(Myclass) then begin
  4221.           RunError(Self, EBeginExpected);
  4222.           exit;
  4223.         end;
  4224.   {$ENDIF}
  4225.         Parser.Next;
  4226.         if Parser.CurrTokenId <> CSTI_Semicolon then
  4227.         begin
  4228.           RunError(Self, ESemicolonExpected);
  4229.           Exit;
  4230.         end;
  4231.         Parser.Next;
  4232.         DoFuncHeader := True;
  4233.         cp^.Mode := 0;
  4234.         Cp^.Offset := -1;
  4235.         exit;
  4236.       end;
  4237.       if Parser.CurrTokenId = CSTII_Var then begin
  4238.         while (Parser.CurrTokenId <> CSTII_Begin) and (Parser.CurrTokenId <> CSTI_EOF) do
  4239.           Parser.Next;
  4240.       end;
  4241.       RunBegin(nil, nil, True);
  4242.       if Parser.CurrTokenId <> CSTI_Semicolon then begin
  4243.         RunError(Self, ESemiColonExpected);
  4244.         exit;
  4245.       end;
  4246.       Parser.Next;
  4247.       DoFuncHeader := True;
  4248.     end;
  4249.   end; {DoFuncHeader}
  4250.  
  4251.   function ProcessTypes: Boolean;
  4252.   var
  4253.     Name: string;
  4254.     p: PTypeRec;
  4255.   begin
  4256.     ProcessTypes := False;
  4257.     Parser.Next;
  4258.     repeat
  4259.       if Parser.CurrTokenId <> CSTI_Identifier then begin
  4260.         RunError(Self, EIdentifierExpected);
  4261.         exit;
  4262.       end; {if}
  4263.       Name := Parser.GetToken;
  4264.       if IdentifierExists(True, nil, Name) then begin
  4265.         RunError(Self, EDuplicateIdentifier);
  4266.         exit;
  4267.       end; {if}
  4268.       Parser.Next;
  4269.       if Parser.CurrTokenId <> CSTI_Equal then begin
  4270.         RunError(Self, EIsExpected);
  4271.         exit;
  4272.       end;
  4273.       Parser.Next;
  4274.       p := ReadType(Parser, True, Name);
  4275.       if p = nil then begin
  4276.         exit;
  4277.       end;
  4278.       if Parser.CurrTokenId <> CSTI_Semicolon then begin
  4279.         RunError(Self, ESemiColonExpected);
  4280.         exit;
  4281.       end;
  4282.       Parser.Next;
  4283.     until Parser.CurrTokenId <> CSTI_Identifier;
  4284.     ProcessTypes := True;
  4285.   end; {ProcessTypes}
  4286.  
  4287.   function CheckForwardProcs: Boolean;
  4288.   var
  4289.     I: Integer;
  4290.     p: PProcedure;
  4291.   begin
  4292.     for I := 0 to Longint(Procedures.Count) - 1 do begin
  4293.       p := Procedures.GetItem(I);
  4294.       if (p^.Mode = 0) and (p^.offset = -1) then begin
  4295. {$IFNDEF NOCLASSES}
  4296.         if p^.ClassType <> nil then
  4297.           RunError2(Self, EUnsatisfiedForward, p^.ClassType^.Ident + '.' + copy(p^.Name, 2, Length(p^.Name) - 1)) else
  4298. {$ENDIF}
  4299.           RunError2(Self, EUnsatisfiedForward, p^.Name);
  4300.         Result := False;
  4301.         exit;
  4302.       end;
  4303.     end;
  4304.     Result := True;
  4305.   end; {CheckClassProcs}
  4306. begin
  4307.   Cleanup;
  4308.   FISUnit := False;
  4309.   FModuleName := 'MAIN';
  4310.   FUses.Clear;
  4311.   VM_Clear(Variables);
  4312.   TM_Destroy(Types);
  4313.   Types := TM_Create;
  4314.   PM_Clear(Procedures);
  4315.   AddStandard;
  4316.   Vm_Add(Variables, CreateBool(True), 'TRUE')^.Flags := 1;
  4317.   Vm_Add(Variables, CreateBool(False), 'FALSE')^.Flags := 1;
  4318.   with Vm_Add(Variables, CreateCajVariant(TM_Add(Types, '', CSV_Special, nil)), 'NIL')^ do begin
  4319.     CV_Spec := 0;
  4320.     Flags := 1;
  4321.   end;
  4322.   FUses.Add('SYSTEM');
  4323.   if assigned(OnUses) then
  4324.     OnUses(fId, Self, 'SYSTEM');
  4325.  
  4326.   RunError(Self, ENoError);
  4327.   MainOffset := -1;
  4328.   HaveHadProgram := False;
  4329.   HaveHadUses := False;
  4330.   HaveHadUnit := False;
  4331.   while Parser.CurrTokenId <> CSTI_EOF do begin
  4332.     if (Parser.CurrTokenId = CSTII_Program) and (HaveHadProgram = False) and
  4333.       (HaveHadUses = False) and (HaveHadUnit = False) then begin
  4334.       Parser.Next;
  4335.       if Parser.CurrTokenId <> CSTI_Identifier then begin
  4336.         RunError(Self, EIdentifierExpected);
  4337.         exit;
  4338.       end; {if}
  4339.       FModuleName := Parser.GetToken;
  4340.       Parser.Next;
  4341.       if Parser.CurrTokenId <> CSTI_Semicolon then begin
  4342.         RunError(Self, ESemiColonExpected);
  4343.         exit;
  4344.       end; {if}
  4345.       Parser.Next;
  4346.       HaveHadProgram := True;
  4347.     end else if (Parser.CurrTokenId = CSTII_UNIT) and (HaveHadProgram = False) and
  4348.       (HaveHadUses = False) and (HaveHadUnit = False) then begin
  4349.       Parser.Next;
  4350.       if Parser.CurrTokenId <> CSTI_Identifier then begin
  4351.         RunError(Self, EIdentifierExpected);
  4352.         exit;
  4353.       end;
  4354.       FModuleName := Parser.GetToken;
  4355.       Parser.Next;
  4356.       if Parser.CurrTokenId <> CSTI_Semicolon then begin
  4357.         RunError(Self, ESemiColonExpected);
  4358.         exit;
  4359.       end; {if}
  4360.       Parser.Next;
  4361.       HaveHadUnit := True;
  4362.       FISUnit := True;
  4363.     end else if (Parser.CurrTokenId = CSTII_Uses) and (HaveHadUses = False) then begin
  4364.       Parser.Next;
  4365.       if not ProcessUses then
  4366.         exit;
  4367.       HaveHadUses := True;
  4368.     end {else if}
  4369.     else if (Parser.CurrTokenId = CSTII_Type) then begin
  4370.       if not ProcessTypes then
  4371.         exit;
  4372.     end
  4373.     else if (Parser.CurrTokenId = CSTII_Var) then begin
  4374.       if not ProcessVars(Variables) then
  4375.         exit;
  4376.     end {Else if}
  4377.     else if (Parser.CurrTokenId = CSTII_Const) then begin
  4378.       if not ProcessConsts(Variables) then
  4379.         exit;
  4380.     end
  4381.     else if (Parser.CurrTokenId = CSTII_Procedure) or
  4382.       (Parser.CurrTokenId = CSTII_Function) or
  4383.       (Parser.CurrTokenId = CSTII_Constructor) or
  4384.       (Parser.CurrTokenId = CSTII_Destructor) then begin
  4385.       if not DoFuncHeader then
  4386.         exit;
  4387.     end {else if}
  4388.     else if (Parser.CurrTokenId = CSTII_Begin) then begin
  4389.       if not CheckForwardProcs then
  4390.         exit;
  4391.       MainOffset := Parser.CurrTokenPos;
  4392.       exit;
  4393.     end {Else if}
  4394.     else if (Parser.CurrTokenId = CSTII_End) and FISUnit then begin
  4395.       if not CheckForwardProcs then
  4396.         exit;
  4397.       MainOffset := Parser.CurrTokenPos;
  4398.       exit;
  4399.     end { Else if}
  4400.     else if (Parser.CurrTokenId = CSTI_EOF) then begin
  4401.       RunError(Self, EUnexpectedEndOfFile);
  4402.     end {Else if}
  4403.     else begin
  4404.       RunError(Self, EBeginExpected);
  4405.       exit;
  4406.     end; {Else If}
  4407.   end; {While}
  4408. end; {SetText}
  4409.  
  4410. //-------------------------------------------------------------------
  4411.  
  4412. function TIfPasScript.ProcessConsts(Vars: PVariableManager): Boolean;
  4413.         { Process constants block (const s = '') }
  4414. var
  4415.   Name: string;
  4416.   Value: PIfVariant;
  4417.   WithList: TIfList;
  4418. begin
  4419.   ProcessConsts := False;
  4420.   Parser.Next;
  4421.   repeat
  4422.     if Parser.CurrTokenId <> CSTI_Identifier then begin
  4423.       RunError(Self, EIdentifierExpected);
  4424.       exit;
  4425.     end;
  4426.     Name := Parser.GetToken;
  4427.     if IdentifierExists(True, Vars, Name) then begin
  4428.       RunError(Self, EDuplicateIdentifier);
  4429.       exit;
  4430.     end;
  4431.     Parser.Next;
  4432.     if Parser.CurrTokenId <> CSTI_Equal then begin
  4433.       RunError(Self, EIsExpected);
  4434.       exit;
  4435.     end;
  4436.     Parser.Next;
  4437.     Value := CreateCajVariant(TM_Add(Types, '', CSV_Var, nil));
  4438.     Value^.CV_Var := nil;
  4439.     WithList := TIfList.Create;
  4440.     if not calc(WithList, Vars, Value, CSTI_Semicolon, True) then begin
  4441.       DestroyCajVariant(Value);
  4442.       DestroyWithList(WithList);
  4443.       exit;
  4444.     end;
  4445.     DestroyWithList(WithList);
  4446.     Value^.Flags := $1;
  4447.     Vm_Add(Vars, Value, Name);
  4448.     Parser.Next;
  4449.   until Parser.CurrTokenId <> CSTI_Identifier;
  4450.   ProcessConsts := True;
  4451. end;
  4452. //-------------------------------------------------------------------
  4453.  
  4454. function TIfPasScript.ProcessVars(Vars: PVariableManager): Boolean;
  4455.         { Process Vars block }
  4456. var
  4457.   Names: string;
  4458.   n: PTypeRec;
  4459.  
  4460.   function IsDuplic(n, s: string): Boolean;
  4461.   begin
  4462.     while Pos('|', n) > 0 do begin
  4463.       if copy(n, 1, Pos('|', n) - 1) = s then begin
  4464.         IsDuplic := True;
  4465.         exit;
  4466.       end;
  4467.       Delete(n, 1, Pos('|', n));
  4468.     end; {if}
  4469.     IsDuplic := False;
  4470.   end;
  4471. begin
  4472.   Parser.Next;
  4473.   ProcessVars := False;
  4474.   while True do begin
  4475.     case Parser.CurrTokenId of
  4476.       CSTI_EOF: begin
  4477.           RunError(Self, EUnexpectedEndOfFile);
  4478.           exit;
  4479.         end;
  4480.     end;
  4481.     if Parser.CurrTokenId <> CSTI_Identifier then begin
  4482.       RunError(Self, EIdentifierExpected);
  4483.       exit;
  4484.     end;
  4485.     if IdentifierExists(False, Vars, Parser.GetToken) then begin
  4486.       RunError(Self, EDuplicateIdentifier);
  4487.       exit;
  4488.     end; {if}
  4489.  
  4490.     Names := Parser.GetToken + '|';
  4491.     Parser.Next;
  4492.     while Parser.CurrTokenId = CSTI_Comma do begin
  4493.       Parser.Next;
  4494.       if Parser.CurrTokenId <> CSTI_Identifier then begin
  4495.         RunError(Self, EIdentifierExpected);
  4496.         exit;
  4497.       end; {if}
  4498.       if IsDuplic(Names, Parser.GetToken) or IdentifierExists(False, Vars, Parser.GetToken) then begin
  4499.         RunError(Self, EDuplicateIdentifier);
  4500.         exit;
  4501.       end; {if}
  4502.       Names := Names + Parser.GetToken + '|';
  4503.       Parser.Next;
  4504.     end; {while}
  4505.     if Parser.CurrTokenId <> CSTI_Colon then begin
  4506.       RunError(Self, EColonExpected);
  4507.       exit;
  4508.     end; {if}
  4509.     Parser.Next;
  4510.     n := ReadType(Parser, False, '');
  4511.     if n = nil then begin
  4512.       exit;
  4513.     end; {if}
  4514.     while Pos('|', Names) > 0 do begin
  4515.       Vm_Add(Vars, CreateCajVariant(n), copy(Names, 1, Pos('|', Names) - 1));
  4516.       Delete(Names, 1, Pos('|', Names));
  4517.     end; {if}
  4518.     if Parser.CurrTokenId <> CSTI_Semicolon then begin
  4519.       RunError(Self, ESemiColonExpected);
  4520.       exit;
  4521.     end; {if}
  4522.     Parser.Next;
  4523.     if Parser.CurrTokenId <> CSTI_Identifier then
  4524.       break;
  4525.   end; {while}
  4526.   ProcessVars := True;
  4527. end; {ProcessVars}
  4528.  
  4529. //-------------------------------------------------------------------
  4530.  
  4531. constructor TIfPasScript.Create(id: Pointer);
  4532. begin
  4533.   inherited Create;
  4534.   fId := id;
  4535. {$IFNDEF NOCLASSES}
  4536.   CreatedClasses := TIfList.Create;
  4537. {$ENDIF}
  4538.   FModuleName := 'MAIN';
  4539.   FISUnit := False;
  4540.   FMaxBeginNesting := High(Longint);
  4541.   FMaxArrayLength := High(Longint);
  4542.  
  4543.   Parser := TIfPascalParser.Create;
  4544.   FAttachedOnes := TIfList.Create;
  4545.   FUses := TIfStringList.Create;
  4546.   FAllocatedResources := TIfList.Create;
  4547.   RunError(Self, ENoError);
  4548.   MainOffset := -1;
  4549.   Procedures := PM_Create;
  4550.   Variables := VM_Create;
  4551.   Types := TM_Create;
  4552.   OnUses := nil;
  4553.   OnRunLine := nil;
  4554.   ProcStack:= TIFList.Create;
  4555.  
  4556. end; {Create}
  4557. //-------------------------------------------------------------------
  4558.  
  4559. destructor TIfPasScript.Destroy;
  4560. begin
  4561.   Cleanup;
  4562.   Parser.Free;
  4563.   VM_Destroy(Variables);
  4564.   PM_Destroy(Procedures);
  4565.   TM_Destroy(Types);
  4566.   FAttachedOnes.Free;
  4567.   FAllocatedResources.Free;
  4568.   ProcStack.Free;
  4569. {$IFNDEF NOCLASSES}
  4570.   CreatedClasses.Free;
  4571. {$ENDIF}
  4572.   FUses.Free;
  4573.   inherited Destroy;
  4574. end; {Create}
  4575. //-------------------------------------------------------------------
  4576.  
  4577. function TIfPasScript.GetErrorCode: TIfPasScriptError;
  4578. begin
  4579.   GetErrorCode := FError.ErrorCode;
  4580. end;
  4581.  
  4582. function TIfPasScript.GetErrorPos: Longint;
  4583. begin
  4584.   GetErrorPos := FError.ErrorPosition;
  4585. end;
  4586.  
  4587. function TIfPasScript.GetErrorString: string;
  4588. begin
  4589.   GetErrorString := FError.ErrorParam;
  4590. end;
  4591.  
  4592. function TIfPasScript.GetErrorModule: string;
  4593. begin
  4594.   GetErrorModule := FError.ErrorModule;
  4595. end;
  4596.  
  4597. procedure TIfPasScript.RunError(SE: TIfPasScript; C: TIfPasScriptError);
  4598. begin
  4599.   if C = ENoError then begin
  4600.     FError.ErrorCode := C;
  4601.     FError.ErrorPosition := -1;
  4602.     FError.ErrorParam := '';
  4603.     FError.ErrorModule := '';
  4604.   end {if}
  4605.   else begin
  4606.     if FError.ErrorCode = ENoError then begin
  4607.       FError.ErrorCode := C;
  4608.       FError.ErrorPosition := SE.Parser.CurrTokenPos;
  4609.       FError.ErrorParam := '';
  4610.       FError.ErrorModule := SE.ModuleName;
  4611.     end;
  4612.   end; {else if}
  4613. end; {RunError}
  4614. //-------------------------------------------------------------------
  4615.  
  4616. procedure TIfPasScript.RunError2(SE: TIfPasScript; C: TIfPasScriptError; Ext: string);
  4617. begin
  4618.   if C = ENoError then begin
  4619.     FError.ErrorCode := C;
  4620.     FError.ErrorPosition := -1;
  4621.     FError.ErrorParam := '';
  4622.     FError.ErrorModule := '';
  4623.   end {if}
  4624.   else begin
  4625.     if FError.ErrorCode = ENoError then begin
  4626.       FError.ErrorCode := C;
  4627.       FError.ErrorPosition := SE.Parser.CurrTokenPos;
  4628.       FError.ErrorParam := Ext;
  4629.       FError.ErrorModule := SE.ModuleName;
  4630.     end;
  4631.   end; {else if}
  4632. end; {RunError2}
  4633.  
  4634. //-------------------------------------------------------------------
  4635. // Procedure: RunScript
  4636. //   Purpose: Process the script commands
  4637. //-------------------------------------------------------------------
  4638.  
  4639. procedure TIfPasScript.RunScript;
  4640. var
  4641.   WithList: TIfList;
  4642. begin
  4643.   ProcStack.Clear;
  4644.   CurrVars := nil;
  4645.  
  4646.   if MainOffset = -1 then exit;
  4647.  
  4648.   RunError(Self, ENoError); // Reset the error code and position
  4649.   Parser.CurrTokenPos := MainOffset; // Position for the next token
  4650.   //
  4651.   // RunBegin actually parses the script and expects a final period
  4652.   //-----------------
  4653.   WithList := TIfList.Create;
  4654.   if RunBegin(WithList, nil, False) then begin
  4655.     if Parser.CurrTokenId <> CSTI_Period then RunError(Self, EPeriodExpected);
  4656.   end;
  4657.   if FError.ErrorCode = EExitCommand then
  4658.     FError.ErrorCode := 0;
  4659.   DestroyWithList(WithList);
  4660.   FBeginNesting := 0;
  4661.  
  4662. end; {RunScript}
  4663. //-------------------------------------------------------------------
  4664. type
  4665.   PSmallCalculation = ^TSmallCalculation;
  4666.   TSmallCalculation = packed record
  4667.     TType: Byte;
  4668.                                   {
  4669.                                   0 = Variant
  4670.  
  4671.                                   2 = *
  4672.                                   3 = /
  4673.                                   4 = DIV
  4674.                                   5 = MOD
  4675.                                   6 = AND
  4676.                                   7 = SHR
  4677.                                   8 = SHL
  4678.  
  4679.                                   9 = +
  4680.                                   10 = -
  4681.                                   11 = OR
  4682.                                   12 = XOR
  4683.  
  4684.                                   13 = =
  4685.                                   14 = >
  4686.                                   15 = <
  4687.                                   16 = <>
  4688.                                   17 = <=
  4689.                                   18 = >=
  4690.                                   19 = AS
  4691.                                   20 = IS
  4692.                                   }
  4693.     CajVariant: PIfVariant;
  4694.   end;
  4695.  
  4696. function TIfPasScript.calc(WithList: TIfList; Vars: PVariableManager; res: PIfVariant; StopOn: TIfPasToken; OnlyConst: Boolean): Boolean;
  4697. { Calculate an expression }
  4698. var
  4699.   Items: TIfList;
  4700.   PreCalc: string;
  4701.   temp4: PIfVariant;
  4702.   Work: PSmallCalculation;
  4703.  
  4704.   function ChrToStr(s: string): Char;
  4705.     {Turn a char intto a string}
  4706.   begin
  4707.     Delete(s, 1, 1); {First char : #}
  4708.     ChrToStr := Chr(StrToInt(s));
  4709.   end;
  4710.  
  4711.   function PString(s: string): string;
  4712.     { remove the ' from the strings}
  4713.   begin
  4714.     s := copy(s, 2, Length(s) - 2);
  4715.     PString := s;
  4716.   end;
  4717.  
  4718.   function DoPrecalc: Boolean;
  4719.     {Pre calculate (- not +)}
  4720.   begin
  4721.     DoPrecalc := True;
  4722.     while Length(PreCalc) > 0 do begin
  4723.       if PreCalc[1] = '-' then begin
  4724.         if not DoMinus(Work^.CajVariant) then begin
  4725.           RunError(Self, ETypeMismatch);
  4726.           exit;
  4727.         end;
  4728.       end else if PreCalc[1] = '|' then begin
  4729.         if not DoNot(Work^.CajVariant) then begin
  4730.           RunError(Self, ETypeMismatch);
  4731.           exit;
  4732.         end;
  4733.       end else if PreCalc[1] = '+' then begin
  4734.         {plus has no effect}
  4735.       end else begin
  4736.         DoPrecalc := False;
  4737.         exit;
  4738.       end;
  4739.       Delete(PreCalc, 1, 1);
  4740.     end;
  4741.   end;
  4742.  
  4743.   procedure DisposeList;
  4744.     { Dispose the items }
  4745.   var
  4746.     I: Integer;
  4747.     p: PSmallCalculation;
  4748.   begin
  4749.     for I := 0 to Longint(Items.Count) - 1 do begin
  4750.       p := Items.GetItem(I);
  4751.       if p^.TType = 0 then
  4752.         DestroyCajVariant(p^.CajVariant);
  4753.       Dispose(p);
  4754.     end;
  4755.     Items.Destroy;
  4756.   end;
  4757.  
  4758.   function ParseString: string;
  4759.     { Parse a string }
  4760.   var
  4761.     temp3: string;
  4762.   begin
  4763.     temp3 := '';
  4764.     while (Parser.CurrTokenId = CSTI_String) or
  4765.       (Parser.CurrTokenId = CSTI_Char) do begin
  4766.       if Parser.CurrTokenId = CSTI_String
  4767.         then begin
  4768.         temp3 := temp3 + PString(Parser.GetToken);
  4769.         Parser.Next;
  4770.         if Parser.CurrTokenId = CSTI_String then
  4771.           temp3 := temp3 + #39;
  4772.       end {if}
  4773.       else begin
  4774.         temp3 := temp3 + ChrToStr(Parser.GetToken);
  4775.         Parser.Next;
  4776.       end; {else if}
  4777.     end; {while}
  4778.     ParseString := temp3;
  4779.   end;
  4780.  
  4781.   procedure Calculate;
  4782.     { Calculate the full expression }
  4783.   var
  4784.     l: PSmallCalculation;
  4785.     I: Longint;
  4786.   begin
  4787.     I := 0;
  4788.     while I < Longint(Items.Count - 1) div 2 do begin
  4789.       l := PSmallCalculation(Items.GetItem(I * 2 + 1));
  4790.       if ((l^.TType >= 2) and (l^.TType <= 8)) or (l^.TType = 19) then begin
  4791.         case l^.TType of
  4792. {$IFNDEF NOCLASSES}
  4793.           19: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4794.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4795.               ^.CajVariant, ptAs)
  4796.             then
  4797.               exit;
  4798. {$ENDIF}
  4799.           2: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4800.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4801.               ^.CajVariant, PtMul)
  4802.             then
  4803.               exit;
  4804.           3: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4805.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4806.               ^.CajVariant, ptDiv)
  4807.             then
  4808.               exit;
  4809.           4: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4810.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4811.               ^.CajVariant, PtIntDiv)
  4812.             then
  4813.               exit;
  4814.           5: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4815.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4816.               ^.CajVariant, PtIntMod)
  4817.             then
  4818.               exit;
  4819.           6: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4820.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4821.               ^.CajVariant, PtAnd)
  4822.             then
  4823.               exit;
  4824.           7: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4825.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4826.               ^.CajVariant, PtShr)
  4827.             then
  4828.               exit;
  4829.           8: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4830.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4831.               ^.CajVariant, PtShl)
  4832.             then
  4833.               exit;
  4834.         end;
  4835.         if ErrorCode <> 0 then
  4836.           exit;
  4837.         l := PSmallCalculation(Items.GetItem(I * 2 + 2));
  4838.         DestroyCajVariant(l^.CajVariant);
  4839.         Items.Remove(l);
  4840.         Dispose(l);
  4841.         l := PSmallCalculation(Items.GetItem(I * 2 + 1));
  4842.         Items.Remove(l);
  4843.         Dispose(l);
  4844.       end else Inc(I);
  4845.     end;
  4846.  
  4847.     I := 0;
  4848.     while I < Longint(Items.Count - 1) div 2 do begin
  4849.       l := PSmallCalculation(Items
  4850.         .GetItem(I * 2 + 1));
  4851.       if (l^.TType >= 9) and (l^.TType <= 12) then begin
  4852.         case l^.TType of
  4853.           9: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4854.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4855.               ^.CajVariant, PtPlus)
  4856.             then
  4857.               exit;
  4858.           10: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4859.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4860.               ^.CajVariant, ptMinus)
  4861.             then
  4862.               exit;
  4863.           11: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4864.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4865.               ^.CajVariant, ptOr)
  4866.             then
  4867.               exit;
  4868.           12: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4869.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4870.               ^.CajVariant, ptXor)
  4871.             then
  4872.               exit;
  4873.         end;
  4874.         if ErrorCode <> 0 then
  4875.           exit;
  4876.         l := PSmallCalculation(Items.GetItem(I * 2 + 2));
  4877.         DestroyCajVariant(l^.CajVariant);
  4878.         Items.Remove(l);
  4879.         Dispose(l);
  4880.         l := PSmallCalculation(Items
  4881.           .GetItem(I * 2 + 1));
  4882.         Items.Remove(l);
  4883.         Dispose(l);
  4884.       end else Inc(I);
  4885.     end;
  4886.     I := 0;
  4887.     while I < Longint(Items.Count - 1) div 2 do begin
  4888.       l := PSmallCalculation(Items.GetItem(I * 2 + 1));
  4889.       if ((l^.TType >= 13) and (l^.TType <= 18)) or (l^.TType = 20) then begin
  4890.         case l^.TType of
  4891.           13: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4892.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4893.               ^.CajVariant, PtEqual)
  4894.             then
  4895.               exit;
  4896.           14: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4897.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4898.               ^.CajVariant, PtGreater)
  4899.             then
  4900.               exit;
  4901.           15: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4902.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4903.               ^.CajVariant, PtLess)
  4904.             then
  4905.               exit;
  4906.           16: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4907.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4908.               ^.CajVariant, PtNotEqual)
  4909.             then
  4910.               exit;
  4911.           17: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4912.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4913.               ^.CajVariant, PtLessEqual)
  4914.             then
  4915.               exit;
  4916.           18: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4917.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4918.               ^.CajVariant, PtGreaterEqual)
  4919.             then
  4920.               exit;
  4921. {$IFNDEF NOCLASSES}
  4922.           20: if not Perform(PSmallCalculation(Items.GetItem(I * 2))^.
  4923.               CajVariant, PSmallCalculation(Items.GetItem(I * 2 + 2))
  4924.               ^.CajVariant, ptIs)
  4925.             then
  4926.               exit;
  4927. {$ENDIF}
  4928.         end;
  4929.         if ErrorCode <> 0 then
  4930.           exit;
  4931.         l := PSmallCalculation(Items.GetItem(I * 2 + 2));
  4932.         DestroyCajVariant(l^.CajVariant);
  4933.         Items.Remove(l);
  4934.         Dispose(l);
  4935.         l := PSmallCalculation(Items.GetItem(I * 2 + 1));
  4936.         Items.Remove(l);
  4937.         Dispose(l);
  4938.       end else Inc(I);
  4939.     end;
  4940.   end; {Calculate}
  4941.  
  4942. begin
  4943.   Items := TIfList.Create;
  4944.   calc := False;
  4945.   res := GetVarLink(res);
  4946.   while True do begin
  4947.     if Parser.CurrTokenId = StopOn then
  4948.       break;
  4949.     case Parser.CurrTokenId of
  4950.       CSTII_Else,
  4951.         CSTII_To,
  4952.         CSTII_DownTo,
  4953.         CSTII_do,
  4954.         CSTII_until,
  4955.         CSTI_Semicolon,
  4956.         CSTII_End,
  4957.         CSTI_Comma,
  4958.         CSTI_CloseRound: begin
  4959.           break;
  4960.         end; {Csti_Else...}
  4961.       CSTI_EOF: begin
  4962.           RunError(Self, EUnexpectedEndOfFile);
  4963.           DisposeList;
  4964.           exit;
  4965.         end; {CSTI_Eof}
  4966.     end; {case}
  4967.     if (Items.Count and $1) = 0 then begin
  4968.       PreCalc := '';
  4969.       while (Parser.CurrTokenId = CSTI_Minus) or
  4970.         (Parser.CurrTokenId = CSTII_Not) or
  4971.         (Parser.CurrTokenId = CSTI_Plus)
  4972.         do begin
  4973.         if (Parser.CurrTokenId = CSTI_Minus) then
  4974.           PreCalc := PreCalc + '-';
  4975.         if (Parser.CurrTokenId = CSTII_Not) then
  4976.           PreCalc := PreCalc + '|';
  4977.         if (Parser.CurrTokenId = CSTI_Plus) then
  4978.           PreCalc := PreCalc + '+';
  4979.         Parser.Next;
  4980.       end; {While}
  4981.  
  4982.       New(Work);
  4983.       case Parser.CurrTokenId of
  4984.         CSTI_AddressOf: begin
  4985.             Parser.Next;
  4986.             case GetIdentifier(WithList, Vars, 2, temp4) of
  4987.               0: begin
  4988.                   Dispose(Work);
  4989.                   DisposeList;
  4990.                   exit;
  4991.                 end;
  4992.               1: begin
  4993.                   RunError(Self, ETypeMismatch);
  4994.                   Dispose(Work);
  4995.                   DisposeList;
  4996.                   exit;
  4997.                 end;
  4998.               2: begin
  4999.                   if temp4^.VType^.atypeid <> CSV_ProcVariable then begin
  5000.                     RunError(Self, ETypeMismatch);
  5001.                     DestroyCajVariant(temp4);
  5002.                     Dispose(Work);
  5003.                     DisposeList;
  5004.                     exit;
  5005.                   end;
  5006.                 end;
  5007.             end;
  5008.             Work^.CajVariant := temp4;
  5009.             Work^.TType := 0;
  5010.             Items.Add(Work);
  5011.           end;
  5012.         CSTI_OpenBlock: begin
  5013.             Parser.Next;
  5014.             if res^.VType^.atypeid = CSV_Array then begin
  5015.               Work^.CajVariant := CreateCajVariant(res^.VType);
  5016.               while True do begin
  5017.                 temp4 := CreateCajVariant(res^.VType^.Ext);
  5018.                 if not calc(WithList, Vars, temp4, CSTI_CloseBlock, False) then begin
  5019.                   DestroyCajVariant(temp4);
  5020.                   DestroyCajVariant(Work^.CajVariant);
  5021.                   Dispose(Work);
  5022.                   DisposeList;
  5023.                   exit;
  5024.                 end;
  5025.                 Work^.CajVariant^.CV_ArrItems.Add(temp4);
  5026.                 if Parser.CurrTokenId = CSTI_CloseBlock then
  5027.                   break;
  5028.                 if (Parser.CurrTokenId <> CSTI_Comma) then begin
  5029.                   RunError(Self, ECloseBlockExpected);
  5030.                   DestroyCajVariant(Work^.CajVariant);
  5031.                   Dispose(Work);
  5032.                   DisposeList;
  5033.                   exit;
  5034.                 end;
  5035.                 Parser.Next;
  5036.               end;
  5037.               Parser.Next;
  5038.               Work^.TType := 0;
  5039.               Items.Add(Work);
  5040.             end else begin
  5041.               RunError(Self, ETypeMismatch);
  5042.               Dispose(Work);
  5043.               DisposeList;
  5044.               exit;
  5045.             end;
  5046.           end;
  5047.         CSTI_OpenRound: begin
  5048.             Parser.Next;
  5049.             Work^.CajVariant := CreateCajVariant(TM_Add(Types, '', CSV_Var, nil));
  5050.             Work^.CajVariant^.CV_Var := nil;
  5051.             Work^.TType := 0;
  5052.             if not calc(WithList, Vars, Work^.CajVariant, CSTI_CloseRound, OnlyConst) then begin
  5053.               DestroyCajVariant(Work^.CajVariant);
  5054.               Dispose(Work);
  5055.               DisposeList;
  5056.               exit;
  5057.             end; {if}
  5058.             if not DoPrecalc then begin
  5059.               DestroyCajVariant(Work^.CajVariant);
  5060.               Dispose(Work);
  5061.               DisposeList;
  5062.               exit;
  5063.             end; {if}
  5064.             Parser.Next;
  5065.             Items.Add(Work);
  5066.           end; {CSTI_OpenRound}
  5067.         CSTII_Inherited,
  5068.           CSTI_Identifier: begin
  5069.             case GetIdentifier(WithList, Vars, 0, temp4) of
  5070.               0: begin
  5071.                   Dispose(Work);
  5072.                   DisposeList;
  5073.                   exit;
  5074.                 end;
  5075.               1: Work^.CajVariant := CopyVariant(temp4);
  5076.               2: Work^.CajVariant := temp4;
  5077.             end;
  5078.             if Work^.CajVariant = nil then begin
  5079.               RunError(Self, ETypeMismatch);
  5080.               Dispose(Work);
  5081.               DisposeList;
  5082.               exit;
  5083.             end;
  5084. {$IFNDEF NOCLASSES}
  5085.             if Work^.CajVariant^.VType^.atypeid = CSV_Property then begin
  5086.               temp4 := GetProperty(Work^.CajVariant);
  5087.               DestroyCajVariant(Work^.CajVariant);
  5088.               if temp4 = nil then begin
  5089.                 Dispose(Work);
  5090.                 DisposeList;
  5091.                 exit;
  5092.               end;
  5093.               Work^.CajVariant := temp4;
  5094.             end;
  5095.             if (Work^.CajVariant^.VType^.atypeid = CSV_ExternalObjectProperty) then begin
  5096.               temp4 := Work.CajVariant;
  5097.               if (not assigned(temp4^.CV_ExtObj)) or (PCreatedCustomObject(temp4^.CV_ExtObj)^.AlreadyFreed) then begin
  5098.                 RunError(Self, EClassNotCreated);
  5099.                 DestroyCajVariant(temp4);
  5100.                 Dispose(Work);
  5101.                 DisposeList;
  5102.                 exit;
  5103.               end;
  5104.               Work^.CajVariant := CreateCajVariant(PCreatedCustomObject(temp4^.CV_ExtObj).p.GetPropertyType(temp4^.CV_PropertyNo));
  5105.               if not PCreatedCustomObject(temp4^.CV_ExtObj).p.GetProperty(temp4^.CV_PropertyNo, Work^.CajVariant) then begin
  5106.                 RunError(Self, ECanNotReadProperty);
  5107.                 DestroyCajVariant(Work^.CajVariant);
  5108.                 DestroyCajVariant(temp4);
  5109.                 Dispose(Work);
  5110.                 DisposeList;
  5111.                 exit;
  5112.               end;
  5113.               DestroyCajVariant(temp4);
  5114.               if Work^.CajVariant = nil then begin
  5115.                 RunError(Self, ETypeMismatch);
  5116.                 DestroyCajVariant(Work^.CajVariant);
  5117.                 Dispose(Work);
  5118.                 DisposeList;
  5119.                 exit;
  5120.               end;
  5121.             end;
  5122. {$ENDIF}
  5123.             Work^.TType := 0;
  5124.             if not DoPrecalc then begin
  5125.               DestroyCajVariant(Work^.CajVariant);
  5126.               Dispose(Work);
  5127.               DisposeList;
  5128.               exit;
  5129.             end; {if}
  5130.             Items.Add(Work);
  5131.           end; {CSTI_Identifier, CSTII_Inherited}
  5132.         CSTI_Integer: begin
  5133.             if ((res^.VType^.atypeid >= CSV_SByte) and (res^.VType^.atypeid <= CSV_SInt32)) { or
  5134.               ((res^.VType^.atypeid >= CSV_Real) and (res^.VType^.atypeid <= CSV_Comp)) }then
  5135.               Work^.CajVariant := CreateCajVariant(res^.VType)
  5136.             else
  5137.               Work^.CajVariant := CreateCajVariant(TM_Add(Types, '', CSV_SInt32, nil));
  5138.             Work^.TType := 0;
  5139.             if IsRealType(Work^.CajVariant) then
  5140.               SetReal(Work^.CajVariant, StrToInt(Parser.GetToken))
  5141.             else
  5142.               SetInteger(Work^.CajVariant, StrToInt(Parser.GetToken));
  5143.             if not DoPrecalc then begin
  5144.               DestroyCajVariant(Work^.CajVariant);
  5145.               Dispose(Work);
  5146.               DisposeList;
  5147.               exit;
  5148.             end; {if}
  5149.             Parser.Next;
  5150.             Items.Add(Work);
  5151.           end; {CSTI_Integer}
  5152.         CSTI_Real: begin
  5153.             if (res^.VType^.atypeid >= CSV_Real) and (res^.VType^.atypeid <= CSV_Comp) then
  5154.               Work^.CajVariant := CreateCajVariant(res^.VType)
  5155.             else
  5156.               Work^.CajVariant := CreateCajVariant(TM_Add(Types, '', CSV_Extended, nil));
  5157.             Work^.TType := 0;
  5158.             SetReal(Work^.CajVariant, StrToReal(Parser.GetToken));
  5159.             if not DoPrecalc then begin
  5160.               DestroyCajVariant(Work^.CajVariant);
  5161.               Dispose(Work);
  5162.               DisposeList;
  5163.               exit;
  5164.             end;
  5165.             Parser.Next;
  5166.             Items.Add(Work);
  5167.           end; {CSTI_Real}
  5168.         CSTI_String, CSTI_Char: begin
  5169.  
  5170.             Work^.CajVariant := CreateCajVariant(TM_Add(Types, '', CSV_String, nil));
  5171.             Work^.TType := 0;
  5172.             Work^.CajVariant^.Cv_Str := ParseString;
  5173.             if not DoPrecalc then begin
  5174.               DestroyCajVariant(Work^.CajVariant);
  5175.               Dispose(Work);
  5176.               DisposeList;
  5177.               exit;
  5178.             end; {if}
  5179.             Items.Add(Work);
  5180.           end; {CSTI_String}
  5181.         CSTI_HexInt: begin
  5182.             Work^.TType := 0;
  5183.             if (res^.VType^.atypeid >= CSV_SByte) and (res^.VType^.atypeid <= CSV_SInt32) then
  5184.               Work^.CajVariant := CreateCajVariant(res^.VType)
  5185.             else
  5186.               Work^.CajVariant := CreateCajVariant(TM_Add(Types, '', CSV_SInt32, nil));
  5187.             SetInteger(Work^.CajVariant, StrToInt(Parser.GetToken));
  5188.             if not DoPrecalc then begin
  5189.               DestroyCajVariant(Work^.CajVariant);
  5190.               Dispose(Work);
  5191.               DisposeList;
  5192.               exit;
  5193.             end; {if}
  5194.             Parser.Next;
  5195.             Items.Add(Work);
  5196.           end; {CSTI_HexInt}
  5197.       else begin
  5198.           RunError(Self, EErrorInExpression);
  5199.           Dispose(Work);
  5200.           DisposeList;
  5201.           exit;
  5202.         end;
  5203.       end; {case}
  5204.     end {if}
  5205.     else begin
  5206.       New(Work);
  5207.       case Parser.CurrTokenId of
  5208.         CSTI_Equal: Work^.TType := 13;
  5209.         CSTI_NotEqual: Work^.TType := 16;
  5210.         CSTI_Greater: Work^.TType := 14;
  5211.         CSTI_GreaterEqual: Work^.TType := 18;
  5212.         CSTI_Less: Work^.TType := 15;
  5213.         CSTI_LessEqual: Work^.TType := 17;
  5214.         CSTI_Plus: Work^.TType := 9;
  5215.         CSTI_Minus: Work^.TType := 10;
  5216.         CSTI_Divide: begin
  5217.             Work^.TType := 3;
  5218.             if res^.VType^.atypeid = CSV_Var then
  5219.               ChangeType(res, TM_Add(Types, '', CSV_Extended, nil));
  5220.           end;
  5221.         CSTI_Multiply: Work^.TType := 2;
  5222.         CSTII_and: Work^.TType := 6;
  5223.         CSTII_div: Work^.TType := 4;
  5224.         CSTII_mod: Work^.TType := 5;
  5225.         CSTII_or: Work^.TType := 11;
  5226.         CSTII_shl: Work^.TType := 8;
  5227.         CSTII_shr: Work^.TType := 7;
  5228.         CSTII_xor: Work^.TType := 12;
  5229. {$IFNDEF NOCLASSES}
  5230.         CSTII_As: Work^.TType := 19;
  5231.         CSTII_Is: Work^.TType := 20;
  5232. {$ENDIF}
  5233.       else begin
  5234.           RunError(Self, EErrorInExpression);
  5235.           Dispose(Work);
  5236.           DisposeList;
  5237.           exit;
  5238.         end; {else case}
  5239.       end; {case}
  5240.       Items.Add(Work);
  5241.       Parser.Next;
  5242.     end; {else if}
  5243.   end; {while}
  5244.   Calculate;
  5245.   if ErrorCode = 0 then begin
  5246.     if Longint(Items.Count) <> 1 then begin
  5247.       RunError(Self, EErrorInExpression);
  5248.       calc := False;
  5249.     end else begin
  5250.       Work := Items.GetItem(0);
  5251.       if Perform(res, Work^.CajVariant, PtSet) then
  5252.         calc := True
  5253.       else
  5254.         calc := False;
  5255.     end; {if}
  5256.   end; {if}
  5257.   DisposeList;
  5258. end; {Calc}
  5259.  
  5260. function TIfPasScript.MakeCompat(v: PIfVariant; FType: PTypeRec): Boolean;
  5261. var
  5262.   n: PIfVariant;
  5263. begin
  5264.   if v^.VType = FType then
  5265.     MakeCompat := True
  5266.   else if (v^.VType^.atypeid = CSV_Array) and (FType^.atypeid = CSV_Array) and (FType^.Ext = nil) then
  5267.     MakeCompat := True
  5268.   else begin
  5269.     n := CreateCajVariant(v^.VType);
  5270.     if not Perform(n, v, PtSet) then begin
  5271.       MakeCompat := False;
  5272.       DestroyCajVariant(n);
  5273.       exit;
  5274.     end;
  5275.     ChangeType(v, FType);
  5276.     if not Perform(v, n, PtSet) then begin
  5277.       MakeCompat := False;
  5278.       DestroyCajVariant(n);
  5279.       exit;
  5280.     end;
  5281.     DestroyCajVariant(n);
  5282.     MakeCompat := True;
  5283.   end;
  5284. end;
  5285. {$IFNDEF NOCLASSES}
  5286.  
  5287. function TIfPasScript.RunInherited(proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
  5288. var
  5289.   u: PIfVariant;
  5290.   p: PVariableManager;
  5291.   I: Integer;
  5292. begin
  5293.   proc := GetInheritedProc(proc);
  5294.   p := VM_Create;
  5295.   for I := 0 to IntProcDefParam(proc^.Decl, -1) do begin
  5296.     Vm_Add(p, CopyVariant(Vm_Get(Params, 0)), '');
  5297.   end;
  5298.   VM_SetName(p, 0, 'SELF');
  5299.   u := RunScriptProc(proc, p);
  5300.   VM_Destroy(p);
  5301.   if FError.ErrorCode <> 0 then begin
  5302.     RunInherited := FError.ErrorCode;
  5303.   end else begin
  5304.     if assigned(u) then begin
  5305.       Perform(res, u, PtSet);
  5306.       DestroyCajVariant(u);
  5307.     end;
  5308.     RunInherited := 0;
  5309.   end;
  5310. end;
  5311. {$ENDIF}
  5312.  
  5313. function TIfPasScript.RunScriptProc(Func: PProcedure; Parameters: PVariableManager): PIfVariant;
  5314. {Call an internal/external Procedure}
  5315. var
  5316.   OldVars: PVariableManager;
  5317.   w: PIfVariant;
  5318.   I: Longint;
  5319.   WithList: TIfList;
  5320. {$IFNDEF NOCLASSES}SaveSelf: PIfVariant;
  5321. {$ENDIF}
  5322.  
  5323.   function IRem(s: string): string;
  5324.   {Remove the !}
  5325.   begin
  5326.     Delete(s, 1, 1);
  5327.     IRem := s;
  5328.   end; {irem}
  5329.  
  5330.  
  5331.  
  5332.   {$IFNDEF NOCLASSES}procedure AddSelf;
  5333.   var
  5334.     u: PIfVariant;
  5335.   begin
  5336.     SaveSelf := Vm_Get(Parameters, 0);
  5337.     if GetVarLink(SaveSelf)^.VType <> Func^.ClassType then begin
  5338.       u := CreateCajVariant(Func^.ClassType);
  5339.       u^.CV_Class := GetVarLink(SaveSelf)^.CV_Class;
  5340.       VM_Set(Parameters, 0, u);
  5341.     end;
  5342.   end;
  5343.  
  5344.   procedure RestoreSelf;
  5345.   begin
  5346.     if (SaveSelf <> Vm_Get(Parameters, 0)) and (Func^.ClassType <> nil) then begin
  5347.       DestroyCajVariant(Vm_Get(Parameters, 0));
  5348.       VM_Set(Parameters, 0, SaveSelf);
  5349.     end;
  5350.   end;
  5351. {$ENDIF}
  5352. begin
  5353.   RunScriptProc := nil;
  5354.   RunError(Self, ENoError); //reset
  5355.   if not assigned(Func) then begin
  5356.     FError.ErrorCode := EUnknownIdentifier;
  5357.     FError.ErrorPosition := -1;
  5358.     exit;
  5359.   end;
  5360.   if Func^.FScriptEngine <> Self then begin
  5361.     RunScriptProc := TIfPasScript(Func^.FScriptEngine).RunScriptProc(Func, Parameters);
  5362.     if TIfPasScript(Func^.FScriptEngine).ErrorCode <> 0 then begin
  5363.       RunError2(Func^.FScriptEngine, TIfPasScript(Func^.FScriptEngine).ErrorCode, TIfPasScript(Func^.FScriptEngine).ErrorString);
  5364.     end;
  5365.     exit;
  5366.   end;
  5367. {$IFNDEF NOCLASSES}
  5368.   if assigned(Func^.ClassType) then begin
  5369.     if (VM_Count(Parameters) = 0) or (VM_GetName(Parameters, 0) <> 'SELF') then begin
  5370.       FError.ErrorCode := EParameterError;
  5371.       FError.ErrorPosition := -1;
  5372.       exit;
  5373.     end;
  5374.     AddSelf;
  5375.     if IntProcDefParam(Func^.Decl, -1) <> VM_Count(Parameters) - 1 then begin
  5376.       FError.ErrorPosition := -1; { -1 means that the count is not the same }
  5377.       FError.ErrorCode := EParameterError;
  5378.       exit;
  5379.     end;
  5380.   end else {$ENDIF}begin
  5381.     if IntProcDefParam(Func^.Decl, -1) <> VM_Count(Parameters) then begin
  5382.       FError.ErrorPosition := -1; { -1 means that the count is not the same }
  5383.       FError.ErrorCode := EParameterError;
  5384.       exit;
  5385.     end;
  5386.   end;
  5387.   for I := 1 to IntProcDefParam(Func^.Decl, -1) do begin
  5388. {$IFNDEF NOCLASSES}
  5389.     if assigned(Func^.ClassType) then
  5390.       w := Vm_Get(Parameters, I)
  5391.     else
  5392. {$ENDIF}
  5393.       w := Vm_Get(Parameters, I - 1);
  5394.     if Pos('!', IntProcDefName(Func^.Decl, I)) = 1 then begin
  5395.       if (w^.VType^.atypeid <> CSV_Var) or (not assigned(w^.CV_Var)) then begin
  5396.         FError.ErrorPosition := I - 1;
  5397.         FError.ErrorCode := EParameterError;
  5398. {$IFNDEF NOCLASSES}RestoreSelf;
  5399. {$ENDIF}
  5400.         exit;
  5401.       end;
  5402.       if (PIfVariant(w^.CV_Var)^.VType <> Pointer(IntProcDefParam(Func^.Decl, I))) and not ((PTypeRec(IntProcDefParam(Func^.Decl, I))^.Ext = nil) and (PTypeRec(IntProcDefParam(Func^.Decl, I))^.atypeid = CSV_Array)) and not (PTypeRec(IntProcDefParam(Func^.Decl, I))^.atypeid = CSV_Var) then begin
  5403.         FError.ErrorPosition := I - 1;
  5404.         FError.ErrorCode := EParameterError;
  5405. {$IFNDEF NOCLASSES}RestoreSelf;
  5406. {$ENDIF}
  5407.         exit;
  5408.       end;
  5409. {$IFNDEF NOCLASSES}
  5410.       if assigned(Func^.ClassType) then
  5411.         VM_SetName(Parameters, I, copy(IntProcDefName(Func^.Decl, I), 2, Length(IntProcDefName(Func^.Decl, I))))
  5412.       else
  5413. {$ENDIF}
  5414.         VM_SetName(Parameters, I - 1, copy(IntProcDefName(Func^.Decl, I), 2, Length(IntProcDefName(Func^.Decl, I))));
  5415.     end else
  5416.       if Pos('^', IntProcDefName(Func^.Decl, I)) = 1 then begin
  5417.         if (w^.VType^.atypeid <> CSV_Var) or (not assigned(w^.CV_Var)) then begin
  5418.           FError.ErrorPosition := I - 1;
  5419.           FError.ErrorCode := EParameterError;
  5420. {$IFNDEF NOCLASSES}RestoreSelf;
  5421. {$ENDIF}
  5422.           exit;
  5423.         end;
  5424.         if (PIfVariant(w^.CV_Var)^.VType <> Pointer(IntProcDefParam(Func^.Decl, I))) and not ((PTypeRec(IntProcDefParam(Func^.Decl, I))^.Ext = nil) and (PTypeRec(IntProcDefParam(Func^.Decl, I))^.atypeid = CSV_Array))
  5425.         and not (PTypeRec(IntProcDefParam(Func^.Decl, I))^.atypeid = CSV_Var) then begin
  5426.           FError.ErrorPosition := I - 1;
  5427.           FError.ErrorCode := EParameterError;
  5428. {$IFNDEF NOCLASSES}RestoreSelf;
  5429. {$ENDIF}
  5430.           exit;
  5431.         end;
  5432. {$IFNDEF NOCLASSES}
  5433.         if assigned(Func^.ClassType) then
  5434.           VM_SetName(Parameters, I, copy(IntProcDefName(Func^.Decl, I), 2, Length(IntProcDefName(Func^.Decl, I))))
  5435.         else
  5436. {$ENDIF}
  5437.           VM_SetName(Parameters, I - 1, copy(IntProcDefName(Func^.Decl, I), 2, Length(IntProcDefName(Func^.Decl, I))));
  5438.         w^.Flags := w^.Flags or 1;
  5439.       end else begin
  5440.         if not MakeCompat(w, Pointer(IntProcDefParam(Func^.Decl, I))) then begin
  5441.           FError.ErrorPosition := I - 1;
  5442.           FError.ErrorCode := EParameterError;
  5443. {$IFNDEF NOCLASSES}RestoreSelf;
  5444. {$ENDIF}
  5445.           exit;
  5446.         end;
  5447. {$IFNDEF NOCLASSES}
  5448.         if assigned(Func^.ClassType) then
  5449.           VM_SetName(Parameters, I, IntProcDefName(Func^.Decl, I))
  5450.         else
  5451. {$ENDIF}
  5452.           VM_SetName(Parameters, I - 1, IntProcDefName(Func^.Decl, I));
  5453.       end;
  5454.   end; {for}
  5455.   ProcStack.Add(Func);
  5456.   OldVars := CurrVars;
  5457.   CurrVars := Parameters;
  5458.   if Func^.Mode = 0 then begin
  5459.     if IntProcDefParam(Func^.Decl, 0) <> 0 then begin
  5460.       w := CreateCajVariant(Pointer(IntProcDefParam(Func^.Decl, 0)));
  5461.       Vm_Add(Parameters, w, 'RESULT');
  5462.     end {if}
  5463.     else w := nil;
  5464.     I := Parser.CurrTokenPos;
  5465.     Parser.CurrTokenPos := Func^.offset;
  5466.     if Parser.CurrTokenId = CSTII_Var then begin
  5467.       if not ProcessVars(Parameters) then begin
  5468.         DestroyCajVariant(w);
  5469.         if IntProcDefParam(Func^.Decl, 0) <> 0 then begin
  5470.           VM_Delete(Parameters, VM_Find(Parameters, 'RESULT'));
  5471.         end; {if}
  5472. {$IFNDEF NOCLASSES}RestoreSelf;
  5473. {$ENDIF}
  5474.         PopProcStack;
  5475.         CurrVars := OldVars;
  5476.         exit;
  5477.       end; {if}
  5478.     end; {if}
  5479.     WithList := TIfList.Create;
  5480. {$IFNDEF NOCLASSES}
  5481.     if assigned(Func^.ClassType) then begin
  5482.       WithList.Add(CreateVarType(Vm_Get(Parameters, 0)));
  5483.     end;
  5484. {$ENDIF}
  5485.     if not RunBegin(WithList, Parameters, False) then begin
  5486.       if FError.ErrorCode = EExitCommand then
  5487.         FError.ErrorCode := 0
  5488.       else begin
  5489.         if IntProcDefParam(Func^.Decl, 0) <> 0 then begin
  5490.           VM_Delete(Parameters, VM_Find(Parameters, 'RESULT'));
  5491.         end; {if}
  5492.         DestroyCajVariant(w);
  5493.         DestroyWithList(WithList);
  5494. {$IFNDEF NOCLASSES}RestoreSelf;
  5495. {$ENDIF}
  5496.         PopProcStack;
  5497.         CurrVars := OldVars;
  5498.  
  5499.         exit;
  5500.       end;
  5501.     end; {if}
  5502.     DestroyWithList(WithList);
  5503.     if IntProcDefParam(Func^.Decl, 0) <> 0 then begin
  5504.       VM_Delete(Parameters, VM_Find(Parameters, 'RESULT'));
  5505.     end; {if}
  5506.     Parser.CurrTokenPos := I;
  5507.     RunScriptProc := w;
  5508. {$IFNDEF NOCLASSES}RestoreSelf;
  5509. {$ENDIF}
  5510.     RunError(Self, ENoError);
  5511.     PopProcStack;
  5512.     CurrVars := OldVars;
  5513.     exit;
  5514.   end {if}
  5515.   else if Func^.Mode = 1 then begin
  5516.     if IntProcDefParam(Func^.Decl, 0) <> 0 then
  5517.       w := CreateCajVariant(Pointer(IntProcDefParam(Func^.Decl, 0)))
  5518.     else
  5519.       w := nil;
  5520. {$IFNDEF NOCLASSES}
  5521.     if assigned(Func^.ClassType) then
  5522.       RunError(Self, Func^.proc1(Func^.FScriptEngine, fId, Func, Parameters, w))
  5523.     else
  5524. {$ENDIF}
  5525.       RunError(Self, Func^.proc1(Func^.FScriptEngine, fId, Func, Parameters, w));
  5526.     if FError.ErrorCode = EExitCommand then
  5527.       FError.ErrorCode := 0
  5528.     else
  5529.       if FError.ErrorCode <> ENoError then begin
  5530.         DestroyCajVariant(w);
  5531. {$IFNDEF NOCLASSES}RestoreSelf;
  5532. {$ENDIF}
  5533.         PopProcStack;
  5534.         CurrVars := OldVars;
  5535.  
  5536.         exit;
  5537.       end; {if}
  5538.     RunScriptProc := w;
  5539.   end
  5540.   else begin
  5541.     if IntProcDefParam(Func^.Decl, 0) <> 0 then
  5542.       w := CreateCajVariant(Pointer(IntProcDefParam(Func^.Decl, 0)))
  5543.     else
  5544.       w := nil;
  5545. {$IFNDEF NOCLASSES}
  5546.     if assigned(Func^.ClassType) then
  5547.       RunError(Self, Func^.proc2(Func^.FScriptEngine, fId, Func, Parameters, w))
  5548.     else
  5549. {$ENDIF}
  5550.       RunError(Self, Func^.proc2(Func^.FScriptEngine, fId, Func, Parameters, w));
  5551.     if FError.ErrorCode = EExitCommand then
  5552.       FError.ErrorCode := 0
  5553.     else
  5554.       if FError.ErrorCode <> ENoError then begin
  5555.         DestroyCajVariant(w);
  5556. {$IFNDEF NOCLASSES}RestoreSelf;
  5557. {$ENDIF}
  5558.         PopProcStack;
  5559.         CurrVars := OldVars;
  5560.         exit;
  5561.       end; {if}
  5562.     RunScriptProc := w;
  5563.   end; {if}
  5564.   PopProcStack;
  5565.   CurrVars := OldVars;
  5566. {$IFNDEF NOCLASSES}RestoreSelf;
  5567. {$ENDIF}
  5568. end;
  5569. {$IFNDEF NOCLASSES}
  5570.  
  5571. function TIfPasScript.RunScriptConstructor(FType: PTypeRec; Func: PProcedure; Parameters: PVariableManager): PIfVariant;
  5572. {Call an internal/external constructor.
  5573. Note the first parameters must be a dummy one, something like:
  5574. VM_Add(Parameters, Nil, '');
  5575.  
  5576. And then the real parameters. This is because SELF must be the first
  5577. parameter but it is self-created.
  5578.  
  5579. }
  5580. var
  5581.   OldVars: PVariableManager;
  5582.   slf, w: PIfVariant;
  5583.   WithList: TIfList;
  5584.   I: Longint;
  5585.   CC: PCreatedClass;
  5586.  
  5587.   function IRem(s: string): string;
  5588.   {Remove the !}
  5589.   begin
  5590.     Delete(s, 1, 1);
  5591.     IRem := s;
  5592.   end; {irem}
  5593.  
  5594.   procedure CreateVars;
  5595.   var
  5596.     I, AA: Longint;
  5597.     C: PIFSClassType;
  5598.     s, Name: string;
  5599.     u: PTypeRec;
  5600.     n: PIfVariant;
  5601.     tmpv: PIFNamedVariable;
  5602.  
  5603.     function CreateProperty(p: PPropertyDef): PCajvariant;
  5604.     var
  5605.       prop: PCajvariant;
  5606.     begin
  5607.       prop := CreateCajVariant(TM_Add(Types, '', CSV_Property, p^.CV_Type));
  5608.       prop^.CV_Self := CC;
  5609.       prop^.CV_PropFlags := p^.CV_PropFlags;
  5610.       if (p^.CV_PropFlags and $5) = $1 then
  5611.         prop^.CV_PropRead := Vm_Get(CC^.Variables, Longint(p^.CV_PropRead))
  5612.       else
  5613.         prop^.CV_PropRead := p^.CV_PropRead;
  5614.       if (p^.CV_PropFlags and $A) = $2 then
  5615.         prop^.CV_PropWrite := Vm_Get(CC^.Variables, Longint(p^.CV_PropWrite))
  5616.       else
  5617.         prop^.CV_PropWrite := p^.CV_PropWrite;
  5618.       if (prop^.CV_PropFlags and $30) = $10 then
  5619.         prop^.Flags := prop^.Flags or 2
  5620.       else if (prop^.CV_PropFlags and $30) = $20 then
  5621.         prop^.Flags := prop^.Flags or 4
  5622.       else if (prop^.CV_PropFlags and $30) = $30 then
  5623.         prop^.Flags := prop^.Flags or 6;
  5624.       CreateProperty := prop;
  5625.     end;
  5626.   begin
  5627.     for I := 0 to (PIFSClassType(CC^.ClassType^.Ext)^.VarNoStart + PIFSClassType(CC^.ClassType^.Ext)^.VarCount) - 1 do begin
  5628.       PVariableManager(CC^.Variables).Add(nil);
  5629.     end;
  5630.     C := PIFSClassType(CC^.ClassType^.Ext);
  5631.     while assigned(C) do begin
  5632.       s := C^.Variables.u;
  5633.       I := C^.VarNoStart;
  5634.       while Length(s) > 0 do begin
  5635.         Name := Fw(s);
  5636.         Rfw(s);
  5637.         u := Pointer(StrToIntDef(Fw(s), 0));
  5638.         Rfw(s);
  5639.         n := CreateCajVariant(u);
  5640.         case Name[1] of
  5641.           '1': n^.Flags := $2;
  5642.           '2': n^.Flags := $4;
  5643.           '3': n^.Flags := $6;
  5644.         end;
  5645.         new(tmpv);
  5646.         tmpv^.FVar := n;
  5647.         Delete(Name, 1, 1);
  5648.         tmpv^.Name := Name;
  5649.         tmpv^.NameHash := mkhash(name);
  5650.         PVariableManager(CC^.Variables).SetItem(i, tmpv);
  5651.  
  5652.         Inc(I);
  5653.       end; {while}
  5654.       if assigned(C^.InheritsFrom) then
  5655.         C := (C^.InheritsFrom^.Ext)
  5656.       else
  5657.         C := nil;
  5658.     end; {while}
  5659.     AA := VM_Count(CC^.Variables);
  5660.     C := PIFSClassType(CC^.ClassType^.Ext);
  5661.     for I := 0 to (PIFSClassType(CC^.ClassType^.Ext)^.PropStart + PIFSClassType(CC^.ClassType^.Ext)^.Properties.Count) - 1 do begin
  5662.       PVariableManager(CC^.Variables).Add(nil);
  5663.     end;
  5664.     while assigned(C) do begin
  5665.       for I := 0 to Longint(C^.Properties.Count) - 1 do begin
  5666.         new(tmpv);
  5667.         tmpv^.Name := '';
  5668.         tmpv^.NameHash := 1;
  5669.         tmpv^.FVar := CreateProperty(C^.Properties.GetItem(I));
  5670.         PVariableManager(CC^.Variables).SetItem(AA + Longint(C^.PropStart) + I, tmpv);
  5671.       end;
  5672.       if assigned(C^.InheritsFrom) then
  5673.         C := (C^.InheritsFrom^.Ext)
  5674.       else
  5675.         C := nil;
  5676.     end;
  5677.   end;
  5678.  
  5679. begin
  5680.   if Func^.FScriptEngine <> Self then begin
  5681.     RunScriptConstructor := TIfPasScript(Func^.FScriptEngine).RunScriptConstructor
  5682.       (FType, Func, Parameters);
  5683.     if TIfPasScript(Func^.FScriptEngine).ErrorCode <> 0 then begin
  5684.       RunError2(Func^.FScriptEngine, TIfPasScript(Func^.FScriptEngine).ErrorCode, TIfPasScript(Func^.FScriptEngine).ErrorString);
  5685.     end;
  5686.  
  5687.     exit;
  5688.   end;
  5689.   RunError(Self, ENoError);
  5690.   if (Func^.Flags and $40) = 0 then begin
  5691.     FError.ErrorCode := EConstructorExpected;
  5692.     RunScriptConstructor := nil;
  5693.     FError.ErrorPosition := 0;
  5694.     exit;
  5695.   end;
  5696.   New(CC);
  5697.   CC^.Variables := VM_Create;
  5698.   CC^.ClassType := FType;
  5699.   CreateVars;
  5700.   CC^.AlreadyFreed := False;
  5701.   CreatedClasses.Add(CC);
  5702.   slf := CreateCajVariant(FType);
  5703.   slf^.CV_Class := CC;
  5704.   DestroyCajVariant(Vm_Get(Parameters, 0));
  5705.   VM_Set(Parameters, 0, CreateCajVariant(Func^.ClassType));
  5706.   with Vm_Get(Parameters, 0)^ do begin
  5707.     CV_Class := slf^.CV_Class;
  5708.     Flags := 1;
  5709.   end;
  5710.   VM_SetName(Parameters, 0, 'SELF');
  5711.   RunScriptConstructor := nil;
  5712.   if not assigned(Func) then begin
  5713.     FError.ErrorCode := EUnknownIdentifier;
  5714.     DestroyCajVariant(slf);
  5715.     FError.ErrorPosition := -1;
  5716.     exit;
  5717.   end;
  5718.   if IntProcDefParam(Func^.Decl, -1) <> VM_Count(Parameters) - 1 then begin
  5719.     FError.ErrorPosition := -1; { -1 means that the count is not the same }
  5720.     DestroyCajVariant(slf);
  5721.     FError.ErrorCode := EParameterError;
  5722.     exit;
  5723.   end;
  5724.   for I := 1 to IntProcDefParam(Func^.Decl, -1) do begin
  5725.     w := Vm_Get(Parameters, I);
  5726.     if Pos('!', IntProcDefName(Func^.Decl, I)) = 1 then begin
  5727.       if (w^.VType^.atypeid <> CSV_Var) or (not assigned(w^.CV_Var)) then begin
  5728.         FError.ErrorPosition := I - 1;
  5729.         FError.ErrorCode := EParameterError;
  5730.         DestroyCajVariant(slf);
  5731.         exit;
  5732.       end;
  5733.       if (PIfVariant(w^.CV_Var)^.VType <> Pointer(IntProcDefParam(Func^.Decl, I))) and not ((PTypeRec(IntProcDefParam(Func^.Decl, I))^.Ext = nil) and (PTypeRec(IntProcDefParam(Func^.Decl, I))^.atypeid = CSV_Array))
  5734.       and not (PTypeRec(IntProcDefParam(Func^.Decl, I))^.atypeid = CSV_Var) then begin
  5735.         FError.ErrorPosition := I - 1;
  5736.         FError.ErrorCode := EParameterError;
  5737.         DestroyCajVariant(slf);
  5738.         exit;
  5739.       end;
  5740.       VM_SetName(Parameters, I, copy(IntProcDefName(Func^.Decl, I), 2, Length(IntProcDefName(Func^.Decl, I))))
  5741.     end else if Pos('^', IntProcDefName(Func^.Decl, I)) = 1 then begin
  5742.       if (w^.VType^.atypeid <> CSV_Var) or (not assigned(w^.CV_Var)) then begin
  5743.         FError.ErrorPosition := I - 1;
  5744.         FError.ErrorCode := EParameterError;
  5745.         DestroyCajVariant(slf);
  5746.         exit;
  5747.       end;
  5748.       if (PIfVariant(w^.CV_Var)^.VType <> Pointer(IntProcDefParam(Func^.Decl, I))) and not ((PTypeRec(IntProcDefParam(Func^.Decl, I))^.Ext = nil) and (PTypeRec(IntProcDefParam(Func^.Decl, I))^.atypeid = CSV_Array))
  5749.         and not (PTypeRec(IntProcDefParam(Func^.Decl, I))^.atypeid = CSV_Var) then begin
  5750.         FError.ErrorPosition := I - 1;
  5751.         FError.ErrorCode := EParameterError;
  5752.         DestroyCajVariant(slf);
  5753.         exit;
  5754.       end;
  5755.       VM_SetName(Parameters, I, copy(IntProcDefName(Func^.Decl, I), 2, Length(IntProcDefName(Func^.Decl, I))));
  5756.       w^.Flags := w^.Flags or 1;
  5757.     end else begin
  5758.       if not MakeCompat(w, Pointer(IntProcDefParam(Func^.Decl, I))) then begin
  5759.         FError.ErrorPosition := I - 1;
  5760.         FError.ErrorCode := EParameterError;
  5761.         DestroyCajVariant(slf);
  5762.         exit;
  5763.       end;
  5764.       VM_SetName(Parameters, I, IntProcDefName(Func^.Decl, I))
  5765.     end;
  5766.   end; {for}
  5767.   ProcStack.Add(Func);
  5768.   OldVars := CurrVars;
  5769.   CurrVars := Parameters;
  5770.   if Func^.Mode = 0 then begin
  5771.     I := Parser.CurrTokenPos;
  5772.     Parser.CurrTokenPos := Func^.offset;
  5773.     if Parser.CurrTokenId = CSTII_Var then begin
  5774.       if not ProcessVars(Parameters) then begin
  5775.         DestroyCajVariant(slf);
  5776.         PopProcStack;
  5777.         CurrVars := OldVars;
  5778.         exit;
  5779.       end; {if}
  5780.     end; {if}
  5781.     WithList := TIfList.Create;
  5782.     WithList.Add(CreateVarType(slf));
  5783.     if not RunBegin(WithList, Parameters, False) then begin
  5784.       if FError.ErrorCode = EExitCommand then
  5785.         FError.ErrorCode := 0
  5786.       else begin
  5787.         DestroyCajVariant(slf);
  5788.         DestroyWithList(WithList);
  5789.         PopProcStack;
  5790.         CurrVars := OldVars;
  5791.         exit;
  5792.       end;
  5793.     end; {if}
  5794.     DestroyWithList(WithList);
  5795.     Parser.CurrTokenPos := I;
  5796.     RunScriptConstructor := slf;
  5797.     RunError(Self, 0);
  5798.     PopProcStack;
  5799.     CurrVars := OldVars;
  5800.     exit;
  5801.   end {if}
  5802.   else if Func^.Mode = 1 then begin
  5803.     w := nil;
  5804.     RunError(Self, Func.proc1(Func^.FScriptEngine, fId, Func, Parameters, w));
  5805.     if FError.ErrorCode = EExitCommand then
  5806.       FError.ErrorCode := 0
  5807.     else
  5808.       if ErrorCode <> ENoError then begin
  5809.         DestroyCajVariant(slf);
  5810.         PopProcStack;
  5811.         CurrVars := OldVars;
  5812.         exit;
  5813.       end; {if}
  5814.     RunScriptConstructor := slf;
  5815.   end {if}
  5816.   else begin
  5817.     w := nil;
  5818.     RunError(Self, Func.proc2(Func^.FScriptEngine, fId, Func, Parameters, w));
  5819.     if FError.ErrorCode = EExitCommand then
  5820.       FError.ErrorCode := 0
  5821.     else
  5822.       if ErrorCode <> ENoError then begin
  5823.         DestroyCajVariant(slf);
  5824.         PopProcStack;
  5825.         CurrVars := OldVars;
  5826.         exit;
  5827.       end; {if}
  5828.     RunScriptConstructor := slf;
  5829.   end; {if}
  5830.   PopProcStack;
  5831.   CurrVars := OldVars;
  5832. end;
  5833.  
  5834. function TIfPasScript.DoClassConstructor(WithList: TIfList; Myclass: PTypeRec; proc: PProcedure; Vars: PVariableManager): PIfVariant;
  5835. {Call an internal/external Procedure}
  5836. var
  5837.   OldVars: PVariableManager;
  5838.   slf: PIfVariant;
  5839.   I: Longint;
  5840.   Params: PVariableManager;
  5841.   CC: PCreatedClass;
  5842.  
  5843.   function IRem(s: string): string;
  5844.   {Remove the !}
  5845.   begin
  5846.     Delete(s, 1, 1);
  5847.     IRem := s;
  5848.   end; {irem}
  5849.  
  5850.   procedure CreateVars;
  5851.   var
  5852.     AA, I: Longint;
  5853.     C: PIFSClassType;
  5854.     s, Name: string;
  5855.     u: PTypeRec;
  5856.     n: PIfVariant;
  5857.     tmpv: PIFNamedVariable;
  5858.  
  5859.     function CreateProperty(p: PPropertyDef): PCajvariant;
  5860.     var
  5861.       prop: PCajvariant;
  5862.     begin
  5863.       prop := CreateCajVariant(TM_Add(Types, '', CSV_Property, p^.CV_Type));
  5864.       prop^.CV_Self := CC;
  5865.       prop^.CV_PropFlags := p^.CV_PropFlags;
  5866.       if (p^.CV_PropFlags and $5) = $1 then
  5867.         prop^.CV_PropRead := Vm_Get(CC^.Variables, Longint(p^.CV_PropRead))
  5868.       else
  5869.         prop^.CV_PropRead := p^.CV_PropRead;
  5870.       if (p^.CV_PropFlags and $A) = $2 then
  5871.         prop^.CV_PropWrite := Vm_Get(CC^.Variables, Longint(p^.CV_PropWrite))
  5872.       else
  5873.         prop^.CV_PropWrite := p^.CV_PropWrite;
  5874.       if (prop^.CV_PropFlags and $30) = $10 then
  5875.         prop^.Flags := prop^.Flags or 2
  5876.       else if (prop^.CV_PropFlags and $30) = $20 then
  5877.         prop^.Flags := prop^.Flags or 4
  5878.       else if (prop^.CV_PropFlags and $30) = $30 then
  5879.         prop^.Flags := prop^.Flags or 6;
  5880.       CreateProperty := prop;
  5881.     end;
  5882.   begin
  5883.     for I := 0 to Longint((PIFSClassType(CC^.ClassType^.Ext)^.VarNoStart + PIFSClassType(CC^.ClassType^.Ext)^.VarCount)) - 1 do begin
  5884.       PVariableManager(CC^.Variables).Add(nil);
  5885.     end;
  5886.     C := PIFSClassType(CC^.ClassType^.Ext);
  5887.     while assigned(C) do begin
  5888.       s := C^.Variables.u;
  5889.       I := C^.VarNoStart;
  5890.       while Length(s) > 0 do begin
  5891.         Name := Fw(s);
  5892.         Rfw(s);
  5893.         u := Pointer(StrToIntDef(Fw(s), 0));
  5894.         Rfw(s);
  5895.         n := CreateCajVariant(u);
  5896.         case Name[1] of
  5897.           '1': n^.Flags := $2;
  5898.           '2': n^.Flags := $4;
  5899.           '3': n^.Flags := $6;
  5900.         end;
  5901.         Delete(Name, 1, 1);
  5902.         new(tmpv);
  5903.         tmpv^.FVar := n;
  5904.         tmpv^.Name := name;
  5905.         tmpv^.NameHash := mkhash(name);
  5906.         PVariableManager(CC^.Variables).setItem(I, tmpv);
  5907.         Inc(I);
  5908.       end; {while}
  5909.       if assigned(C^.InheritsFrom) then
  5910.         C := (C^.InheritsFrom^.Ext)
  5911.       else
  5912.         C := nil;
  5913.     end; {while}
  5914.     AA := VM_Count(CC^.Variables);
  5915.     C := PIFSClassType(CC^.ClassType^.Ext);
  5916.     for I := 0 to Longint(PIFSClassType(CC^.ClassType^.Ext)^.PropStart + PIFSClassType(CC^.ClassType^.Ext)^.Properties.Count) - 1 do begin
  5917.       PVariableManager(CC^.Variables).Add(nil);
  5918.     end;
  5919.     while assigned(C) do begin
  5920.       for I := 0 to Longint(C^.Properties.Count) - 1 do begin
  5921.         new(tmpv);
  5922.         tmpv^.Name := '';
  5923.         tmpv^.NameHash := 1;
  5924.         tmpv^.FVar := CreateProperty(C^.Properties.GetItem(I));
  5925.         PVariableManager(CC^.Variables).SetItem(AA + Longint(C^.PropStart) + I, tmpv);
  5926.       end;
  5927.       if assigned(C^.InheritsFrom) then
  5928.         C := (C^.InheritsFrom^.Ext)
  5929.       else
  5930.         C := nil;
  5931.     end;
  5932.   end;
  5933.  
  5934. begin
  5935.   if (proc^.Flags and $40) = 0 then begin
  5936.     DoClassConstructor := nil;
  5937.     RunError(Self, EConstructorExpected);
  5938.     exit;
  5939.   end;
  5940.   DoClassConstructor := nil;
  5941.   Params := VM_Create;
  5942.   New(CC);
  5943.   CC^.Variables := VM_Create;
  5944.   CC^.ClassType := Myclass;
  5945.   CreateVars;
  5946.   CC^.AlreadyFreed := False;
  5947.   CreatedClasses.Add(CC);
  5948.   slf := CreateCajVariant(Myclass);
  5949.   slf^.CV_Class := CC;
  5950.   with Vm_Add(Params, CreateCajVariant(proc^.ClassType), 'SELF')^ do begin
  5951.     CV_Class := slf^.CV_Class;
  5952.     Flags := 1;
  5953.   end;
  5954.   Parser.Next;
  5955.   if not ReadParams(WithList, proc^.Decl, Vars, Params) then begin
  5956.     VM_Destroy(Params);
  5957.     DestroyCajVariant(slf);
  5958.     exit;
  5959.   end;
  5960.   ProcStack.Add(Proc);
  5961.   OldVars := CurrVars;
  5962.   CurrVars := Params;
  5963.   {Now we have all the parameters}
  5964.   if proc^.Mode = 0 then begin
  5965.     I := Parser.CurrTokenPos;
  5966.     Parser.CurrTokenPos := proc^.offset;
  5967.     if Parser.CurrTokenId = CSTII_Var then begin
  5968.       if not ProcessVars(Params) then begin
  5969.         DestroyCajVariant(slf);
  5970.         exit;
  5971.       end; {if}
  5972.     end; {if}
  5973.     WithList := TIfList.Create; // old withlist is no longer needed
  5974.     WithList.Add(CreateVarType(Vm_Get(Params, 0)));
  5975.     if not RunBegin(WithList, Params, False) then begin
  5976.       if FError.ErrorCode = EExitCommand then
  5977.         FError.ErrorCode := 0
  5978.       else begin
  5979.         DestroyCajVariant(slf);
  5980.         DestroyWithList(WithList);
  5981.         exit;
  5982.       end;
  5983.     end; {if}
  5984.     DestroyWithList(WithList);
  5985.     Parser.CurrTokenPos := I;
  5986.     DoClassConstructor := slf;
  5987.     VM_Destroy(Params);
  5988.   end {if}
  5989.   else if proc^.Mode = 1 then begin
  5990.     RunError(Self, proc^.proc1(proc^.FScriptEngine, fId, proc, Params, nil));
  5991.     if FError.ErrorCode = EExitCommand then
  5992.       FError.ErrorCode := 0
  5993.     else
  5994.       if FError.ErrorCode <> ENoError then begin
  5995.         VM_Destroy(Params);
  5996.         DestroyCajVariant(slf);
  5997.         exit;
  5998.       end; {if}
  5999.     VM_Destroy(Params);
  6000.     DoClassConstructor := slf;
  6001.   end {if}
  6002.   else begin
  6003.     RunError(Self, proc^.proc2(proc^.FScriptEngine, fId, proc, Params, nil));
  6004.     if FError.ErrorCode = EExitCommand then
  6005.       FError.ErrorCode := 0
  6006.     else
  6007.       if FError.ErrorCode <> ENoError then begin
  6008.         VM_Destroy(Params);
  6009.         DestroyCajVariant(slf);
  6010.         exit;
  6011.       end; {if}
  6012.     VM_Destroy(Params);
  6013.     DoClassConstructor := slf;
  6014.   end; {if}
  6015.   PopProcStack;
  6016.   CurrVars := OldVars;
  6017. end; {DoClassConstructor}
  6018. {$ENDIF}
  6019.  
  6020. function TIfPasScript.ReadParams(WithList: TIfList; ProcDef: string; Vars, Params: PVariableManager): Boolean;
  6021. {Call an internal/external Procedure}
  6022. var
  6023.   w: PIfVariant;
  6024.   I: Longint;
  6025.  
  6026.   function IRem(s: string): string;
  6027.   {Remove the !}
  6028.   begin
  6029.     Delete(s, 1, 1);
  6030.     IRem := s;
  6031.   end; {irem}
  6032. begin
  6033.   ReadParams := False;
  6034.   if (IntProcDefParam(ProcDef, -1) <> 0) and (Parser.CurrTokenId <> CSTI_OpenRound) then begin
  6035.     RunError(Self, ERoundOpenExpected);
  6036.     exit;
  6037.   end; {if}
  6038.   if (IntProcDefParam(ProcDef, -1) = 0) and (Parser.CurrTokenId = CSTI_OpenRound) then begin
  6039.     Parser.Next;
  6040.     if Parser.CurrTokenId = CSTI_CloseRound then begin
  6041.       Parser.Next;
  6042.     end else begin
  6043.       RunError(Self, ECloseRoundExpected);
  6044.       exit;
  6045.     end;
  6046.   end; {if}
  6047.   if Parser.CurrTokenId = CSTI_OpenRound then begin
  6048.     for I := 1 to IntProcDefParam(ProcDef, -1) do begin
  6049.       Parser.Next;
  6050.       if Pos('!', IntProcDefName(ProcDef, I)) = 1 then begin
  6051.         {Expect a variable}
  6052.         case GetIdentifier(WithList, Vars, 1, w) of
  6053.           0: begin
  6054.               exit;
  6055.             end;
  6056.           2: begin
  6057.               DestroyCajVariant(w);
  6058.               RunError(Self, EVariableExpected);
  6059.               exit;
  6060.             end;
  6061.         end;
  6062.         if (w^.Flags and $1) <> 0 then begin
  6063.           RunError(Self, EVariableExpected);
  6064.           exit;
  6065.         end; {if}
  6066.         w := GetVarLink(w);
  6067.         if (Longint(w^.VType) <> IntProcDefParam(ProcDef, I)) and not ((PTypeRec(IntProcDefParam(ProcDef, I))^.Ext = nil) and (PTypeRec(IntProcDefParam(ProcDef, I))^.atypeid = CSV_Array)) and not (PTypeRec(IntProcDefParam(ProcDef, I))^.atypeid = CSV_Var) then begin
  6068.           RunError(Self, ETypeMismatch);
  6069.           exit;
  6070.         end;
  6071.         Vm_Add(Params, CreateCajVariant(TM_Add(Types, '', CSV_Var, nil)), FastUppercase(IRem(IntProcDefName(ProcDef, I))))^.CV_Var := w;
  6072.       end {if}
  6073.       else if Pos('^', IntProcDefName(ProcDef, I)) = 1 then begin
  6074.         {Expect a constant}
  6075.         case GetIdentifier(WithList, Vars, 1, w) of
  6076.           0: begin // error
  6077.               exit;
  6078.             end;
  6079.           2: begin // created variable
  6080.               w := GetVarLink(w);
  6081.               if (Longint(w^.VType) <> IntProcDefParam(ProcDef, I)) and not ((PTypeRec(IntProcDefParam(ProcDef, I))^.Ext = nil) and (PTypeRec(IntProcDefParam(ProcDef, I))^.atypeid = CSV_Array))
  6082.               and not (PTypeRec(IntProcDefParam(ProcDef, I))^.atypeid = CSV_Var) then begin
  6083.                 RunError(Self, ETypeMismatch);
  6084.                 exit;
  6085.               end;
  6086.               Vm_Add(Params, w, IRem(IntProcDefName(ProcDef, I)))^.Flags := 1; {readonly}
  6087.             end;
  6088.         else begin
  6089.             w := GetVarLink(w);
  6090.             if (Longint(w^.VType) <> IntProcDefParam(ProcDef, I)) and not ((PTypeRec(IntProcDefParam(ProcDef, I))^.Ext = nil) and (PTypeRec(IntProcDefParam(ProcDef, I))^.atypeid = CSV_Array))
  6091.             and not (PTypeRec(IntProcDefParam(ProcDef, I))^.atypeid = CSV_Var) then begin
  6092.               RunError(Self, ETypeMismatch);
  6093.               exit;
  6094.             end;
  6095.             with Vm_Add(Params, CreateCajVariant(TM_Add(Types, '', CSV_Var, nil)), IRem(IntProcDefName(ProcDef, I)))^ do begin
  6096.               CV_Var := w;
  6097.               Flags := 1; {readonly}
  6098.             end;
  6099.           end;
  6100.         end;
  6101.       end {if}
  6102.       else begin
  6103.         w := Vm_Add(Params, CreateCajVariant(Pointer(IntProcDefParam(ProcDef, I))), IntProcDefName(ProcDef, I));
  6104.         if not calc(WithList, Vars, w, CSTI_CloseRound, False) then begin
  6105.           exit;
  6106.         end; {if}
  6107.       end; {else if}
  6108.       if I = IntProcDefParam(ProcDef, -1) then begin
  6109.         if Parser.CurrTokenId <> CSTI_CloseRound then begin
  6110.           RunError(Self, ERoundCloseExpected);
  6111.           exit;
  6112.         end; {if}
  6113.       end {if}
  6114.       else begin
  6115.         if Parser.CurrTokenId <> CSTI_Comma then begin
  6116.           RunError(Self, ECommaExpected);
  6117.           exit;
  6118.         end; {if}
  6119.       end; {else if}
  6120.     end; {for}
  6121.     Parser.Next;
  6122.   end; {if}
  6123.   ReadParams := True;
  6124. end;
  6125.  
  6126. function TIfPasScript.DoProc(WithList: TIfList; {$IFNDEF NOCLASSES}Myself: PCreatedClass; {$ENDIF}proc: PProcedure; Vars: PVariableManager): PIfVariant;
  6127. {Call an internal/external Procedure}
  6128. var
  6129.   OldVars: PVariableManager;
  6130.   w: PIfVariant;
  6131.   I: Longint;
  6132.   Params: PVariableManager;
  6133.  
  6134.   function IRem(s: string): string;
  6135.   {Remove the !}
  6136.   begin
  6137.     Delete(s, 1, 1);
  6138.     IRem := s;
  6139.   end; {irem}
  6140. {$IFNDEF NOCLASSES}
  6141.  
  6142.   procedure AddSelf;
  6143.   begin
  6144.     with Vm_Add(Params, CreateCajVariant(proc^.ClassType), 'SELF')^ do begin
  6145.       CV_Class := Myself;
  6146.       Flags := 1;
  6147.     end;
  6148.   end;
  6149. {$ENDIF}
  6150. begin
  6151.   DoProc := nil;
  6152.   Params := VM_Create;
  6153. {$IFNDEF NOCLASSES}
  6154.   if assigned(Myself) then begin
  6155.     AddSelf;
  6156.   end;
  6157. {$ENDIF}
  6158.   if not ReadParams(WithList, proc^.Decl, Vars, Params) then begin
  6159.     VM_Destroy(Params);
  6160.     exit;
  6161.   end;
  6162.   ProcStack.Add(Proc);
  6163.   OldVars := CurrVars;
  6164.   CurrVars := Params;
  6165.   {Now we have all the parameters}
  6166.   if proc^.Mode = 0 then begin
  6167.     if proc^.FScriptEngine = Self then begin
  6168.       if IntProcDefParam(proc^.Decl, 0) <> 0 then begin
  6169.         w := CreateCajVariant(Pointer(IntProcDefParam(proc^.Decl, 0)));
  6170.         Vm_Add(Params, CreateCajVariant(TM_Add(Types, '', CSV_Var, nil)), 'RESULT')^.CV_Var := w;
  6171.       end {if}
  6172.       else w := nil;
  6173.       I := Parser.CurrTokenPos;
  6174.       Parser.CurrTokenPos := proc^.offset;
  6175.       if Parser.CurrTokenId = CSTII_Var then begin
  6176.         if not ProcessVars(Params) then begin
  6177.           VM_Destroy(Params);
  6178.           DestroyCajVariant(w);
  6179.           exit;
  6180.         end; {if}
  6181.       end; {if}
  6182.       WithList := TIfList.Create;
  6183. {$IFNDEF NOCLASSES}
  6184.       if assigned(proc^.ClassType) then begin
  6185.         WithList.Add(CreateVarType(Vm_Get(Params, 0)));
  6186.       end;
  6187. {$ENDIF}
  6188.       if not RunBegin(WithList, Params, False) then begin
  6189.         if FError.ErrorCode = EExitCommand then
  6190.           FError.ErrorCode := 0
  6191.         else begin
  6192.           VM_Destroy(Params);
  6193.           DestroyWithList(WithList);
  6194.           DestroyCajVariant(w);
  6195.           exit;
  6196.         end;
  6197.       end; {if}
  6198.       DestroyWithList(WithList);
  6199.       Parser.CurrTokenPos := I;
  6200.       DoProc := w;
  6201.       VM_Destroy(Params);
  6202.     end else begin
  6203.       DoProc := TIfPasScript(proc^.FScriptEngine).RunScriptProc(proc, Params);
  6204.       if TIfPasScript(proc^.FScriptEngine).ErrorCode <> 0 then begin
  6205.         RunError2(proc^.FScriptEngine, TIfPasScript(proc^.FScriptEngine).ErrorCode, TIfPasScript(proc^.FScriptEngine).ErrorString);
  6206.         DoProc := nil;
  6207.       end;
  6208.       VM_Destroy(Params);
  6209.     end;
  6210.   end {if}
  6211.   else if proc^.Mode = 1 then begin
  6212.     if IntProcDefParam(proc^.Decl, 0) <> 0 then
  6213.       w := CreateCajVariant(Pointer(IntProcDefParam(proc^.Decl, 0)))
  6214.     else
  6215.       w := nil;
  6216.     RunError(Self, proc^.proc1(proc^.FScriptEngine, fId, proc, Params, w));
  6217.     if FError.ErrorCode = EExitCommand then
  6218.       FError.ErrorCode := 0
  6219.     else
  6220.       if FError.ErrorCode <> ENoError then begin
  6221.         VM_Destroy(Params);
  6222.         DestroyCajVariant(w);
  6223.         exit;
  6224.       end; {if}
  6225.     VM_Destroy(Params);
  6226.     DoProc := w;
  6227.   end {if} else begin
  6228.     if IntProcDefParam(proc^.Decl, 0) <> 0 then
  6229.       w := CreateCajVariant(Pointer(IntProcDefParam(proc^.Decl, 0)))
  6230.     else
  6231.       w := nil;
  6232.     RunError(Self, proc^.proc2(proc^.FScriptEngine, fId, proc, Params, w));
  6233.     if FError.ErrorCode = EExitCommand then
  6234.       FError.ErrorCode := 0
  6235.     else
  6236.       if FError.ErrorCode <> ENoError then begin
  6237.         VM_Destroy(Params);
  6238.         DestroyCajVariant(w);
  6239.         exit;
  6240.       end; {if}
  6241.     VM_Destroy(Params);
  6242.     DoProc := w;
  6243.   end; {if}
  6244.   PopProcStack;
  6245.   CurrVars := OldVars;
  6246. end; {DoProc}
  6247.  
  6248. //-------------------------------------------------------------------
  6249. // Procedure: RunBegin
  6250. //   Purpose: Steps through the script, parsing the tokens
  6251. //-------------------------------------------------------------------
  6252. type
  6253.   TBeginMode = (mbTry, mbRepeat, mbBegin, mbOneLiner);
  6254.  
  6255. function TIfPasScript.RunBegin(WithList: TIfList; Vars: PVariableManager; Skip: Boolean): Boolean;
  6256.       { Run the Script, this is the main part of the script engine }
  6257. var
  6258.   C, c2, C3: PIfVariant;
  6259.   IPos, IStart, ii, IEnd: Longint;
  6260.   b: Boolean;
  6261. {$IFNDEF NOCLASSES}
  6262.   NewWithList: TIfList;
  6263. {$ENDIF}
  6264.   BeginMode: TBeginMode;
  6265.   lBreak: Boolean;
  6266. begin
  6267.   if Parser.CurrTokenId = CSTII_repeat then BeginMode := mbRepeat else
  6268.     if Parser.CurrTokenId = CSTII_try then BeginMode := mbTry else
  6269.       BeginMode := mbOneLiner;
  6270.   Inc(FBeginNesting);
  6271.   if FBeginNesting > FMaxBeginNesting then begin
  6272.     Dec(FBeginNesting);
  6273.     RunError(Self, EOutOfMemoryError);
  6274.     RunBegin := False;
  6275.     exit;
  6276.   end;
  6277.  
  6278.   if Skip then begin
  6279.     if (Parser.CurrTokenId = CSTII_Begin) or (Parser.CurrTokenId = CSTII_Case) or (Parser.CurrTokenId = CSTII_repeat) or (Parser.CurrTokenId = CSTII_try) or (Parser.CurrTokenId = CSTII_Except)
  6280.     or (Parser.CurrTokenId = CSTII_Finally) then begin
  6281.       IPos := 1;
  6282.       Parser.Next;
  6283.       while Parser.CurrTokenId <> CSTI_EOF do begin
  6284.         case Parser.CurrTokenId of
  6285.           CSTII_Case, CSTII_Begin, CSTII_try, CSTII_repeat: Inc(IPos);
  6286.           CSTII_until, CSTII_End: begin
  6287.               Dec(IPos);
  6288.               if IPos = 0 then begin
  6289.                 RunBegin := True;
  6290.                 Parser.Next;
  6291.                 Dec(FBeginNesting);
  6292.                 exit;
  6293.               end;
  6294.             end;
  6295.         end;
  6296.         Parser.Next;
  6297.       end;
  6298.       RunError(Self, EUnexpectedEndOfFile);
  6299.       RunBegin := False;
  6300.       Dec(FBeginNesting);
  6301.       exit;
  6302.     end else begin
  6303.       IPos := 1;
  6304.       while Parser.CurrTokenId <> CSTI_EOF do begin
  6305.         case Parser.CurrTokenId of
  6306.           CSTII_If: Inc(IPos);
  6307.           CSTI_Semicolon: begin
  6308.               RunBegin := True;
  6309.               Dec(FBeginNesting);
  6310.               exit;
  6311.             end;
  6312.           CSTII_Else: begin
  6313.               Dec(IPos);
  6314.               if IPos = 0 then begin
  6315.                 RunBegin := True;
  6316.                 Dec(FBeginNesting);
  6317.                 exit;
  6318.               end;
  6319.             end;
  6320.           CSTII_Begin, CSTII_Case, CSTII_repeat: begin
  6321.               if ExecRunLine then
  6322.               begin
  6323.                 Dec(FBeginNesting);
  6324.                 RunBegin := True;
  6325.                 exit;
  6326.               end;
  6327.               RunBegin(WithList, Vars, True);
  6328.               continue;
  6329.             end;
  6330.           CSTII_End, CSTII_until: begin
  6331.               RunBegin := True;
  6332.               Dec(FBeginNesting);
  6333.               exit;
  6334.             end;
  6335.         end;
  6336.         Parser.Next;
  6337.       end;
  6338.       RunError(Self, EUnexpectedEndOfFile);
  6339.       RunBegin := False;
  6340.       Dec(FBeginNesting);
  6341.       exit;
  6342.     end;
  6343.   end;
  6344.   RunBegin := False;
  6345.   if (Parser.CurrTokenId = CSTII_Begin) or (Parser.CurrTokenId = CSTII_Except) or (Parser.CurrTokenId = CSTII_Finally) then begin
  6346.     BeginMode := mbBegin;
  6347.     Parser.Next; {skip begin}
  6348.   end else
  6349.     if (Parser.CurrTokenId = CSTII_repeat) or (Parser.CurrTokenId = CSTII_try) then
  6350.       Parser.Next;
  6351.  
  6352.   while True do begin
  6353.  
  6354.     case Parser.CurrTokenId of
  6355.       CSTI_EOF: begin
  6356.           RunError(Self, EUnexpectedEndOfFile);
  6357.           Dec(FBeginNesting);
  6358.           exit;
  6359.         end;
  6360.       CSTII_Else: begin
  6361.           if BeginMode = mbOneLiner then begin
  6362.             RunBegin := True;
  6363.             Dec(FBeginNesting);
  6364.             exit;
  6365.           end
  6366.           else begin
  6367.             RunError(Self, EErrorInStatement);
  6368.             RunBegin := False;
  6369.             Dec(FBeginNesting);
  6370.             exit;
  6371.           end;
  6372.         end;
  6373.       CSTII_try: begin
  6374.           if RunBegin(WithList, Vars, False) then begin
  6375.             if Parser.CurrTokenId = CSTII_Finally then begin
  6376.               RunBegin(WithList, Vars, False);
  6377.             end else if Parser.CurrTokenId = CSTII_Except then begin
  6378.               RunBegin(WithList, Vars, True);
  6379.             end;
  6380.           end else begin
  6381.             if FError.ErrorCode < ERuntimeError then exit;
  6382.             FLastException := FError;
  6383.             RunError(Self, ENoError);
  6384.             while (Parser.CurrTokenId <> CSTII_Except) and (Parser.CurrTokenId <> CSTII_Finally) do begin
  6385.               if Parser.CurrTokenId = CSTI_EOF then begin
  6386.                 RunError(Self, EUnexpectedEndOfFile);
  6387.                 exit;
  6388.               end;
  6389.               Parser.Next;
  6390.             end;
  6391.             if Parser.CurrTokenId = CSTII_Finally then begin
  6392.               if not RunBegin(WithList, Vars, False) then
  6393.                 exit;
  6394.               FError := FLastException;
  6395.               exit;
  6396.             end else if Parser.CurrTokenId = CSTII_Except then begin
  6397.               if not RunBegin(WithList, Vars, FLastException.ErrorCode = EExitCommand) then
  6398.                 exit;
  6399.               FLastException := FError;
  6400.             end;
  6401.           end;
  6402.         end;
  6403.       CSTII_Finally,
  6404.         CSTII_Except: begin
  6405.           if BeginMode = mbTry then begin
  6406.             RunBegin := True;
  6407.             Dec(FBeginNesting);
  6408.             exit;
  6409.           end else begin
  6410.             case BeginMode of
  6411.               mbRepeat: RunError(Self, EUntilExpected);
  6412.               mbOneLiner, mbBegin: RunError(Self, EEndExpected);
  6413.             end;
  6414.             RunBegin := False;
  6415.             Dec(FBeginNesting);
  6416.             exit;
  6417.           end;
  6418.         end;
  6419.  
  6420.       CSTII_End: begin
  6421.           if (BeginMode = mbBegin) or (BeginMode = mbOneLiner) then begin
  6422.             RunBegin := True;
  6423.             if BeginMode <> mbOneLiner then
  6424.               Parser.Next;
  6425.             Dec(FBeginNesting);
  6426.             exit;
  6427.           end else begin
  6428.             case BeginMode of
  6429.               mbTry: RunError(Self, EExceptExpected);
  6430.               mbRepeat: RunError(Self, EUntilExpected);
  6431.             end;
  6432.             RunBegin := False;
  6433.             Dec(FBeginNesting);
  6434.             exit;
  6435.           end;
  6436.         end; {CSTII_End}
  6437.       CSTII_until: begin
  6438.           if BeginMode = mbRepeat then begin
  6439.             RunBegin := True;
  6440.             Dec(FBeginNesting);
  6441.             exit;
  6442.           end else begin
  6443.             case BeginMode of
  6444.               mbTry: RunError(Self, EExceptExpected);
  6445.               mbOneLiner, mbBegin: RunError(Self, EEndExpected);
  6446.             end;
  6447.             RunError(Self, EEndExpected);
  6448.             RunBegin := False;
  6449.             Dec(FBeginNesting);
  6450.             exit;
  6451.           end;
  6452.         end; {CSTII_Until}
  6453. //-------------------------------------------------------
  6454. // Exit command - aborts the script
  6455. //-------------------------------------------------------
  6456.       CSTII_Exit: begin
  6457.           RunBegin := False;
  6458.           RunError(Self, EExitCommand);
  6459.           Dec(FBeginNesting);
  6460.           exit;
  6461.         end; { CSTII_Exit}
  6462. //-------------------------------------------------------
  6463. // Break command - breaks out of loop
  6464. //-------------------------------------------------------
  6465.       CSTII_Break: begin
  6466.           RunBegin := True;
  6467.           Dec(FBeginNesting);
  6468.           exit;
  6469.         end; { CSTII_Break }
  6470. //-------------------------------------------------------
  6471. // Continue command - breaks out of loop
  6472. //-------------------------------------------------------
  6473.       CSTII_Continue: begin
  6474.           RunBegin := True;
  6475.           Dec(FBeginNesting);
  6476.           exit;
  6477.         end; { CSTII_Break }
  6478.  
  6479. //-------------------------------------------------------
  6480. // Semicolon is handled specially
  6481. //-------------------------------------------------------
  6482.       CSTI_Semicolon: begin
  6483.           if BeginMode = mbOneLiner then begin
  6484.             RunBegin := True;
  6485.             Dec(FBeginNesting);
  6486.             exit;
  6487.           end;
  6488.           Parser.Next;
  6489.         end; {CSTI_SemiColon}
  6490. //-------------------------------------------------------
  6491. // Process an IF statement
  6492. //-------------------------------------------------------
  6493.       CSTII_If: begin
  6494.           if ExecRunLine then
  6495.           begin
  6496.             Dec(FBeginNesting);
  6497.             exit;
  6498.           end;
  6499.           Parser.Next;
  6500.           C := CreateCajVariant(TM_Add(Types, '', CSV_Bool, nil));
  6501.           if not calc(WithList, Vars, C, CSTII_Then, False) then begin
  6502.             DestroyCajVariant(C);
  6503.             Dec(FBeginNesting);
  6504.             exit;
  6505.           end; {if}
  6506.           if Parser.CurrTokenId <> CSTII_Then
  6507.             then begin
  6508.             RunError(Self, EThenExpected);
  6509.             DestroyCajVariant(C);
  6510.             Dec(FBeginNesting);
  6511.             exit;
  6512.           end;
  6513.           Parser.Next; {skip THEN}
  6514.           if C^.Cv_Bool then begin
  6515.             DestroyCajVariant(C);
  6516.             if not RunBegin(WithList, Vars, False) then begin
  6517.               Dec(FBeginNesting);
  6518.               exit;
  6519.             end; {if}
  6520.             if Parser.CurrTokenId = CSTII_Else then begin
  6521.               if ExecRunLine then
  6522.               begin
  6523.                 Dec(FBeginNesting);
  6524.                 exit;
  6525.               end;
  6526.               Parser.Next;
  6527.               if not RunBegin(WithList, Vars, True) then begin
  6528.                 Dec(FBeginNesting);
  6529.                 exit;
  6530.               end; {if}
  6531.             end; {if}
  6532.           end {if}
  6533.           else begin
  6534.             DestroyCajVariant(C);
  6535.             if not RunBegin(WithList, Vars, True) then begin
  6536.               Dec(FBeginNesting);
  6537.               exit;
  6538.             end; {if}
  6539.             if Parser.CurrTokenId = CSTII_Else then begin
  6540.               Parser.Next;
  6541.               if ExecRunLine then
  6542.               begin
  6543.                 Dec(FBeginNesting);
  6544.                 exit;
  6545.               end;
  6546.               if not RunBegin(WithList, Vars, False) then begin
  6547.                 Dec(FBeginNesting);
  6548.                 exit;
  6549.               end; {if}
  6550.             end; {if}
  6551.           end; {if}
  6552.         end; {CSTII_If}
  6553.  
  6554. //--------------------------------------------------------------------
  6555. // Process the WHILE DO loop ***************************************--
  6556. //--------------------------------------------------------------------
  6557.       CSTII_While: begin
  6558.           lBreak := False;
  6559.  
  6560.           Parser.Next; // Find Next token
  6561.  
  6562.           C := CreateCajVariant(TM_Add(Types, '', CSV_Bool, nil)); // Create a boolean variable
  6563.           IPos := Parser.CurrTokenPos; // Save position of variable
  6564.  
  6565.           // Test the expression up to the DO command
  6566.           //-------------------------------------------
  6567.           if not calc(WithList, Vars, C, CSTII_do, False) then begin
  6568.             DestroyCajVariant(C);
  6569.             Dec(FBeginNesting);
  6570.             exit;
  6571.           end; {if}
  6572.  
  6573.           // If not a DO command, this is an error
  6574.           //-----------------------------------------
  6575.           if Parser.CurrTokenId <> CSTII_do then begin
  6576.             RunError(Self, EDoExpected);
  6577.             DestroyCajVariant(C);
  6578.             Dec(FBeginNesting);
  6579.             exit;
  6580.           end;
  6581.  
  6582.           Parser.Next;
  6583.  
  6584.           // Save the DO block starting position
  6585.           //--------------------------------------
  6586.           IStart := Parser.CurrTokenPos;
  6587.  
  6588.           //-------------------------------
  6589.           // Start the loop processing
  6590.           //-------------------------------
  6591.           while C^.Cv_Bool and (not lBreak) do begin
  6592.              // See if any command to run
  6593.              // ---------------------------
  6594.             if ExecRunLine then
  6595.             begin
  6596.               Dec(FBeginNesting);
  6597.               exit;
  6598.             end;
  6599.  
  6600.              // Call routine to process the code
  6601.              //----------------------------------
  6602.             if not RunBegin(WithList, Vars, False) then begin
  6603.               DestroyCajVariant(C);
  6604.               Dec(FBeginNesting);
  6605.               exit;
  6606.             end;
  6607.  
  6608.             // If a break were returned
  6609.             //--------------------------
  6610.             if Parser.CurrTokenId = CSTII_Break then begin
  6611.               lBreak := True;
  6612.             end;
  6613.  
  6614.             // Go back to the variable test position
  6615.             //----------------------------------------
  6616.             Parser.CurrTokenPos := IPos;
  6617.  
  6618.             // Test the condition again, if false, exit
  6619.             //-----------------------------------------
  6620.             if not calc(WithList, Vars, C, CSTII_do, False) then begin
  6621.               DestroyCajVariant(C);
  6622.               Dec(FBeginNesting);
  6623.               exit;
  6624.             end;
  6625.  
  6626.             // Reset to the DO starting block
  6627.             //---------------------------------
  6628.             Parser.CurrTokenPos := IStart;
  6629.           end;
  6630.  
  6631.           DestroyCajVariant(C);
  6632.           if not RunBegin(WithList, Vars, True) then begin
  6633.             Dec(FBeginNesting);
  6634.             exit;
  6635.           end;
  6636.         end;
  6637. //--------------------------------------------------------------------
  6638. // Process the REPEAT UNTIL loop ***********************************--
  6639. //--------------------------------------------------------------------
  6640.       CSTII_repeat: begin
  6641.           lBreak := False;
  6642.  
  6643.           C := CreateCajVariant(TM_Add(Types, '', CSV_Bool, nil)); // Create a boolean variable
  6644.  
  6645.           IStart := Parser.CurrTokenPos;
  6646.  
  6647.           //-------------------------------
  6648.           // Start the loop processing
  6649.           //-------------------------------
  6650.           repeat
  6651.             Parser.CurrTokenPos := IStart;
  6652.              // See if any command to run
  6653.              // ---------------------------
  6654.             if ExecRunLine then
  6655.             begin
  6656.               Dec(FBeginNesting);
  6657.               exit;
  6658.             end;
  6659.  
  6660.              // Call routine to process the code
  6661.              //----------------------------------
  6662.             if not RunBegin(WithList, Vars, False) then begin
  6663.               DestroyCajVariant(C);
  6664.               Dec(FBeginNesting);
  6665.               exit;
  6666.             end;
  6667.  
  6668.             // If a break were returned
  6669.             //--------------------------
  6670.             if Parser.CurrTokenId = CSTII_Break then begin
  6671.               lBreak := True;
  6672.               break;
  6673.             end;
  6674.  
  6675.             if Parser.CurrTokenId <> CSTII_until then begin
  6676.               RunError(Self, EUntilExpected);
  6677.               DestroyCajVariant(C);
  6678.               Dec(FBeginNesting);
  6679.               exit;
  6680.             end;
  6681.  
  6682.             Parser.Next;
  6683.  
  6684.             // Test the condition again, if false, exit
  6685.             //-----------------------------------------
  6686.             if not calc(WithList, Vars, C, CSTI_Semicolon, False) then begin
  6687.               DestroyCajVariant(C);
  6688.               Dec(FBeginNesting);
  6689.               exit;
  6690.             end;
  6691.           until C^.Cv_Bool;
  6692.  
  6693.           DestroyCajVariant(C);
  6694.  
  6695.           if lBreak then begin
  6696.             Parser.CurrTokenPos := IStart;
  6697.             if not RunBegin(WithList, Vars, True) then begin
  6698.               Dec(FBeginNesting);
  6699.               exit;
  6700.             end;
  6701.           end;
  6702.         end;
  6703.  
  6704. //-------------------------------------------------------
  6705. // FOR LOOP is handled here
  6706. //-------------------------------------------------------
  6707.       CSTII_For: begin
  6708.           // Found the FOR keyword
  6709.           // ----------------------
  6710.           Parser.Next; // Find the next token
  6711.  
  6712.           // It should be an identifier
  6713.           //------------------------------
  6714.           if Parser.CurrTokenId <> CSTI_Identifier then begin
  6715.             RunError(Self, EIdentifierExpected);
  6716.             Dec(FBeginNesting);
  6717.             exit;
  6718.           end; {if}
  6719.  
  6720.           // The variable must exist
  6721.           //------------------------------
  6722.           if assigned(Vars) and
  6723.             (VM_Find(Vars, Parser.GetToken) <> -1)
  6724.             then C := GetVarLink(Vm_Get(Vars, VM_Find(Vars,
  6725.               Parser.GetToken)))
  6726.           else
  6727.             if VM_Find(Variables, Parser.GetToken) <> -1
  6728.               then C := GetVarLink(Vm_Get(Variables, VM_Find(Variables,
  6729.                 Parser.GetToken)))
  6730.             else begin
  6731.               RunError2(Self, EUnknownIdentifier, Parser.GetToken);
  6732.               Dec(FBeginNesting);
  6733.               exit;
  6734.             end; {if}
  6735.  
  6736.           // It cannot be a constant
  6737.           //------------------------------
  6738.           if (C^.Flags and $1) <> 0 then begin
  6739.             RunError(Self, EVariableExpected);
  6740.             Dec(FBeginNesting);
  6741.             exit;
  6742.           end; {if}
  6743.  
  6744.           // And it must be an integer
  6745.           //------------------------------
  6746.           if not IsIntegerType(C) then begin
  6747.             RunError(Self, eIntegerExpected);
  6748.           end; {if}
  6749.  
  6750.           Parser.Next; // Find the next token
  6751.  
  6752.           // Expecting an assignment statement
  6753.           //----------------------------------------
  6754.           if Parser.CurrTokenId <> CSTI_Assignment then begin
  6755.             RunError(Self, EAssignmentExpected);
  6756.             Dec(FBeginNesting);
  6757.             exit;
  6758.           end; {if}
  6759.  
  6760.           Parser.Next; // Find the next token
  6761.  
  6762.           // Calculate expression of token from current position
  6763.           // to the TO keyword
  6764.           //--------------------------------------------------
  6765.           if not calc(WithList, Vars, C, CSTII_To, False)
  6766.             then begin
  6767.             Dec(FBeginNesting);
  6768.             exit;
  6769.           end;
  6770.  
  6771.           // Get the result of the calculation
  6772.           //---------------------------------------
  6773.           IStart := GetInteger(C);
  6774.  
  6775.           if (Parser.CurrTokenId <> CSTII_To) and
  6776.             (Parser.CurrTokenId <> CSTII_DownTo) then begin
  6777.             RunError(Self, EToExpected);
  6778.             Dec(FBeginNesting);
  6779.             exit;
  6780.           end; {if}
  6781.  
  6782.           // See if we are going up or down
  6783.           //-----------------------------------
  6784.           b := (Parser.CurrTokenId = CSTII_DownTo);
  6785.  
  6786.           Parser.Next; // Find the next token
  6787.  
  6788.           if not calc(WithList, Vars, C, CSTII_do, False)
  6789.             then begin
  6790.             Dec(FBeginNesting);
  6791.             exit;
  6792.           end;
  6793.  
  6794.           // Get the result of the calculation
  6795.           //---------------------------------------
  6796.           IEnd := GetInteger(C);
  6797.  
  6798.           if Parser.CurrTokenId <> CSTII_do then begin
  6799.             RunError(Self, EDoExpected);
  6800.             Dec(FBeginNesting);
  6801.             exit;
  6802.           end; {if}
  6803.  
  6804.           Parser.Next; // Find the next token
  6805.  
  6806.           lBreak := False; // Assume the loop will complete
  6807.           IPos := Parser.CurrTokenPos;
  6808.  
  6809.           if b then begin
  6810.             C^.Flags := C^.Flags or $1;
  6811.  
  6812.             // Start the loop
  6813.             //------------------------------
  6814.             for ii := IStart downto IEnd do begin
  6815.               if ExecRunLine then
  6816.               begin
  6817.                 Dec(FBeginNesting);
  6818.                 exit;
  6819.               end;
  6820.  
  6821.               // Make the loop variable visible to program
  6822.               //--------------------------------------------
  6823.               SetInteger(C, ii);
  6824.               if not RunBegin(WithList, Vars, False) then begin
  6825.                 C^.Flags := C^.Flags and not $1;
  6826.                 Dec(FBeginNesting);
  6827.                 exit;
  6828.               end;
  6829.  
  6830.               // If a break were returned
  6831.               //--------------------------
  6832.               if Parser.CurrTokenId = CSTII_Break
  6833.                 then lBreak := True;
  6834.  
  6835.               Parser.CurrTokenPos := IPos;
  6836.  
  6837.               if lBreak then break;
  6838.  
  6839.             end;
  6840.             C^.Flags := C^.Flags and not $1;
  6841.             if not RunBegin(WithList, Vars, True) then begin
  6842.               Dec(FBeginNesting);
  6843.               exit;
  6844.             end;
  6845.           end {if}
  6846.           else begin
  6847.             C^.Flags := C^.Flags or $1;
  6848.             for ii := IStart to IEnd do begin
  6849.               if ExecRunLine then
  6850.               begin
  6851.                 Dec(FBeginNesting);
  6852.                 exit;
  6853.               end;
  6854.  
  6855.               SetInteger(C, ii);
  6856.               if not RunBegin(WithList, Vars, False) then begin
  6857.                 C^.Flags := C^.Flags and not $1;
  6858.                 Dec(FBeginNesting);
  6859.                 exit;
  6860.               end;
  6861.  
  6862.               // If a break were returned
  6863.               //--------------------------
  6864.               if Parser.CurrTokenId = CSTII_Break
  6865.                 then lBreak := True;
  6866.  
  6867.               Parser.CurrTokenPos := IPos;
  6868.  
  6869.               // If a break were returned
  6870.                             //--------------------------
  6871.               if lBreak then break
  6872.  
  6873.             end;
  6874.             C^.Flags := C^.Flags and not $1;
  6875.             if not RunBegin(WithList, Vars, True) then begin
  6876.               Dec(FBeginNesting);
  6877.               exit;
  6878.             end;
  6879.           end {if}
  6880.         end;
  6881. //-------------------------------------------------------
  6882. // Begin a block
  6883. //-------------------------------------------------------
  6884.       CSTII_Begin: begin
  6885.           if not RunBegin(WithList, Vars, False) then begin
  6886.             Dec(FBeginNesting);
  6887.             exit;
  6888.           end;
  6889.         end; {CSTII_Begin}
  6890. //-------------------------------------------------------
  6891. // CASE <x> OF
  6892. //-------------------------------------------------------
  6893.       CSTII_Case: begin
  6894.           Parser.Next;
  6895.           C := CreateCajVariant(TM_Add(Types, '', CSV_Var, nil));
  6896.           C^.CV_Var := nil; {Say that calc can assign any type}
  6897.           if not calc(WithList, Vars, C, CSTII_Of, False) then begin
  6898.             DestroyCajVariant(C);
  6899.             Dec(FBeginNesting);
  6900.             exit;
  6901.           end; {If}
  6902.           if Parser.CurrTokenId <> CSTII_Of then begin
  6903.             RunError(Self, EOfExpected);
  6904.             Dec(FBeginNesting);
  6905.             exit;
  6906.           end; {If}
  6907.           Parser.Next;
  6908.           b := False;
  6909.           while Parser.CurrTokenId <> CSTII_End do begin
  6910.             if Parser.CurrTokenId = CSTII_Else then begin
  6911.               Parser.Next;
  6912.               if not RunBegin(WithList, Vars, b) then begin
  6913.                 Dec(FBeginNesting);
  6914.                 exit;
  6915.               end;
  6916.               if Parser.CurrTokenId = CSTI_Semicolon then begin
  6917.                 Parser.Next;
  6918.               end;
  6919.               if Parser.CurrTokenId <> CSTII_End then begin
  6920.                 RunError(Self, EEndExpected);
  6921.                 Dec(FBeginNesting);
  6922.                 exit;
  6923.               end;
  6924.               break;
  6925.             end;
  6926.             if ExecRunLine then
  6927.             begin
  6928.               Dec(FBeginNesting);
  6929.               exit;
  6930.             end;
  6931.             c2 := CreateCajVariant(C^.VType);
  6932.             if not calc(WithList, Vars, c2, CSTI_Colon, False) then begin
  6933.               DestroyCajVariant(C);
  6934.               DestroyCajVariant(c2);
  6935.               Dec(FBeginNesting);
  6936.               exit;
  6937.             end; {If}
  6938.             if not Perform(c2, C, PtEqual) then begin
  6939.               DestroyCajVariant(C);
  6940.               DestroyCajVariant(c2);
  6941.               Dec(FBeginNesting);
  6942.               exit;
  6943.             end; {If}
  6944.             while Parser.CurrTokenId = CSTI_Comma do begin
  6945.               Parser.Next;
  6946.               C3 := CreateCajVariant(C^.VType);
  6947.               if not calc(WithList, Vars, C3, CSTI_Colon, False) then begin
  6948.                 DestroyCajVariant(C);
  6949.                 DestroyCajVariant(c2);
  6950.                 DestroyCajVariant(C3);
  6951.                 Dec(FBeginNesting);
  6952.                 exit;
  6953.               end; {If}
  6954.               if not Perform(C3, C, PtEqual) then begin
  6955.                 DestroyCajVariant(C);
  6956.                 DestroyCajVariant(c2);
  6957.                 DestroyCajVariant(C3);
  6958.                 Dec(FBeginNesting);
  6959.                 exit;
  6960.               end; {If}
  6961.               if not Perform(c2, C3, ptOr) then begin
  6962.                 DestroyCajVariant(C);
  6963.                 DestroyCajVariant(c2);
  6964.                 Dec(FBeginNesting);
  6965.                 exit;
  6966.               end;
  6967.             end;
  6968.             if Parser.CurrTokenId <> CSTI_Colon then begin
  6969.               RunError(Self, EColonExpected);
  6970.               DestroyCajVariant(C);
  6971.               DestroyCajVariant(c2);
  6972.               Dec(FBeginNesting);
  6973.               exit;
  6974.             end; {If}
  6975.             Parser.Next;
  6976.             if not RunBegin(WithList, Vars, (not c2^.Cv_Bool or b)) then begin
  6977.               DestroyCajVariant(C);
  6978.               DestroyCajVariant(c2);
  6979.               Dec(FBeginNesting);
  6980.               exit;
  6981.             end;
  6982.             if c2^.Cv_Bool then
  6983.               b := True;
  6984.             if Parser.CurrTokenId = CSTI_Semicolon then begin
  6985.               Parser.Next;
  6986.             end;
  6987.             DestroyCajVariant(c2);
  6988.           end; {While}
  6989.           DestroyCajVariant(C);
  6990.           Parser.Next; {Skip end}
  6991.         end; {CSTII_Case}
  6992. {$IFNDEF NOClASSES}
  6993.       CSTII_WITH: begin
  6994.           Parser.Next;
  6995.           NewWithList := TIfList.Create;
  6996.           case GetIdentifier(WithList, Vars, 0, C) of
  6997.             0: begin
  6998.                 DestroyWithList(NewWithList);
  6999.                 Dec(FBeginNesting);
  7000.                 exit;
  7001.               end; // case 0
  7002.             1: C := CreateVarType(C);
  7003.             2: ;
  7004.           end; //case
  7005.           if (GetVarLink(C)^.VType^.atypeid = CSV_Class) or (GetVarLink(C)^.VType^.ATypeId = CSV_Record) then begin
  7006.             if GetVarLink(C)^.VType^.atypeid = CSV_Class then begin
  7007.               if (GetVarLink(C)^.CV_Class = nil) then begin
  7008.                 DestroyCajVariant(C);
  7009.                 DestroyWithList(NewWithList);
  7010.                 RunError(Self, EClassNotCreated);
  7011.                 Dec(FBeginNesting);
  7012.                 exit;
  7013.               end;
  7014.               if (GetVarLink(C)^.CV_Class^.AlreadyFreed) then begin
  7015.                 DestroyCajVariant(C);
  7016.                 DestroyWithList(NewWithList);
  7017.                 RunError(Self, EClassAlreadyFreed);
  7018.                 Dec(FBeginNesting);
  7019.                 exit;
  7020.               end;
  7021.             end;
  7022.             NewWithList.Add(C);
  7023.             while Parser.CurrTokenId <> CSTII_do do begin
  7024.               if Parser.CurrTokenId <> CSTI_Comma then begin
  7025.                 DestroyWithList(NewWithList);
  7026.                 RunError(Self, ECommaExpected);
  7027.                 Dec(FBeginNesting);
  7028.                 exit;
  7029.               end;
  7030.               Parser.Next;
  7031.               case GetIdentifier(WithList, Vars, 0, C) of
  7032.                 0: begin
  7033.                     DestroyWithList(NewWithList);
  7034.                     Dec(FBeginNesting);
  7035.                     exit;
  7036.                   end;
  7037.                 1: C := CreateVarType(C);
  7038.                 2: ;
  7039.               end; //case
  7040.               if GetVarLink(C)^.VType^.atypeid = CSV_Class then begin
  7041.                 if (GetVarLink(C)^.CV_Class = nil) then begin
  7042.                   DestroyCajVariant(C);
  7043.                   DestroyWithList(NewWithList);
  7044.                   RunError(Self, EClassNotCreated);
  7045.                   Dec(FBeginNesting);
  7046.                   exit;
  7047.                 end;
  7048.                 if (GetVarLink(C)^.CV_Class^.AlreadyFreed) then begin
  7049.                   DestroyCajVariant(C);
  7050.                   DestroyWithList(NewWithList);
  7051.                   RunError(Self, EClassAlreadyFreed);
  7052.                   Dec(FBeginNesting);
  7053.                   exit;
  7054.                 end;
  7055.               end else if GetVarLink(C)^.VType^.atypeid <> CSV_Record then begin
  7056.                 DestroyCajVariant(C);
  7057.                 DestroyWithList(NewWithList);
  7058.                 RunError(Self, EClassTypeExpected);
  7059.                 Dec(FBeginNesting);
  7060.                 exit;
  7061.               end;
  7062.               NewWithList.Add(C);
  7063.             end; //while
  7064.             for ii := 0 to Longint(WithList.Count) - 1 do begin
  7065.               NewWithList.Add(CreateVarType(WithList.GetItem(ii)));
  7066.             end;
  7067.             Parser.Next;
  7068.             if not RunBegin(NewWithList, Vars, False) then begin
  7069.               DestroyWithList(NewWithList);
  7070.               Dec(FBeginNesting);
  7071.               exit;
  7072.             end;
  7073.             DestroyWithList(NewWithList);
  7074.           end else begin
  7075.             DestroyCajVariant(C);
  7076.             DestroyWithList(NewWithList);
  7077.             RunError(Self, EClassTypeExpected);
  7078.             Dec(FBeginNesting);
  7079.             exit;
  7080.           end;
  7081.         end; {CSTII_With}
  7082. {$ENDIF}
  7083. //-------------------------------------------------------
  7084. // Found an identifier
  7085. //-------------------------------------------------------
  7086.       CSTII_Inherited,
  7087.         CSTI_OpenRound,
  7088.         CSTI_Identifier: begin
  7089.           if ExecRunLine then
  7090.           begin
  7091.             Dec(FBeginNesting);
  7092.             exit;
  7093.           end;
  7094.           case GetIdentifier(WithList, Vars, 0, C) of
  7095.             0: begin
  7096.                 Dec(FBeginNesting);
  7097.                 exit;
  7098.               end;
  7099.             1: begin
  7100.                 if (C^.Flags and 1) <> 0 then begin
  7101.                   RunError(Self, EVariableExpected);
  7102.                   Dec(FBeginNesting);
  7103.                   exit;
  7104.                 end;
  7105.                 if Parser.CurrTokenId <> CSTI_Assignment then begin
  7106.                   RunError(Self, EAssignmentExpected);
  7107.                   Dec(FBeginNesting);
  7108.                   exit;
  7109.                 end;
  7110.                 Parser.Next;
  7111. {$IFNDEF NOCLASSES}
  7112.                 if C^.VType^.atypeid = CSV_Property then begin
  7113.                   c2 := CreateCajVariant(TM_Add(Types, '', CSV_Var, nil));
  7114.                   if not calc(WithList, Vars, c2, CSTI_Semicolon, False) then begin
  7115.                     Dec(FBeginNesting);
  7116.                     exit;
  7117.                   end;
  7118.                   if not SetProperty(C, c2) then begin
  7119.                     DestroyCajVariant(c2);
  7120.                     Dec(FBeginNesting);
  7121.                     exit;
  7122.                   end;
  7123.                   DestroyCajVariant(c2);
  7124.                 end else begin
  7125.                   if not calc(WithList, Vars, C, CSTI_Semicolon, False) then begin
  7126.                     Dec(FBeginNesting);
  7127.                     exit;
  7128.                   end;
  7129.                 end;
  7130. {$ELSE}
  7131.                 if not calc(WithList, Vars, C, CSTI_Semicolon, False) then begin
  7132.                   Dec(FBeginNesting);
  7133.                   exit;
  7134.                 end;
  7135. {$ENDIF}
  7136.               end;
  7137.             2: begin
  7138. {$IFNDEF NOCLASSES}
  7139.                 if assigned(C) and (C^.VType^.atypeid = CSV_ExternalObjectProperty) then begin
  7140.                   if Parser.CurrTokenId <> CSTI_Assignment then begin
  7141.                     DestroyCajVariant(C);
  7142.                     RunError(Self, EAssignmentExpected);
  7143.                     Dec(FBeginNesting);
  7144.                     exit;
  7145.                   end;
  7146.                   Parser.Next;
  7147.                   if (not assigned(C^.CV_ExtObj)) or (PCreatedCustomObject(C^.CV_ExtObj)^.AlreadyFreed) then begin
  7148.                     DestroyCajVariant(C);
  7149.                     Dec(FBeginNesting);
  7150.                     RunError(Self, EClassNotCreated);
  7151.                     exit;
  7152.                   end;
  7153.                   c2 := CreateCajVariant(PCreatedCustomObject(C^.CV_ExtObj)^.p.GetPropertyType(C^.CV_PropertyNo));
  7154.                   if not calc(WithList, Vars, c2, CSTI_Semicolon, False) then begin
  7155.                     DestroyCajVariant(C);
  7156.                     Dec(FBeginNesting);
  7157.                     exit;
  7158.                   end;
  7159.                   if not PCreatedCustomObject(C^.CV_ExtObj)^.p.SetProperty(C^.CV_PropertyNo, c2) then begin
  7160.                     DestroyCajVariant(C);
  7161.                     DestroyCajVariant(c2);
  7162.                     Dec(FBeginNesting);
  7163.                     exit;
  7164.                   end;
  7165.                   DestroyCajVariant(c2);
  7166.                   DestroyCajVariant(C);
  7167.                 end else {$ENDIF}
  7168.                   DestroyCajVariant(C);
  7169.               end;
  7170.           end;
  7171.         end; {CSTI_Identifier}
  7172.     else begin
  7173.         RunError(Self, EErrorInStatement);
  7174.         Dec(FBeginNesting);
  7175.         exit;
  7176.       end; {Else case}
  7177.     end; {Case}
  7178.   end; {While}
  7179.   RunBegin := True;
  7180.   Dec(FBeginNesting);
  7181. end; {RunBegin}
  7182. {$IFNDEF NOCLASSES}
  7183.  
  7184. function TObjProc(Sender: TIfPasScript; ScriptID: Pointer; proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
  7185. var
  7186.   Self: PIfVariant;
  7187.   nn: PVariableManager;
  7188.   p: PProcedure;
  7189.   PT: PTypeRec;
  7190.   s: string;
  7191. begin
  7192.   Self := GetVarLink(Vm_Get(Params, 0));
  7193.   if proc^.Name = '!CLASSNAME' then begin
  7194.     SetString(res, Self^.CV_Class^.ClassType^.Ident);
  7195.   end else if proc^.Name = '!CLASSNAMEIS' then begin
  7196.     s := FastUppercase(GetString(GetVarLink(Vm_Get(Params, 1))));
  7197.     PT := Self^.CV_Class^.ClassType;
  7198.     SetBoolean(res, False);
  7199.     while assigned(PT) do begin
  7200.       if PT^.Ident = s then begin
  7201.         SetBoolean(res, True);
  7202.         break;
  7203.       end;
  7204.       PT := PIFSClassType(PT^.Ext)^.InheritsFrom;
  7205.     end;
  7206.   end else if proc^.Name = '!GETANCESTORS' then begin
  7207.     PT := Self^.CV_Class^.ClassType;
  7208.     s := PT^.Ident;
  7209.     PT := PIFSClassType(PT^.Ext)^.InheritsFrom;
  7210.     while assigned(PT) do begin
  7211.       s := PT.Ident + '.' + s;
  7212.       PT := PIFSClassType(PT^.Ext)^.InheritsFrom;
  7213.     end;
  7214.     SetString(res, s);
  7215.   end else if proc^.Name = '!CREATE' then begin
  7216.   end else if (proc^.Name = '!DESTROY') then begin
  7217.     if assigned(Self^.CV_Class) and not (Self^.CV_Class^.AlreadyFreed) then begin
  7218.       VM_Destroy(Self.CV_Class^.Variables);
  7219.       Self.CV_Class^.AlreadyFreed := True;
  7220.     end else begin
  7221.       if Self^.CV_Class^.AlreadyFreed then
  7222.         TObjProc := EClassAlreadyFreed
  7223.       else
  7224.         TObjProc := EClassNotCreated;
  7225.       exit;
  7226.     end;
  7227.   end else if proc^.Name = '!FREE' then begin
  7228.     GetClassProcedure(Self, Sender.GetType('TObject')^.Ext, 'DESTROY', p, True);
  7229.     nn := VM_Create;
  7230.     Vm_Add(nn, Self, 'SELF');
  7231.     DestroyCajVariant(Sender.RunScriptProc(p, nn));
  7232.     VM_Delete(nn, 0);
  7233.     VM_Destroy(nn);
  7234.     if Sender.ErrorCode <> 0 then begin
  7235.       TObjProc := Sender.ErrorCode;
  7236.       exit;
  7237.     end;
  7238.   end;
  7239.   TObjProc := ENoError;
  7240. end;
  7241. {$ENDIF}
  7242.  
  7243. function Trim(s: string): string;
  7244. begin
  7245.   while (Length(s) > 0) and (s[1] = ' ') do
  7246.     Delete(s, 1, 1);
  7247.   while (Length(s) > 0) and (s[Length(s)] = ' ') do
  7248.     Delete(s, Length(s), 1);
  7249.   Trim := s;
  7250. end;
  7251.  
  7252. function ExProc(Sender: TIfPasScript; ScriptID: Pointer; proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
  7253. var
  7254.   I: Word;
  7255. begin
  7256.   if proc^.Name = 'GETLASTERRORCODE' then begin
  7257.     SetInteger(res, Sender.FLastException.ErrorCode);
  7258.   end else if proc^.Name = 'GETLASTERRORPOSITION' then begin
  7259.     SetInteger(res, Sender.FLastException.ErrorPosition);
  7260.   end else if proc^.Name = 'GETLASTERRORPARAM' then begin
  7261.     SetString(res, Sender.FLastException.ErrorParam);
  7262.   end else if proc^.Name = 'GETLASTERRORMODULE' then begin
  7263.     SetString(res, Sender.FLastException.ErrorModule);
  7264.   end else if proc^.Name = 'GETLASTERRORASSTRING' then begin
  7265.     SetString(res, ErrorToString(Sender.FLastException.ErrorCode, Sender.FLastException.ErrorParam));
  7266.   end else if proc^.Name = 'RAISEERROR' then begin
  7267.     I := GetInteger(Vm_Get(Params, 0));
  7268.     if I < ERuntimeError then
  7269.       I := ECustomError;
  7270.     Sender.RunError2(Sender, I, GetString(Vm_Get(Params, 1)));
  7271.     Result := I;
  7272.     exit;
  7273.   end;
  7274.   Result := ENoError;
  7275. end;
  7276.  
  7277. function StdProc(Sender: TIfPasScript; ScriptID: Pointer; proc: PProcedure; Params: PVariableManager; res: PIfVariant): TIfPasScriptError;
  7278. var
  7279.   C: PIfVariant;
  7280.   i1, I2: Longint;
  7281.   cStr: string;
  7282.   x: PPointerList;
  7283.  
  7284.   function mkchr(C: PIfVariant): Integer;
  7285.   begin
  7286.     if C^.VType^.atypeid = CSV_String then begin
  7287.       if Length(C^.Cv_Str) = 1 then begin
  7288.         mkchr := Ord(C^.Cv_Str[1]);
  7289.       end else
  7290.         mkchr := -1;
  7291.     end else begin
  7292.       mkchr := Ord(C^.Cv_Char);
  7293.     end;
  7294.   end;
  7295. begin
  7296.   StdProc := ENoError;
  7297.   if proc^.Name = 'SETLENGTH' then begin
  7298.     C := GetVarLink(Vm_Get(Params, 0));
  7299.     SetLength(C^.Cv_Str, GetInteger(Vm_Get(Params, 1)));
  7300.   end else if proc^.Name = 'ASSIGNED' then begin
  7301.     C := GetVarLink(Vm_Get(Params, 0));
  7302.     case C^.VType.atypeid of
  7303. {$IFNDEF NOCLASSES}
  7304.       CSV_Class: SetBoolean(res, assigned(C^.CV_Class) and (not C^.CV_Class^.AlreadyFreed));
  7305.       CSV_ClassRef: SetBoolean(res, assigned(C^.Cv_ClassRef));
  7306.       CSV_ExternalObject: SetBoolean(res, assigned(C^.CV_ExternalObject));
  7307. {$ENDIF}
  7308.       CSV_ProcVariable: SetBoolean(res, assigned(C^.Cv_Proc));
  7309.       CSV_Variant: SetBoolean(res, assigned(C^.CV_Variant));
  7310.     else
  7311.       StdProc := ETypeMismatch;
  7312.     end;
  7313.   end else
  7314.     if proc^.Name = 'GETTYPE' then begin
  7315.       C := GetVarLink(Vm_Get(Params, 0));
  7316.       if C^.VType.Ident <> '' then
  7317.         SetString(res, C^.VType.Ident)
  7318.       else
  7319.         SetString(res, 'VAR');
  7320.     end else if proc^.Name = 'STRGET' then begin
  7321.       C := GetVarLink(Vm_Get(Params, 0));
  7322.       i1 := GetInteger(GetVarLink(Vm_Get(Params, 1)));
  7323.       if (i1 < 1) or (i1 > Length(C^.Cv_Str)) then begin
  7324.         StdProc := EOutOfRange;
  7325.         exit;
  7326.       end;
  7327.       res^.Cv_Char := C^.Cv_Str[i1];
  7328.     end else if proc^.Name = 'STRSET' then begin
  7329.       C := GetVarLink(Vm_Get(Params, 2));
  7330.       i1 := GetInteger(GetVarLink(Vm_Get(Params, 1)));
  7331.       if (i1 < 1) or (i1 > Length(C^.Cv_Str)) then begin
  7332.         StdProc := EOutOfRange;
  7333.         exit;
  7334.       end;
  7335.       I2 := mkchr(GetVarLink(Vm_Get(Params, 0)));
  7336.       if I2 = -1 then begin
  7337.         StdProc := EOutOfRange;
  7338.         exit;
  7339.       end;
  7340.       C^.Cv_Str[i1] := Chr(I2);
  7341.     end else if proc^.Name = 'LOW' then begin
  7342.       C := GetVarLink(Vm_Get(Params, 0));
  7343.       if C^.VType^.atypeid = CSV_Enum then begin
  7344.         ChangeType(res, C^.VType)^.CV_Enum := 0;
  7345.       end else if C^.VType^.atypeid = CSV_Array then begin
  7346.         ChangeType(res, Sender.GetType('LONGINT'))^.Cv_SInt32 := 0;
  7347.       end else begin
  7348.         StdProc := ETypeMismatch;
  7349.         exit;
  7350.       end;
  7351.     end else if proc^.Name = 'HIGH' then begin
  7352.       C := GetVarLink(Vm_Get(Params, 0));
  7353.       if C^.VType^.atypeid = CSV_Enum then begin
  7354.         ChangeType(res, C^.VType)^.CV_Enum := Longint(C^.VType^.Ext);
  7355.       end else if C^.VType^.atypeid = CSV_Array then begin
  7356.         ChangeType(res, Sender.GetType('LONGINT'))^.Cv_SInt32 := Longint(C^.CV_ArrItems.Count) - 1;
  7357.       end else begin
  7358.         StdProc := ETypeMismatch;
  7359.         exit;
  7360.       end;
  7361.     end else if proc^.Name = 'PRED' then begin
  7362.       C := GetVarLink(Vm_Get(Params, 0));
  7363.       if C^.VType^.atypeid = CSV_Enum then begin
  7364.         if C^.CV_Enum = 0 then
  7365.         begin
  7366.           StdProc := EOutOfRange;
  7367.         end else
  7368.         ChangeType(res, C^.VType)^.CV_Enum := C^.CV_Enum - 1;
  7369.  
  7370.       end else begin
  7371.         StdProc := ETypeMismatch;
  7372.         exit;
  7373.       end;
  7374.     end else if proc^.Name = 'SUCC' then begin
  7375.       C := GetVarLink(Vm_Get(Params, 0));
  7376.       if C^.VType^.atypeid = CSV_Enum then begin
  7377.         if C^.CV_Enum = Longint(c^.VType^.Ext) -1 then
  7378.         begin
  7379.           StdProc := EOutOfRange;
  7380.         end else
  7381.         ChangeType(res, C^.VType)^.CV_Enum := C^.CV_Enum + 1;
  7382.       end else begin
  7383.         StdProc := ETypeMismatch;
  7384.         exit;
  7385.       end;
  7386.     end else if (proc^.Name = 'ORD') then begin
  7387.       C := GetVarLink(Vm_Get(Params, 0));
  7388.       if (C^.VType^.atypeid = CSV_Char) or (C^.VType^.atypeid = CSV_String) then begin
  7389.         i1 := mkchr(C);
  7390.         if i1 = -1 then begin
  7391.           StdProc := EOutOfRange;
  7392.           exit;
  7393.         end;
  7394.         ChangeType(res, Sender.GetType('LONGINT'));
  7395.         res^.Cv_SInt32 := i1;
  7396.       end else if (C^.VType^.atypeid = CSV_Enum) then begin
  7397.         ChangeType(res, Sender.GetType('LONGINT'));
  7398.         res^.Cv_SInt32 := C^.CV_Enum;
  7399.       end else begin
  7400.         StdProc := ETypeMismatch;
  7401.         exit;
  7402.       end;
  7403.     end else if proc^.Name = 'CHR' then begin
  7404.       res^.Cv_Char := Chr(GetInteger(GetVarLink(Vm_Get(Params, 0))));
  7405.     end else if proc^.Name = 'UPPERCASE' then begin
  7406.       SetString(res, FastUppercase(GetString(GetVarLink(Vm_Get(Params, 0)))));
  7407.     end else if proc^.Name = 'LOWERCASE' then begin
  7408.       SetString(res, FastLowercase(GetString(GetVarLink(Vm_Get(Params, 0)))));
  7409.     end else if proc^.Name = 'TRIM' then begin
  7410.       SetString(res, Trim(GetString(GetVarLink(Vm_Get(Params, 0)))));
  7411.     end else if (proc^.Name = 'POS') then begin
  7412.       SetInteger(res, Pos(GetString(GetVarLink(Vm_Get(Params, 0))),
  7413.         GetString(GetVarLink(Vm_Get(Params, 1)))));
  7414.     end else if proc^.Name = 'INTTOSTR' then begin
  7415.       SetString(res, inttostr(GetInteger(GetVarLink(Vm_Get(Params, 0)))));
  7416.     end else if proc^.Name = 'STRTOINT' then begin
  7417.       SetInteger(res, StrToIntDef(GetString(GetVarLink(Vm_Get(Params, 0))),
  7418.         GetInteger(GetVarLink(Vm_Get(Params, 1)))));
  7419.     end else if proc^.Name = 'COPY' then begin
  7420.       SetString(res, copy(GetString(GetVarLink(Vm_Get(Params, 0))),
  7421.         GetInteger(GetVarLink(Vm_Get(Params, 1))),
  7422.         GetInteger(GetVarLink(Vm_Get(Params, 2)))));
  7423.     end else if proc^.Name = 'LEFT' then begin
  7424.       SetString(res, copy(GetString(GetVarLink(Vm_Get(Params, 0))), 1,
  7425.         GetInteger(GetVarLink(Vm_Get(Params, 1)))));
  7426.     end else if proc^.Name = 'DELETE' then begin
  7427.       C := GetVarLink(Vm_Get(Params, 0));
  7428.       Delete(C^.Cv_Str, GetInteger(GetVarLink(Vm_Get(Params, 1))),
  7429.         GetInteger(GetVarLink(Vm_Get(Params, 2))));
  7430.     end else if proc^.Name = 'INSERT' then begin
  7431.       C := GetVarLink(Vm_Get(Params, 1));
  7432.       insert(GetString(GetVarLink(Vm_Get(Params, 0))), C^.Cv_Str,
  7433.         GetInteger(GetVarLink(Vm_Get(Params, 2))));
  7434.     end else if proc^.Name = 'SETARRAYLENGTH' then begin
  7435.       C := GetVarLink(Vm_Get(Params, 0));
  7436.       i1 := GetInteger(GetVarLink(Vm_Get(Params, 1)));
  7437.       if i1 > Sender.MaxArrayLength then begin
  7438.         StdProc := EOutOfMemoryError;
  7439.         exit;
  7440.       end;
  7441.       if i1 > Longint(C^.CV_ArrItems.Count) then begin
  7442.         i1 := i1 - Longint(C^.CV_ArrItems.Count);
  7443.         GetMem(x, i1 * sizeof(PIFVariant)); { i1 * 4 }
  7444.         for I2 := 0 to i1-1 do begin
  7445.           x[i2] := CreateCajVariant(C^.VType^.Ext);
  7446.         end;
  7447.         c^.CV_ArrItems.AddBlock(x, i1);
  7448.         FreeMem(x, i1 * Sizeof(PIFVariant)); 
  7449.       end else if i1 < Longint(C^.CV_ArrItems.Count) then begin
  7450.         for I2 := 1 to Longint(C^.CV_ArrItems.Count) - i1 do begin
  7451.           DestroyCajVariant(C^.CV_ArrItems.GetItem(C^.CV_ArrItems.Count - 1));
  7452.           C^.CV_ArrItems.Delete(C^.CV_ArrItems.Count - 1);
  7453.         end;
  7454.       end;
  7455.     end else if proc^.Name = 'GETARRAYLENGTH' then begin
  7456.       SetInteger(res, GetVarLink(Vm_Get(Params, 0))^.CV_ArrItems.Count);
  7457.     end else if proc^.Name = 'LENGTH' then begin
  7458.       SetInteger(res, Length(GetString(GetVarLink(Vm_Get(Params, 0)))));
  7459.     end else if proc^.Name = 'SIN' then begin
  7460.       SetReal(res, Sin(GetReal(GetVarLink(Vm_Get(Params, 0)))));
  7461.     end else if proc^.Name = 'COS' then begin
  7462.       SetReal(res, Cos(GetReal(GetVarLink(Vm_Get(Params, 0)))));
  7463.     end else if proc^.Name = 'TAN' then begin
  7464.       SetReal(res, Sin(GetReal(GetVarLink(Vm_Get(Params, 0)))) / Cos(GetReal(GetVarLink(Vm_Get(Params, 0)))));
  7465.     end else if proc^.Name = 'SQRT' then begin
  7466.       SetReal(res, Sqrt(GetReal(GetVarLink(Vm_Get(Params, 0)))));
  7467.     end else if proc^.Name = 'PI' then begin
  7468.       SetReal(res, pi);
  7469.     end else if proc^.Name = 'ROUND' then begin
  7470.       SetInteger(res, Round(GetReal(GetVarLink(Vm_Get(Params, 0)))));
  7471.     end else if proc^.Name = 'TRUNC' then begin
  7472.       SetInteger(res, Trunc(GetReal(GetVarLink(Vm_Get(Params, 0)))));
  7473.     end else if proc^.Name = 'INT' then begin
  7474.       SetInteger(res, Trunc(GetReal(GetVarLink(Vm_Get(Params, 0))) + 0.5));
  7475.     end else if proc^.Name = 'ABS' then begin
  7476.       SetReal(res, Abs(GetReal(GetVarLink(Vm_Get(Params, 0)))));
  7477.     end else if proc^.Name = 'SQRT' then begin
  7478.       SetReal(res, Sqrt(GetReal(GetVarLink(Vm_Get(Params, 0)))));
  7479.     end else if proc^.Name = 'FLOATTOSTR' then begin
  7480.       SetString(res, FloatToStr(GetReal(GetVarLink(Vm_Get(Params, 0)))));
  7481.     end else if proc^.Name = 'PADZ' then begin
  7482.       SetString(res, Padz(GetString(GetVarLink(Vm_Get(Params, 0))),
  7483.         GetInteger(GetVarLink(Vm_Get(Params, 1)))));
  7484.     end else if proc^.Name = 'PADL' then begin
  7485.       SetString(res, Padl(GetString(GetVarLink(Vm_Get(Params, 0))),
  7486.         GetInteger(GetVarLink(Vm_Get(Params, 1)))));
  7487.     end else if proc^.Name = 'PADR' then begin
  7488.       SetString(res, Padr(GetString(GetVarLink(Vm_Get(Params, 0))),
  7489.         GetInteger(GetVarLink(Vm_Get(Params, 1)))));
  7490.     end else if proc^.Name = 'VERSION' then begin
  7491.       SetString(res, Version);
  7492.     end else if (proc^.Name = 'REPLICATE') or (proc^.Name = 'STRINGOFCHAR') then begin
  7493.       cStr := GetString(GetVarLink(Vm_Get(Params, 0)));
  7494.       SetString(res, StringOfChar(cStr[1],
  7495.         GetInteger(GetVarLink(Vm_Get(Params, 1)))));
  7496.  
  7497.     end;
  7498.  
  7499. end;
  7500.  
  7501.  
  7502. procedure TIfPasScript.Cleanup;
  7503. var
  7504.   p: PResourceData;
  7505. {$IFNDEF NOCLASSES}
  7506.   p1: PCreatedClass;
  7507. {$ENDIF}
  7508.   I: Integer;
  7509. begin
  7510.   FLastException.ErrorCode := 0;
  7511.   for I := 0 to VM_Count(Variables) - 1 do begin
  7512.     ChangeType(Vm_Get(Variables, I), Vm_Get(Variables, I)^.VType);
  7513.   end;
  7514.   FBeginNesting := 0;
  7515.   for I := 0 to Longint(FAttachedOnes.Count) - 1 do begin
  7516.     if TIfPasScript(FAttachedOnes.GetItem(I)).FFreeOnCleanup then
  7517.       TIfPasScript(FAttachedOnes.GetItem(I)).Free;
  7518.   end;
  7519.   FAttachedOnes.Clear;
  7520.   for I := Longint(FAllocatedResources.Count) - 1 downto 0 do begin
  7521.     p := FAllocatedResources.GetItem(I);
  7522.     p.FreeProc(fId, p.Data);
  7523.     Dispose(p);
  7524.   end;
  7525.   FAllocatedResources.Clear;
  7526. {$IFNDEF NOCLASSES}
  7527.   for I := 0 to Longint(CreatedClasses.Count) - 1 do begin
  7528.     p1 := CreatedClasses.GetItem(I);
  7529.     if not p1^.AlreadyFreed then begin
  7530.       VM_Destroy(p1^.Variables);
  7531.     end;
  7532.     Dispose(p1);
  7533.   end;
  7534.   CreatedClasses.Clear;
  7535. {$ENDIF}
  7536. end;
  7537.  
  7538. //
  7539. //  Purpose: Adds a pointer to a needed resource
  7540. //
  7541. //-------------------------------------------------------------------
  7542.  
  7543. procedure TIfPasScript.AddResource(FreeProc: TResourceFree; Data: Pointer);
  7544. var
  7545.   p: PResourceData;
  7546. begin
  7547.   New(p);
  7548.   p^.Data := Data;
  7549.   p^.FreeProc := FreeProc;
  7550.   FAllocatedResources.Add(p);
  7551. end;
  7552.  
  7553. function TIfPasScript.FindResource(FreeProc: TResourceFree): Pointer;
  7554. var
  7555.   I: Longint;
  7556.   p: PResourceData;
  7557. begin
  7558.   for I := Longint(FAllocatedResources.Count) - 1 downto 0 do begin
  7559.     p := FAllocatedResources.GetItem(I);
  7560.     if @p^.FreeProc = @FreeProc then begin
  7561.       FindResource := p^.Data;
  7562.       exit;
  7563.     end;
  7564.   end;
  7565.   FindResource := nil;
  7566. end;
  7567.  
  7568. //
  7569. //  Purpose: Removes a resource pointer and cleans up the memory
  7570. //
  7571. //-------------------------------------------------------------------
  7572.  
  7573. procedure TIfPasScript.RemoveResource(Data: Pointer);
  7574. var
  7575.   I: Longint;
  7576.   p: PResourceData;
  7577. begin
  7578.   for I := Longint(FAllocatedResources.Count) - 1 downto 0 do begin
  7579.     p := FAllocatedResources.GetItem(I);
  7580.     if p^.Data = Data then begin
  7581.       FAllocatedResources.Delete(I);
  7582.       Dispose(p);
  7583.       break;
  7584.     end;
  7585.   end;
  7586. end;
  7587.  
  7588. //-------------------------------------------------------------------
  7589.  
  7590. function TIfPasScript.IsValidResource(FreeProc: TResourceFree; Data: Pointer): Boolean;
  7591. var
  7592.   I: Longint;
  7593.   p: PResourceData;
  7594. begin
  7595.   IsValidResource := True;
  7596.  
  7597.   for I := Longint(FAllocatedResources.Count) - 1 downto 0 do begin
  7598.     p := FAllocatedResources.GetItem(I);
  7599.     if (p^.Data = Data) and (@p^.FreeProc = @FreeProc)
  7600.       then exit;
  7601.   end;
  7602.   IsValidResource := False;
  7603. end;
  7604.  
  7605. function TIfPasScript.GetVariable(const Name: string): PIfVariant;
  7606. begin
  7607.   GetVariable := Vm_Get(Variables, VM_Find(Variables, FastUppercase(Name)));
  7608. end;
  7609.  
  7610. function TIfPasScript.AddVariable(Name, FType: string; Constant: Boolean): PIfVariant;
  7611. var
  7612.   Parser: TIfPascalParser;
  7613.   ptype: PTypeRec;
  7614.   p: PIfVariant;
  7615.   E: TIFPARSERERROR;
  7616. begin
  7617.   Name := FastUppercase(Name);
  7618.   Parser := TIfPascalParser.Create;
  7619.   if not Parser.SetText(FType, E) then begin
  7620.     AddVariable := nil;
  7621.     Parser.Free;
  7622.     exit;
  7623.   end;
  7624.   Parser.CurrTokenPos := 0;
  7625.   ptype := ReadType(Parser, False, '');
  7626.   if ptype = nil then begin
  7627.     AddVariable := nil;
  7628.     RunError(Self, 0);
  7629.   end else begin
  7630.     if Constant then begin
  7631.       p := Vm_Add(Variables, CreateCajVariant(ptype), Name);
  7632.       p^.Flags := 1;
  7633.       AddVariable := p;
  7634.     end else
  7635.       AddVariable := Vm_Add(Variables, CreateCajVariant(ptype), Name);
  7636.   end;
  7637.   Parser.Free;
  7638. end;
  7639.  
  7640. function TIfPasScript.RemoveFunction(d: PProcedure): Boolean;
  7641. var
  7642.   I: Longint;
  7643. begin
  7644.   for I := Longint(Procedures.Count) - 1 downto 0 do begin
  7645.     if Procedures.GetItem(I) = d then begin
  7646.       Procedures.Delete(I);
  7647.       RemoveFunction := True;
  7648.       exit;
  7649.     end;
  7650.   end;
  7651.   RemoveFunction := False;
  7652. end;
  7653.  
  7654. function TIfPasScript.AddClassFunction(Proc: TRegisteredProcObject; Decl: string; Ext: Pointer): PProcedure;
  7655. var
  7656.   tmp: PProcedure;
  7657. begin
  7658.   tmp := AddFunction(nil, Decl, Ext);
  7659.   Result := tmp;
  7660.   if tmp <> nil then tmp^.Proc2 := Proc;
  7661. end;
  7662.  
  7663. function TIfPasScript.AddFunction(proc: Pointer; Decl: string; Ext: Pointer): PProcedure;
  7664. var
  7665.   Parser: TIfPascalParser;
  7666.   CurrVar: string;
  7667.   FuncName,
  7668.     FuncParam: string;
  7669.   FuncRes,
  7670.     CurrType: Longint;
  7671.   E: TIFPARSERERROR;
  7672.  
  7673. begin
  7674.   Parser := TIfPascalParser.Create;
  7675.   AddFunction := nil;
  7676.   if not Parser.SetText(Decl, E) then begin
  7677.     Parser.Free;
  7678.     exit;
  7679.   end;
  7680.   if Parser.CurrTokenId = CSTII_Procedure then
  7681.     FuncRes := 0
  7682.   else
  7683.     FuncRes := 1;
  7684.   Parser.Next;
  7685.   FuncName := Parser.GetToken;
  7686.   Parser.Next;
  7687.   FuncParam := '';
  7688.   CurrVar := '';
  7689.   if Parser.CurrTokenId = CSTI_OpenRound then begin
  7690.     Parser.Next;
  7691.     while True do begin
  7692.       if Parser.CurrTokenId = CSTII_Var then begin
  7693.         CurrVar := '!';
  7694.         Parser.Next;
  7695.       end else {if}
  7696.         if Parser.CurrTokenId = CSTII_Const then begin
  7697.           CurrVar := '^';
  7698.           Parser.Next;
  7699.         end; {if}
  7700.       while True do begin
  7701.         if Parser.CurrTokenId <> CSTI_Identifier then begin
  7702.           Parser.Free;
  7703.           exit;
  7704.         end;
  7705.         CurrVar := CurrVar + Parser.GetToken + '|';
  7706.         Parser.Next;
  7707.         if Parser.CurrTokenId = CSTI_Colon then break;
  7708.         if Parser.CurrTokenId <> CSTI_Comma then begin
  7709.           Parser.Free;
  7710.           exit;
  7711.         end;
  7712.         Parser.Next;
  7713.       end; {while}
  7714.       Parser.Next;
  7715.  
  7716.       CurrType := Longint(ReadType(Parser, False, ''));
  7717.       if Pos('!', CurrVar) = 1 then begin
  7718.         Delete(CurrVar, 1, 1);
  7719.         while Pos('|', CurrVar) > 0 do begin
  7720.           FuncParam := FuncParam + ' !' + copy(CurrVar, 1, Pos('|', CurrVar) - 1) + ' ' + inttostr(CurrType);
  7721.           Delete(CurrVar, 1, Pos('|', CurrVar));
  7722.         end; {while}
  7723.       end else if Pos('^', CurrVar) = 1 then begin
  7724.         Delete(CurrVar, 1, 1);
  7725.         while Pos('|', CurrVar) > 0 do begin
  7726.           FuncParam := FuncParam + ' ^' + copy(CurrVar, 1, Pos('|', CurrVar) - 1) + ' ' + inttostr(CurrType);
  7727.           Delete(CurrVar, 1, Pos('|', CurrVar));
  7728.         end; {while}
  7729.       end else begin
  7730.         while Pos('|', CurrVar) > 0 do begin
  7731.           FuncParam := FuncParam + ' ' + copy(CurrVar, 1, Pos('|', CurrVar) - 1) + ' ' + inttostr(CurrType);
  7732.           Delete(CurrVar, 1, Pos('|', CurrVar));
  7733.         end; {while}
  7734.       end; {if}
  7735.       if Parser.CurrTokenId = CSTI_CloseRound then begin
  7736.         Parser.Next;
  7737.         break;
  7738.       end; {if}
  7739.       Parser.Next;
  7740.     end;
  7741.   end;
  7742.   if FuncRes = 1 then begin
  7743.     Parser.Next;
  7744.     FuncRes := Longint(ReadType(Parser, False, ''));
  7745.   end;
  7746.   FuncParam := inttostr(FuncRes) + FuncParam;
  7747.   AddFunction := PM_AddExt(Procedures, Self, FuncName, FuncParam, {$IFNDEF NOCLASSES}nil, {$ENDIF}Ext, proc);
  7748.   Parser.Free;
  7749. end;
  7750.  
  7751. function TIfPasScript.CreateReal(const E: Extended): PIfVariant;
  7752. var
  7753.   p: PIfVariant;
  7754. begin
  7755.   p := CreateCajVariant(TM_Add(Types, '', CSV_Extended, nil));
  7756.   p^.Cv_Extended := E;
  7757.   CreateReal := p;
  7758. end;
  7759.  
  7760. function TIfPasScript.CreateString(const s: string): PIfVariant;
  7761. var
  7762.   p: PIfVariant;
  7763. begin
  7764.   p := CreateCajVariant(TM_Add(Types, '', CSV_String, nil));
  7765.   p^.Cv_Str := s;
  7766.   CreateString := p;
  7767. end;
  7768.  
  7769. function TIfPasScript.CreateVarType(p: PIfVariant): PIfVariant;
  7770. var
  7771.   n: PIfVariant;
  7772. begin
  7773.   n := CreateCajVariant(TM_Add(Types, '', CSV_Var, nil));
  7774.   n^.CV_Var := GetVarLink(p);
  7775.   CreateVarType := n;
  7776. end;
  7777.  
  7778. function TIfPasScript.CreateInteger(I: Longint): PIfVariant;
  7779. var
  7780.   p: PIfVariant;
  7781. begin
  7782.   p := CreateCajVariant(TM_Add(Types, '', CSV_SInt32, nil));
  7783.   p^.Cv_SInt32 := I;
  7784.   CreateInteger := p;
  7785. end;
  7786.  
  7787. function TIfPasScript.CreateBool(b: Boolean): PIfVariant;
  7788. var
  7789.   p: PIfVariant;
  7790. begin
  7791.   p := CreateCajVariant(TM_Add(Types, '', CSV_Bool, nil));
  7792.   p^.Cv_Bool := b;
  7793.   CreateBool := p;
  7794. end;
  7795.  
  7796. //
  7797. //  Purpose: Adds various internal function calls
  7798. //
  7799. //-------------------------------------------------------------------
  7800.  
  7801. procedure RegisterExceptionLib(Sender: TIfPasScript);
  7802.  
  7803. begin
  7804.   Sender.AddFunction(@ExProc, 'function GetLastErrorCode: word;', nil);
  7805.   Sender.AddFunction(@ExProc, 'function GetLastErrorParam: string;', nil);
  7806.   Sender.AddFunction(@ExProc, 'function GetLastErrorModule: string;', nil);
  7807.   Sender.AddFunction(@ExProc, 'function GetLastErrorAsString: string;', nil);
  7808.   Sender.AddFunction(@ExProc, 'procedure RaiseError(ErrorCode: Word; Param: string);', nil);
  7809.   Sender.AddFunction(@ExProc, 'function GetLastErrorPosition: Longint;', nil);
  7810.  
  7811. end;
  7812. //
  7813. //  Purpose: Adds various internal function calls
  7814. //
  7815. //-------------------------------------------------------------------
  7816.  
  7817. procedure RegisterStdLib(p: TIfPasScript; OnlySafe: Boolean);
  7818. {Register standard library}
  7819. begin
  7820.   p.AddFunction(@StdProc, 'function StrGet(var s: string; I: Longint): char', nil);
  7821.   p.AddFunction(@StdProc, 'procedure StrSet(c: char; i: Longint; var s: string): char', nil);
  7822.   p.AddFunction(@StdProc, 'function Chr(b: Byte): Char', nil);
  7823.   p.AddFunction(@StdProc, 'function StrToInt(s: string; I: Longint): Integer', nil);
  7824.   p.AddFunction(@StdProc, 'function IntToStr(i: Longint): string', nil);
  7825.   p.AddFunction(@StdProc, 'function Uppercase(s: string): string', nil);
  7826.   p.AddFunction(@StdProc, 'function Copy(s: string; i1, i2: Longint): string', nil);
  7827.   p.AddFunction(@StdProc, 'procedure Delete(var s: string; i1,i2: Longint)', nil);
  7828.   p.AddFunction(@StdProc, 'procedure Insert(s1: string; var s: string; i1: Longint)', nil);
  7829.   p.AddFunction(@StdProc, 'function Pos(s1, s2: string): Longint', nil);
  7830.   p.AddFunction(@StdProc, 'function Length(s: string): Longint', nil);
  7831.   p.AddFunction(@StdProc, 'function LowerCase(s: string): string', nil);
  7832.   p.AddFunction(@StdProc, 'function Trim(s: string): string', nil);
  7833.   p.AddFunction(@StdProc, 'function Int(s: Extended): Longint', nil);
  7834.   p.AddFunction(@StdProc, 'function FloatToStr(s: Extended): string', nil);
  7835.   p.AddFunction(@StdProc, 'function replicate(s: string; i: Longint): string', nil);
  7836.   p.AddFunction(@StdProc, 'function Version: string', nil);
  7837.   p.AddFunction(@StdProc, 'function Left(s: string; i: Longint): string', nil);
  7838.   p.AddFunction(@StdProc, 'function StringOfChar(s: string; i: Integer): string', nil);
  7839.   p.AddFunction(@StdProc, 'procedure SetLength(var S: String; L: Longint);', nil);
  7840.   p.Addfunction(@StdProc, 'function abs(s: extended): extended;', nil);
  7841.   PM_AddExt(p.Procedures, p, 'GETTYPE', inttostr(Longint(TM_Get(p.Types, 'STRING'))) + ' MYVAR ' + inttostr(Longint(TM_Get(p.Types, '!VAR'))), {$IFNDEF NOCLASSES}nil, {$ENDIF}nil, @StdProc);
  7842.   PM_AddExt(p.Procedures, p, 'GETARRAYLENGTH', inttostr(Longint(TM_Get(p.Types, 'LONGINT'))) + ' !ARR ' + inttostr(Longint(TM_Get(p.Types, '!ARRAY'))), {$IFNDEF NOCLASSES}nil, {$ENDIF}nil, @StdProc);
  7843.   PM_AddExt(p.Procedures, p, 'SETARRAYLENGTH', '0 !ARR ' + inttostr(Longint(TM_Get(p.Types, '!ARRAY'))) + ' NEWLEN ' + inttostr(Longint(TM_Get(p.Types, 'LONGINT'))), {$IFNDEF NOCLASSES}nil, {$ENDIF}nil, @StdProc);
  7844.   PM_AddExt(p.Procedures, p, 'ASSIGNED', inttostr(Longint(TM_Get(p.Types, 'BOOLEAN'))) + ' MYVAR ' + inttostr(Longint(TM_Get(p.Types, '!VAR'))), {$IFNDEF NOCLASSES}nil, {$ENDIF}nil, @StdProc);
  7845.  
  7846.   PM_AddExt(p.Procedures, p, 'LOW', inttostr(Longint(TM_Get(p.Types, '!VAR'))) + ' ^ARR ' + inttostr(Longint(TM_Get(p.Types, '!VAR'))), {$IFNDEF NOCLASSES}nil, {$ENDIF}nil, @StdProc);
  7847.   PM_AddExt(p.Procedures, p, 'HIGH', inttostr(Longint(TM_Get(p.Types, '!VAR'))) + ' ^ARR ' + inttostr(Longint(TM_Get(p.Types, '!VAR'))), {$IFNDEF NOCLASSES}nil, {$ENDIF}nil, @StdProc);
  7848.   PM_AddExt(p.Procedures, p, 'ORD', inttostr(Longint(TM_Get(p.Types, 'LONGINT'))) + ' ARR ' + inttostr(Longint(TM_Get(p.Types, '!VAR'))), {$IFNDEF NOCLASSES}nil, {$ENDIF}nil, @StdProc);
  7849.   PM_AddExt(p.Procedures, p, 'PRED', inttostr(Longint(TM_Get(p.Types, '!VAR'))) + ' ARR ' + inttostr(Longint(TM_Get(p.Types, '!VAR'))), {$IFNDEF NOCLASSES}nil, {$ENDIF}nil, @StdProc);
  7850.   PM_AddExt(p.Procedures, p, 'SUCC', inttostr(Longint(TM_Get(p.Types, '!VAR'))) + ' ARR ' + inttostr(Longint(TM_Get(p.Types, '!VAR'))), {$IFNDEF NOCLASSES}nil, {$ENDIF}nil, @StdProc);
  7851.   if not OnlySafe then begin
  7852.     p.AddFunction(@StdProc, 'function sin(s: Extended): Extended', nil);
  7853.     p.AddFunction(@StdProc, 'function cos(s: Extended): Extended', nil);
  7854.     p.AddFunction(@StdProc, 'function tan(s: Extended): Extended', nil);
  7855.     p.AddFunction(@StdProc, 'function SQRT(s: Extended): Extended', nil);
  7856.     p.AddFunction(@StdProc, 'function Round(s: Extended): Longint', nil);
  7857.     p.AddFunction(@StdProc, 'function Trunc(s: Extended): Longint', nil);
  7858.     p.AddFunction(@StdProc, 'function PI: Extended', nil);
  7859.   end;
  7860. end;
  7861. //-------------------------------------------------------------------
  7862.  
  7863. procedure TIfPasScript.AddStandard;
  7864. var
  7865. {$IFNDEF NOCLASSES}
  7866.   TObjClass: PIFSClassType;
  7867.   n: PProcedure;
  7868. {$ENDIF}
  7869.   u: PTypeRec;
  7870. begin
  7871.   TM_Add(Types, 'BYTE', CSV_UByte, nil);
  7872.   TM_Add(Types, 'SHORTINT', CSV_SByte, nil);
  7873.   TM_Add(Types, 'CHAR', CSV_Char, nil);
  7874.   TM_Add(Types, 'WORD', CSV_UInt16, nil);
  7875.   TM_Add(Types, 'SMALLINT', CSV_SInt16, nil);
  7876.   TM_Add(Types, 'CARDINAL', CSV_UInt32, nil);
  7877.   u := TM_Add(Types, 'LONGINT', CSV_SInt32, nil);
  7878.   TM_Add(Types, 'INTEGER', CSV_TypeCopy, u);
  7879.   TM_Add(Types, 'STRING', CSV_String, nil);
  7880.   TM_Add(Types, 'REAL', CSV_Real, nil);
  7881.   TM_Add(Types, 'SINGLE', CSV_Single, nil);
  7882.   TM_Add(Types, 'DOUBLE', CSV_Double, nil);
  7883.   TM_Add(Types, 'EXTENDED', CSV_Extended, nil);
  7884.   TM_Add(Types, 'COMP', CSV_Comp, nil);
  7885.   TM_Add(Types, 'BOOLEAN', CSV_Bool, nil);
  7886.   TM_Add(Types, 'RESOURCEPOINTER', CSV_Internal, nil); // can be used for resources (See AddResource)
  7887.  
  7888.   TM_Add(Types, '!ARRAY', CSV_Array, nil); // only for internal use! (SetArrayLength; GetArrayLength)
  7889.   TM_Add(Types, '!VAR', CSV_Var, nil); // only for internal use! (GetType)
  7890. {$IFDEF VARIANTSUPPORT}
  7891.   TM_Add(Types, 'VARIANT', CSV_Variant, nil);
  7892. {$ENDIF}
  7893. {$IFNDEF NOCLASSES}
  7894.   New(TObjClass);
  7895.   TObjClass.InheritsFrom := nil;
  7896.   TObjClass.VarNoStart := 0;
  7897.   TObjClass.VarCount := 0;
  7898.   TObjClass.Variables.u := '';
  7899.   TObjClass.PropStart := 0;
  7900.   TObjClass.Procedures := TIfList.Create;
  7901.   TObjClass.Properties := TIfList.Create;
  7902.   u := TM_Add(Types, 'TOBJECT', CSV_Class, TObjClass);
  7903.   n := AddFunction(@TObjProc, 'procedure Create', TObjClass);
  7904.   n^.Flags := $40 or $2; {public Constructor}
  7905.   n^.Name := '!' + n^.Name;
  7906.   n^.ClassType := u;
  7907.   TObjClass.Procedures.Add(n);
  7908.   n := AddFunction(@TObjProc, 'procedure Destroy', TObjClass);
  7909.   n^.Flags := $80 or $10 or $2; {Public virtualstart destructor}
  7910.   n^.ClassType := u;
  7911.   n^.Name := '!' + n^.Name;
  7912.   TObjClass.Procedures.Add(n);
  7913.   n := AddFunction(@TObjProc, 'procedure Free', TObjClass);
  7914.   n^.Flags := $2; {Public}
  7915.   n^.ClassType := u;
  7916.   n^.Name := '!' + n^.Name;
  7917.   TObjClass.Procedures.Add(n);
  7918.   n := AddFunction(@TObjProc, 'function ClassNameIs(ftype: string): Boolean', TObjClass);
  7919.   n^.Flags := $2; {Public}
  7920.   n^.ClassType := u;
  7921.   n^.Name := '!' + n^.Name;
  7922.   TObjClass.Procedures.Add(n);
  7923.   n := AddFunction(@TObjProc, 'function ClassName: String', TObjClass);
  7924.   n^.Flags := $2; {Public}
  7925.   n^.ClassType := u;
  7926.   n^.Name := '!' + n^.Name;
  7927.   TObjClass.Procedures.Add(n);
  7928.   n := AddFunction(@TObjProc, 'function GetAncestors: string', TObjClass);
  7929.   n^.Flags := $2; {Public}
  7930.   n^.ClassType := u;
  7931.   n^.Name := '!' + n^.Name;
  7932.   TObjClass.Procedures.Add(n);
  7933. {$ENDIF}
  7934. end;
  7935. //-------------------------------------------------------------------
  7936.  
  7937. function TIfPasScript.GetFunction(s: string): PProcedure;
  7938. {$IFNDEF NOCLASSES}
  7939. var
  7940.   ptype: PTypeRec;
  7941.   p: PProcedure;
  7942. {$ENDIF}
  7943. begin
  7944. {$IFNDEF NOCLASSES}
  7945.   if Pos('.', s) > 0 then begin
  7946.     ptype := GetType(FastUppercase(copy(s, 1, Pos('.', s) - 1)));
  7947.     Delete(s, 1, Pos('.', s));
  7948.     if ptype^.atypeid = CSV_Class then begin
  7949.       if GetClassProcedure(nil, ptype^.Ext, FastUppercase(s), p, True) then
  7950.         GetFunction := p
  7951.       else
  7952.         GetFunction := nil;
  7953.     end else
  7954.       GetFunction := nil;
  7955.   end else begin
  7956. {$ENDIF}
  7957.     GetFunction := PM_Get(Procedures, PM_Find(Procedures, FastUppercase(s)));
  7958. {$IFNDEF NOCLASSES} end;
  7959. {$ENDIF}
  7960. end;
  7961. //-------------------------------------------------------------------
  7962.  
  7963. function TIfPasScript.CopyVariant(p: PIfVariant): PIfVariant;
  7964. var
  7965.   r: PIfVariant;
  7966. begin
  7967.   if p = nil then begin
  7968.     CopyVariant := nil;
  7969.     exit;
  7970.   end;
  7971. {$IFNDEF NOCLASSES}
  7972.   if p^.VType^.atypeid = CSV_Property then begin
  7973.     p := GetProperty(p);
  7974.     if p = nil then begin
  7975.       CopyVariant := nil;
  7976.       exit;
  7977.     end;
  7978.     CopyVariant := p;
  7979.   end else begin
  7980. {$ENDIF}
  7981.     r := CreateCajVariant(p^.VType);
  7982.     Perform(r, p, PtSet);
  7983.     CopyVariant := r;
  7984. {$IFNDEF NOCLASSES}
  7985.   end;
  7986. {$ENDIF}
  7987. end;
  7988. //-------------------------------------------------------------------
  7989. {$IFDEF VARIANTSUPPORT}
  7990.  
  7991. function TIfPasScript.VariantToIFVariant(const v: Variant; res: PIfVariant): Boolean;
  7992. var
  7993.   f: Word;
  7994.   I: Longint;
  7995.   l: PIfVariant;
  7996. begin
  7997.   f := VarType(v);
  7998.   VariantToIFVariant := True;
  7999.   if (f and varArray) = 0 then begin
  8000.     case f and varTypeMask of
  8001. {$IFDEF USEIDISPATCH}
  8002.       varDispatch: begin
  8003.           if assigned(IDispatchToIFVariantProc) then
  8004.             VariantToIFVariant := IDispatchToIFVariantProc(Self, res, v)
  8005.           else
  8006.             VariantToIFVariant := False;
  8007.         end;
  8008. {$ENDIF}
  8009.       varEmpty, varNull: ChangeType(res, TM_Add(Types, '', CSV_Special, nil))^.CV_Spec := 0; {nil}
  8010.       varSmallInt: ChangeType(res, TM_Add(Types, '', CSV_SInt16, nil))^.Cv_SInt16 := v;
  8011.       varInteger: ChangeType(res, TM_Add(Types, '', CSV_SInt32, nil))^.Cv_SInt32 := v;
  8012.       varSingle: ChangeType(res, TM_Add(Types, '', CSV_Single, nil))^.CV_Single := v;
  8013.       varDouble, VarDate: ChangeType(res, TM_Add(Types, '', CSV_Double, nil))^.CV_Double := v;
  8014.       varBoolean: ChangeType(res, TM_Add(Types, '', CSV_Bool, nil))^.Cv_Bool := v;
  8015.       varByte: ChangeType(res, TM_Add(Types, '', CSV_UByte, nil))^.Cv_UByte := v;
  8016.       varString: ChangeType(res, TM_Add(Types, '', CSV_String, nil))^.Cv_Str := v;
  8017.       varOleStr: ChangeType(res, TM_Add(Types, '', CSV_String, nil))^.Cv_Str := v;
  8018.     else begin
  8019.         VariantToIFVariant := False;
  8020.       end;
  8021.     end;
  8022.   end else begin
  8023.     if VarArrayDimCount(v) > 0 then begin
  8024.       VariantToIFVariant := False;
  8025.       exit;
  8026.     end;
  8027.     ChangeType(res, TM_Add(Types, '', CSV_Array, res^.VType));
  8028.     for I := VarArrayLowBound(v, 0) to VarArrayHighBound(v, 0) do begin
  8029.       l := CreateVarType(nil);
  8030.       res.CV_ArrItems.Add(l);
  8031.       if not VariantToIFVariant(v[I], l) then begin
  8032.         VariantToIFVariant := False;
  8033.         exit;
  8034.       end;
  8035.     end;
  8036.   end;
  8037. end;
  8038.  
  8039. function TIfPasScript.IfVariantToVariant(v: PIfVariant; var res: Variant): Boolean;
  8040. var
  8041.   I: Longint;
  8042.   q: Variant;
  8043. {$IFNDEF NOCLASSES}{$IFDEF USEIDISPATCH}n: IDispatch;
  8044. {$ENDIF}{$ENDIF}
  8045. begin
  8046.   if v = nil then begin
  8047.     res := null;
  8048.     IfVariantToVariant := True;
  8049.     exit;
  8050.   end;
  8051.   v := GetVarLink(v);
  8052.   res := Unassigned;
  8053.   IfVariantToVariant := True;
  8054.   if v^.VType^.atypeid = CSV_Variant then begin
  8055.     v := v^.CV_Variant;
  8056.   end;
  8057.   if v^.VType^.atypeid = CSV_Array then begin
  8058.     if (PTypeRec(v^.VType^.Ext)^.atypeid = CSV_Array) or (PTypeRec(v^.VType^.Ext)^.atypeid = CSV_Var) then begin
  8059.       IfVariantToVariant := False;
  8060.     end;
  8061.     res := VarArrayCreate([0, v^.CV_ArrItems.Count - 1], varVariant);
  8062.     for I := 0 to Longint(v^.CV_ArrItems.Count) - 1 do begin
  8063.       if IfVariantToVariant(v^.CV_ArrItems.GetItem(I), q) then
  8064.         res[I] := q
  8065.       else begin
  8066.         IFVariantToVariant := False;
  8067.         Res := Null;
  8068.       end;
  8069.     end;
  8070.   end else begin
  8071.     case v^.VType^.atypeid of
  8072.       CSV_Special: res := null;
  8073.       CSV_UByte: res := v^.Cv_UByte;
  8074.       CSV_SByte: res := v^.Cv_SByte;
  8075.       CSV_UInt16: res := v^.Cv_UInt16;
  8076.       CSV_SInt16: res := v^.Cv_SInt16;
  8077.       CSV_UInt32: res := Longint(v^.Cv_UInt32);
  8078.       CSV_SInt32: res := v^.Cv_SInt32;
  8079.       CSV_Char: res := v^.Cv_Char;
  8080.       CSV_String: res := v^.Cv_Str;
  8081.       CSV_Real: res := v^.CV_Real;
  8082.       CSV_Single: res := v^.CV_Single;
  8083.       CSV_Double: res := v^.CV_Double;
  8084.       CSV_Extended: res := v^.Cv_Extended;
  8085.       CSV_Comp: res := v^.CV_comp;
  8086.       CSV_Bool: res := v^.Cv_Bool;
  8087. {$IFNDEF NOCLASSES}
  8088. {$IFDEF USEIDISPATCH}
  8089.       CSV_ExternalObject: begin
  8090.           if assigned(IFVariantToIDispatchProc) then begin
  8091.             if IFVariantToIDispatchProc(Self, n, v) then
  8092.               res := n
  8093.             else
  8094.               IfVariantToVariant := False;
  8095.           end else
  8096.             IfVariantToVariant := False;
  8097.         end;
  8098. {$ENDIF}
  8099. {$ENDIF}
  8100.     else
  8101.       IfVariantToVariant := False;
  8102.     end;
  8103.   end;
  8104. end;
  8105.  
  8106. function TIfPasScript.CallFunction(p: PProcedure; Params: array of Variant): Variant;
  8107. var
  8108.   RealParams: PVariableManager;
  8109.   I: Longint;
  8110.   n: PIfVariant;
  8111.   a: Variant;
  8112. begin
  8113.   RunError(Self, 0);
  8114. {$IFNDEF NOCLASSES}
  8115.   if assigned(p^.ClassType) then begin // use CallMethod instead
  8116.     FError.ErrorCode := ETypeMismatch;
  8117.     FError.ErrorPosition := -1;
  8118.     exit;
  8119.   end;
  8120. {$ENDIF}
  8121.   CallFunction := null;
  8122.   RealParams := VM_Create;
  8123.   for I := Low(Params) to High(Params) do begin
  8124.     n := CreateVarType(nil);
  8125.     Vm_Add(RealParams, n, '');
  8126.     if not VariantToIFVariant(Params[I], n) then begin
  8127.       FError.ErrorCode := ETypeMismatch;
  8128.       FError.ErrorPosition := -1;
  8129.       VM_Destroy(RealParams);
  8130.       CallFunction := null;
  8131.       exit;
  8132.     end;
  8133.   end;
  8134.   n := RunScriptProc(p, RealParams);
  8135.   VM_Destroy(RealParams);
  8136.   IfVariantToVariant(n, a);
  8137.   DestroyCajVariant(n);
  8138.   CallFunction := a;
  8139. end;
  8140.  
  8141. //-------------------------------------------------------------------
  8142. {$IFNDEF NOCLASSES}
  8143.  
  8144. function TIfPasScript.CallMethod(p: PProcedure; Myself: PCreatedClass; Params: array of Variant): Variant;
  8145. var
  8146.   RealParams: PVariableManager;
  8147.   I: Longint;
  8148.   n: PIfVariant;
  8149.   a: Variant;
  8150. begin
  8151.   RunError(Self, 0);
  8152.   if not assigned(p^.ClassType) then begin // use CallFunction instead
  8153.     FError.ErrorCode := ETypeMismatch;
  8154.     FError.ErrorPosition := -1;
  8155.     exit;
  8156.   end;
  8157.   CallMethod := null;
  8158.   RealParams := VM_Create;
  8159.   n := CreateCajVariant(Myself^.ClassType);
  8160.   n^.CV_Class := Myself;
  8161.   Vm_Add(RealParams, n, 'SELF');
  8162.   for I := Low(Params) to High(Params) do begin
  8163.     n := CreateVarType(nil);
  8164.     Vm_Add(RealParams, n, '');
  8165.     if not VariantToIFVariant(Params[I], n) then begin
  8166.       FError.ErrorCode := ETypeMismatch;
  8167.       FError.ErrorPosition := -1;
  8168.       VM_Destroy(RealParams);
  8169.       CallMethod := null;
  8170.       exit;
  8171.     end;
  8172.   end;
  8173.   n := RunScriptProc(p, RealParams);
  8174.   VM_Destroy(RealParams);
  8175.   IfVariantToVariant(n, a);
  8176.   DestroyCajVariant(n);
  8177.   CallMethod := a;
  8178. end;
  8179.  
  8180. {$ENDIF}
  8181. {$ENDIF}
  8182.  
  8183. //-------------------------------------------------------------------
  8184.  
  8185. function TIfPasScript.Attach(ScriptEngine: TIfPasScript): Boolean;
  8186. begin
  8187.   Attach := Attach2(ScriptEngine, True);
  8188. end;
  8189.  
  8190. function TIfPasScript.Attach2(ScriptEngine: TIfPasScript; FreeOnCleanup: Boolean): Boolean;
  8191. var
  8192.   I: Longint;
  8193.   nt: PTypeRec;
  8194.   Nc: PIfVariant;
  8195.   np: PProcedure;
  8196. begin
  8197.   if (ScriptEngine = nil) or (ScriptEngine = Self) or (ScriptEngine.MainOffset = -1) or (not ScriptEngine.IsUnit) then begin
  8198.     Attach2 := False;
  8199.     exit;
  8200.   end;
  8201.   for I := 0 to Longint(FAttachedOnes.Count) - 1 do begin
  8202.     if FastUppercase(TIfPasScript(FAttachedOnes.GetItem(I)).ModuleName) = (ScriptEngine.ModuleName) then begin
  8203.       Attach2 := False;
  8204.       exit;
  8205.     end;
  8206.   end;
  8207.   ScriptEngine.FFreeOnCleanup := FreeOnCleanup;
  8208.   for I := 0 to Longint(ScriptEngine.Types.List.Count) - 1 do begin
  8209.     nt := ScriptEngine.Types.List.GetItem(I);
  8210.     TM_Add(Types, nt^.Ident, CSV_TypeCopy, nt);
  8211.   end;
  8212.   for I := 0 to VM_Count(ScriptEngine.Variables) - 1 do begin
  8213.     Nc := Vm_Get(ScriptEngine.Variables, I);
  8214.     if VM_Find(Variables, VM_GetName(ScriptEngine.Variables, I)) = -1 then begin
  8215.       Vm_Add(Variables, CreateVarType(Nc), VM_GetName(ScriptEngine.Variables, I));
  8216.     end;
  8217.   end;
  8218.   for I := 0 to Longint(ScriptEngine.Procedures.Count) - 1 do begin
  8219.     np := ScriptEngine.Procedures.GetItem(I);
  8220.     if np^.Mode = 0 then
  8221.       PM_AddInt(Procedures, np^.FScriptEngine, np^.Name, np^.Decl, {$IFNDEF NOCLASSES}np^.ClassType, {$ENDIF}np^._Ext, np^.offset)^.Flags := np^.Flags
  8222.     else
  8223.       PM_AddExt(Procedures, np^.FScriptEngine, np^.Name, np^.Decl, {$IFNDEF NOCLASSES}np^.ClassType, {$ENDIF}np^._Ext, @np^.proc1)^.Flags := np^.Flags;
  8224.   end;
  8225.   FAttachedOnes.Add(ScriptEngine);
  8226.   Attach2 := True;
  8227. end;
  8228. //-------------------------------------------------------------------
  8229.  
  8230. function TIfPasScript.GetType(const s: string): PTypeRec;
  8231. begin
  8232.   GetType := GetTypeLink(TM_Get(Types, FastUppercase(s)));
  8233. end;
  8234. //-------------------------------------------------------------------
  8235. {$IFNDEF NOCLASSES}
  8236.  
  8237. function GetInheritedProc(CurrProc: PProcedure): PProcedure;
  8238. var
  8239.   p: PIFSClassType;
  8240.   n: PProcedure;
  8241.   I: Integer;
  8242. begin
  8243.   p := PTypeRec(CurrProc^.ClassType)^.Ext;
  8244.   repeat
  8245.     p := p^.InheritsFrom^.Ext;
  8246.     for I := 0 to Longint(p^.Procedures.Count) - 1 do begin
  8247.       n := p^.Procedures.GetItem(I);
  8248.       if n^.Name = CurrProc^.Name then begin
  8249.         GetInheritedProc := n;
  8250.         exit;
  8251.       end;
  8252.     end;
  8253.   until p = nil;
  8254.   GetInheritedProc := nil;
  8255. end;
  8256. {$ENDIF}
  8257.  
  8258. function TIfPasScript.GetCurrProc: PProcedure;
  8259. begin
  8260.   if Longint(ProcStack.Count) > 0 then
  8261.     GetCurrProc := ProcStack.GetItem(ProcStack.Count -1)
  8262.   else
  8263.     GetCurrProc := nil;
  8264. end;
  8265.  
  8266. function TIfPasScript.PopProcStack: PProcedure;
  8267. begin
  8268.   if ProcStack.Count > 0 then
  8269.   begin
  8270.     PopProcStack := ProcStack.GetItem(ProcStack.Count -1);
  8271.     ProcStack.Delete(ProcStack.Count -1);
  8272.   end else
  8273.     PopProcStack := nil;
  8274. end;
  8275.  
  8276. function TIfPasScript.ExecRunLine: Boolean;
  8277. begin
  8278.   if @FOnRunLine <> nil then
  8279.   begin
  8280.     RunError(Self, FOnRunLine(fId, Self, Parser.CurrTokenPos));
  8281.     ExecRunLine := FError.ErrorCode <> ENoError;
  8282.   end else
  8283.    ExecRunLine := False;
  8284. end;
  8285.  
  8286.  
  8287. procedure SetArrayLength(FVar: PIFVariant; NewLength: Longint);
  8288. var
  8289.   i: Longint;
  8290.   x: PPointerList;
  8291.  
  8292. begin
  8293.   if (NewLength > Longint(FVar^.CV_ArrItems.Count)) then
  8294.   begin
  8295.     NewLength := NewLength - Longint(FVar^.CV_ArrItems.Count);
  8296.     GetMem(x, NewLength * sizeof(PIFVariant)); { i1 * 4 }
  8297.     for I := 0 to NewLength - 1 do begin
  8298.       x[I] := CreateCajVariant(FVar^.VType^.Ext);
  8299.     end;
  8300.     FVar^.CV_ArrItems.AddBlock(x, NewLength);
  8301.     FreeMem(x, NewLength * Sizeof(PIFVariant));
  8302.   end else if NewLength < Longint(FVar^.CV_ArrItems.Count) then
  8303.   begin
  8304.     for I := 1 to Longint(FVar^.CV_ArrItems.Count) - NewLength do
  8305.     begin
  8306.       DestroyCajVariant(FVar^.CV_ArrItems.GetItem(FVar^.CV_ArrItems.Count - 1));
  8307.       FVar^.CV_ArrItems.Delete(FVar^.CV_ArrItems.Count - 1);
  8308.     end;
  8309.   end;
  8310. end;
  8311.  
  8312. end.
  8313.  
  8314.