home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 October / Chip_2001-10_cd1.bin / zkuste / delphi / kolekce / d6 / FRCLX.ZIP / SOURCE / FR_Intrp.pas < prev    next >
Pascal/Delphi Source File  |  2001-07-01  |  19KB  |  827 lines
  1.  
  2. {******************************************}
  3. {                                          }
  4. {           FastReport CLX v2.4            }
  5. {               Interpreter                }
  6. {                                          }
  7. { Copyright (c) 1998-2001 by Tzyganenko A. }
  8. {                                          }
  9. {******************************************}
  10.  
  11. unit FR_Intrp;
  12.  
  13. interface
  14.  
  15. {$I FR.inc}
  16.  
  17. uses Classes, SysUtils, FR_Pars;
  18.  
  19. type
  20.  
  21. // This is a simple Pascal-like interpreter. Input code can contain
  22. // if-then-else, while-do, repeat-until, for, goto operators, begin-end blocks.
  23. // Code can also contain expressions, variables, functions and methods.
  24. // There is three events for handling variables and functions(methods):
  25. // GetValue, SetValue and DoFunction.
  26. // To execute code, call PrepareScript and then DoScript.
  27.  
  28.   TfrInterpretator = class(TObject)
  29.   protected
  30.     FParser: TfrParser;
  31.   public
  32.     constructor Create;
  33.     destructor Destroy; override;
  34.     procedure GetValue(const Name: String; var Value: Variant); virtual;
  35.     procedure SetValue(const Name: String; Value: Variant); virtual;
  36.     procedure DoFunction(const name: String; p1, p2, p3: Variant;
  37.                          var val: Variant); virtual;
  38.     procedure PrepareScript(MemoFrom, MemoTo, MemoErr: TStrings); virtual;
  39.     procedure DoScript(Memo: TStrings); virtual;
  40.     procedure SplitExpressions(Memo, MatchFuncs, SplitTo: TStrings;
  41.       Variables: TfrVariables);
  42.   end;
  43.  
  44.  
  45. implementation
  46.  
  47. type
  48.   TCharArray = Array[0..31999] of Char;
  49.   PCharArray = ^TCharArray;
  50.   lrec = record
  51.     name: String[16];
  52.     n: Integer;
  53.   end;
  54.  
  55. const
  56.   ttIf    = #1;
  57.   ttGoto  = #2;
  58.   ttProc  = #3;
  59.  
  60. var
  61.   labels: Array[0..100] of lrec;
  62.   labc: Integer;
  63.  
  64.  
  65. function Remain(const S: String; From: Integer): String;
  66. begin
  67.   Result := Copy(s, From, MaxInt);
  68. end;
  69.  
  70. function GetIdentify(const s: String; var i: Integer): String;
  71. var
  72.   k: Integer;
  73. begin
  74.   while (i <= Length(s)) and (s[i] <= ' ') do
  75.     Inc(i);
  76.   k := i;
  77.   while (i <= Length(s)) and (s[i] > ' ') do
  78.     Inc(i);
  79.   Result := Copy(s, k, i - k);
  80. end;
  81.  
  82.  
  83. { TfrInterpretator }
  84.  
  85. constructor TfrInterpretator.Create;
  86. begin
  87.   inherited Create;
  88.   FParser := TfrParser.Create;
  89.   FParser.OnGetValue := GetValue;
  90.   FParser.OnFunction := DoFunction;
  91. end;
  92.  
  93. destructor TfrInterpretator.Destroy;
  94. begin
  95.   FParser.Free;
  96.   inherited Destroy;
  97. end;
  98.  
  99. procedure TfrInterpretator.PrepareScript(MemoFrom, MemoTo, MemoErr: TStrings);
  100. var
  101.   i, j, cur, lastp: Integer;
  102.   s, bs: String;
  103.   len: Integer;
  104.   buf: PCharArray;
  105.   Error: Boolean;
  106.   CutList: TStringList;
  107.  
  108. procedure DoCommand; forward;
  109. procedure DoBegin; forward;
  110. procedure DoIf; forward;
  111. procedure DoRepeat; forward;
  112. procedure DoWhile; forward;
  113. procedure DoGoto; forward;
  114. procedure DoEqual; forward;
  115. procedure DoExpression; forward;
  116. procedure DoSExpression; forward;
  117. procedure DoTerm; forward;
  118. procedure DoFactor; forward;
  119. procedure DoVariable; forward;
  120. procedure DoConst; forward;
  121. procedure DoLabel; forward;
  122. procedure DoFunc; forward;
  123. procedure DoFuncId; forward;
  124.  
  125.   function last: Integer;
  126.   begin
  127.     Result := MemoTo.Count;
  128.   end;
  129.  
  130.   function CopyArr(cur, n: Integer): String;
  131.   begin
  132.     SetLength(Result, n);
  133.     Move(buf^[cur], Result[1], n);
  134.   end;
  135.  
  136.   procedure AddLabel(s: String; n: Integer);
  137.   var
  138.     i: Integer;
  139.     f: Boolean;
  140.   begin
  141.     f := True;
  142.     for i := 0 to labc - 1 do
  143.       if labels[i].name = s then f := False;
  144.     if f then
  145.     begin
  146.       labels[labc].name := s;
  147.       labels[labc].n := n;
  148.       Inc(labc);
  149.     end;
  150.   end;
  151.  
  152.   procedure SkipSpace;
  153.   begin
  154.     while (buf^[cur] <= ' ') and (cur < len) do Inc(cur);
  155.   end;
  156.  
  157.   function GetToken: String;
  158.   var
  159.     n, j: Integer;
  160.   label 1;
  161.   begin
  162. 1:  SkipSpace;
  163.     j := cur;
  164.     while (buf^[cur] > ' ') and (cur < len) do
  165.     begin
  166.       if (buf^[cur] = '{') and (buf^[j] <> #$27) then
  167.       begin
  168.         n := cur;
  169.         while (buf^[cur] <> '}') and (cur < len) do
  170.           Inc(cur);
  171.         CutList.Add(IntToStr(n) + ' ' + IntToStr(cur - n + 1));
  172.         Move(buf^[cur + 1], buf^[n], len - cur);
  173.         Dec(len, cur - n + 1);
  174.         cur := n;
  175.         goto 1;
  176.       end
  177.       else if (buf^[cur] = '/') and (buf^[cur + 1] = '/') and (buf^[j] <> #$27) then
  178.       begin
  179.         n := cur;
  180.         while (buf^[cur] <> #13) and (cur < len) do
  181.           Inc(cur);
  182.         CutList.Add(IntToStr(n) + ' ' + IntToStr(cur - n + 1));
  183.         Move(buf^[cur + 1], buf^[n], len - cur);
  184.         Dec(len, cur - n + 1);
  185.         cur := n;
  186.         goto 1;
  187.       end;
  188.       Inc(cur);
  189.     end;
  190.     Result := AnsiUpperCase(CopyArr(j, cur - j));
  191.     if Result = '' then
  192.       Result := ' ';
  193.   end;
  194.  
  195.   procedure AddError(s: String);
  196.   var
  197.     i, j, c: Integer;
  198.     s1: String;
  199.   begin
  200.     Error := True;
  201.     cur := lastp;
  202.     SkipSpace;
  203.     for i := 0 to CutList.Count - 1 do
  204.     begin
  205.       s1 := CutList[i];
  206.       j := StrToInt(Copy(s1, 1, Pos(' ', s1) - 1));
  207.       c := StrToInt(Copy(s1, Pos(' ', s1) + 1, 255));
  208.       if lastp >= j then
  209.         Inc(cur, c);
  210.     end;
  211.  
  212.     Inc(cur);
  213.     i := 0;
  214.     c := 0;
  215.     j := 0;
  216.     while i < MemoFrom.Count do
  217.     begin
  218.       s1 := MemoFrom[i];
  219.       if c + Length(s1) + 1 < cur then
  220.         c := c + Length(s1) + 1 else
  221.       begin
  222.         j := cur - c;
  223.         break;
  224.       end;
  225.       Inc(i);
  226.     end;
  227.     MemoErr.Add('Line ' + IntToStr(i + 1) + '/' + IntToStr(j) + ': ' + s);
  228.     cur := lastp;
  229.   end;
  230.  
  231.   procedure ProcessBrackets(var i: Integer);
  232.   var
  233.     c: Integer;
  234.     fl1, fl2: Boolean;
  235.   begin
  236.     fl1 := True; fl2 := True; c := 0;
  237.     Dec(i);
  238.     repeat
  239.       Inc(i);
  240.       if fl1 and fl2 then
  241.         if buf^[i] = '[' then
  242.           Inc(c) else
  243.           if buf^[i] = ']' then Dec(c);
  244.       if fl1 then
  245.         if buf^[i] = '"' then fl2 := not fl2;
  246.       if fl2 then
  247.         if buf^[i] = '''' then fl1 := not fl1;
  248.     until (c = 0) or (i >= len);
  249.   end;
  250.  
  251.   {----------------------------------------------}
  252.   procedure DoDigit;
  253.   begin
  254.     while (buf^[cur] <= ' ') and (cur < len) do Inc(cur);
  255.     if buf^[cur] in ['0'..'9'] then
  256.       while (buf^[cur] in ['0'..'9']) and (cur < len) do Inc(cur)
  257.     else Error := True;
  258.   end;
  259.  
  260.   procedure DoBegin;
  261.   label 1;
  262.   begin
  263.   1:DoCommand;
  264.     if Error then Exit;
  265.     lastp := cur;
  266.     bs := GetToken;
  267.     if (bs = '') or (bs[1] = ';') then
  268.     begin
  269.       cur := cur - Length(bs) + 1;
  270.       goto 1;
  271.     end
  272.     else if (bs = 'END') or (bs = 'END;') then cur := cur - Length(bs) + 3
  273.     else AddError('Need ";" or "end" here');
  274.   end;
  275.  
  276.   procedure DoIf;
  277.   var
  278.     nsm, nl, nl1: Integer;
  279.   begin
  280.     nsm := cur;
  281.     DoExpression;
  282.     if Error then Exit;
  283.     bs := ttIf + '  ' + CopyArr(nsm, cur - nsm);
  284.     nl := last;
  285.     MemoTo.Add(bs);
  286.     lastp := cur;
  287.     if GetToken = 'THEN' then
  288.     begin
  289.       DoCommand;
  290.       if Error then Exit;
  291.       nsm := cur;
  292.       if GetToken = 'ELSE' then
  293.       begin
  294.         nl1 := last;
  295.         MemoTo.Add(ttGoto + '  ');
  296.         bs := MemoTo[nl]; bs[2] := Chr(last); bs[3] := Chr(last div 256); MemoTo[nl] := bs;
  297.         DoCommand;
  298.         bs := MemoTo[nl1]; bs[2] := Chr(last); bs[3] := Chr(last div 256); MemoTo[nl1] := bs;
  299.       end
  300.       else
  301.       begin
  302.         bs := MemoTo[nl]; bs[2] := Chr(last); bs[3] := Chr(last div 256); MemoTo[nl] := bs;
  303.         cur := nsm;
  304.       end;
  305.     end
  306.     else AddError('Need "then" here');
  307.   end;
  308.  
  309.   procedure DoRepeat;
  310.   label 1;
  311.   var
  312.     nl, nsm: Integer;
  313.   begin
  314.     nl := last;
  315.   1:DoCommand;
  316.     if Error then Exit;
  317.     lastp := cur;
  318.     bs := GetToken;
  319.     if bs = 'UNTIL' then
  320.     begin
  321.       nsm := cur;
  322.       DoExpression;
  323.       MemoTo.Add(ttIf + Chr(nl) + Chr(nl div 256) + CopyArr(nsm, cur - nsm));
  324.     end
  325.     else if bs[1] = ';' then
  326.     begin
  327.       cur := cur - Length(bs) + 1;
  328.       goto 1;
  329.     end
  330.     else AddError('Need ";" or "until" here');
  331.   end;
  332.  
  333.   procedure DoWhile;
  334.   var
  335.     nl, nsm: Integer;
  336.   begin
  337.     nl := last;
  338.     nsm := cur;
  339.     DoExpression;
  340.     if Error then Exit;
  341.     MemoTo.Add(ttIf + '  ' + CopyArr(nsm, cur - nsm));
  342.     lastp := cur;
  343.     if GetToken = 'DO' then
  344.     begin
  345.       DoCommand;
  346.       MemoTo.Add(ttGoto + Chr(nl) + Chr(nl div 256));
  347.       bs := MemoTo[nl]; bs[2] := Chr(last); bs[3] := Chr(last div 256); MemoTo[nl] := bs;
  348.     end
  349.     else AddError('Need "do" here');
  350.   end;
  351.  
  352.   procedure DoFor;
  353.   var
  354.     nsm, nl: Integer;
  355.     loopvar: String;
  356.   begin
  357.     nsm := cur;
  358.     DoEqual;
  359.     if Error then Exit;
  360.     bs := Trim(CopyArr(nsm, cur - nsm));
  361.     loopvar := Copy(bs, 1, Pos(':=', bs) - 1);
  362.     lastp := cur;
  363.     if GetToken = 'TO' then
  364.     begin
  365.       nsm := cur;
  366.       DoExpression;
  367.       if Error then Exit;
  368.       nl := last;
  369.       MemoTo.Add(ttIf + '  ' + loopvar + '<=' + CopyArr(nsm, cur - nsm));
  370.  
  371.       lastp := cur;
  372.       if GetToken = 'DO' then
  373.       begin
  374.         DoCommand;
  375.         if Error then Exit;
  376.         MemoTo.Add(loopvar + ' ' + loopvar + '+1');
  377.         MemoTo.Add(ttGoto + Chr(nl) + Chr(nl div 256));
  378.         bs := MemoTo[nl]; bs[2] := Chr(last); bs[3] := Chr(last div 256); MemoTo[nl] := bs;
  379.       end
  380.       else AddError('Need "do" here');
  381.     end
  382.     else AddError('Need "to" here');
  383.   end;
  384.  
  385.   procedure DoGoto;
  386.   var
  387.     nsm: Integer;
  388.   begin
  389.     SkipSpace;
  390.     nsm := cur;
  391.     lastp := cur;
  392.     DoDigit;
  393.     if Error then AddError('"goto" label must be a number');
  394.     MemoTo.Add(ttGoto + Trim(CopyArr(nsm, cur - nsm)));
  395.   end;
  396.  
  397.   procedure DoEqual;
  398.   var
  399.     s: String;
  400.     n, nsm: Integer;
  401.   begin
  402.     nsm := cur;
  403.     DoVariable;
  404.     s := Trim(CopyArr(nsm, cur - nsm)) + ' ';
  405.     lastp := cur;
  406.     bs := GetToken;
  407.     if (bs = ';') or (bs = '') or (bs = #0) or (bs = 'END') or (bs = 'ELSE') then
  408.     begin
  409.       s := Trim(CopyArr(nsm, lastp - nsm));
  410.       MemoTo.Add(ttProc + s + '(0)');
  411.       cur := lastp;
  412.     end
  413.     else if Pos(':=', bs) = 1 then
  414.     begin
  415.       cur := cur - Length(bs) + 2;
  416.       nsm := cur;
  417.       DoExpression;
  418.       n := Pos('[', s);
  419.       if n <> 0 then
  420.       begin
  421.         s := ttProc + 'SETARRAY(' + Copy(s, 1, n - 1) + ', ' +
  422.           Copy(s, n + 1, Length(s) - n - 2) + ', ' + CopyArr(nsm, cur - nsm) + ')';
  423.       end
  424.       else
  425.         s := s + CopyArr(nsm, cur - nsm);
  426.       MemoTo.Add(s);
  427.     end
  428.     else
  429.       AddError('Need ":=" here');
  430.   end;
  431.   {-------------------------------------}
  432.   procedure DoExpression;
  433.   var
  434.     nsm: Integer;
  435.   begin
  436.     DoSExpression;
  437.     nsm := cur;
  438.     bs := GetToken;
  439.     if (Pos('>=', bs) = 1) or (Pos('<=', bs) = 1) or (Pos('<>', bs) = 1) then
  440.     begin
  441.       cur := cur - Length(bs) + 2;
  442.       DoSExpression;
  443.     end
  444.     else if (bs[1] = '>') or (bs[1] = '<') or (bs[1] = '=') then
  445.     begin
  446.       cur := cur - Length(bs) + 1;
  447.       DoSExpression;
  448.     end
  449.     else cur := nsm;
  450.   end;
  451.  
  452.   procedure DoSExpression;
  453.   var
  454.     nsm: Integer;
  455.   begin
  456.     DoTerm;
  457.     nsm := cur;
  458.     bs := GetToken;
  459.     if (bs[1] = '+') or (bs[1] = '-') then
  460.     begin
  461.       cur := cur - Length(bs) + 1;
  462.       DoSExpression;
  463.     end
  464.     else if Pos('OR', bs) = 1 then
  465.     begin
  466.       cur := cur - Length(bs) + 2;
  467.       DoSExpression;
  468.     end
  469.     else cur := nsm;
  470.   end;
  471.  
  472.   procedure DoTerm;
  473.   var
  474.     nsm: Integer;
  475.   begin
  476.     DoFactor;
  477.     nsm := cur;
  478.     bs := GetToken;
  479.     if (bs[1] = '*') or (bs[1] = '/') then
  480.     begin
  481.       cur := cur - Length(bs) + 1;
  482.       DoTerm;
  483.     end
  484.     else if (Pos('AND', bs) = 1) or (Pos('MOD', bs) = 1) then
  485.     begin
  486.       cur := cur - Length(bs) + 3;
  487.       DoTerm;
  488.     end
  489.     else cur := nsm;
  490.   end;
  491.  
  492.   procedure DoFactor;
  493.   var
  494.     nsm: Integer;
  495.   begin
  496.     nsm := cur;
  497.     bs := GetToken;
  498.     if bs[1] = '(' then
  499.     begin
  500.       cur := cur - Length(bs) + 1;
  501.       DoExpression;
  502.       SkipSpace;
  503.       lastp := cur;
  504.       if buf^[cur] = ')' then Inc(cur)
  505.       else AddError('Need ")" here');
  506.     end
  507.     else if bs[1] = '[' then
  508.     begin
  509.       cur := cur - Length(bs);
  510.       ProcessBrackets(cur);
  511.       SkipSpace;
  512.       lastp := cur;
  513.       if buf^[cur] = ']' then Inc(cur)
  514.       else AddError('Need "]" here');
  515.     end
  516.     else if (bs[1] = '+') or (bs[1] = '-') then
  517.     begin
  518.       cur := cur - Length(bs) + 1;
  519.       DoExpression;
  520.     end
  521.     else if bs = 'NOT' then
  522.     begin
  523.       cur := cur - Length(bs) + 3;
  524.       DoExpression;
  525.     end
  526.     else
  527.     begin
  528.       cur := nsm;
  529.       DoVariable;
  530.       if Error then
  531.       begin
  532.         Error := False;
  533.         cur := nsm;
  534.         DoConst;
  535.         if Error then
  536.         begin
  537.           Error := False;
  538.           cur := nsm;
  539.           DoFunc;
  540.         end;
  541.       end;
  542.     end;
  543.   end;
  544.  
  545.   procedure DoVariable;
  546.   begin
  547.     SkipSpace;
  548.     if (buf^[cur] in ['a'..'z', 'A'..'Z']) then
  549.     begin
  550.       Inc(cur);
  551.       while buf^[cur] in ['0'..'9', '_', '.', 'A'..'Z', 'a'..'z'] do Inc(cur);
  552.       if buf^[cur] = '(' then
  553.         Error := True
  554.       else if buf^[cur] = '[' then
  555.       begin
  556.         Inc(cur);
  557.         DoExpression;
  558.         if buf^[cur] <> ']' then
  559.           Error := True else
  560.           Inc(cur);
  561.       end;
  562.     end
  563.     else Error := True;
  564.   end;
  565.  
  566.   procedure DoConst;
  567.   label 1;
  568.   begin
  569.     SkipSpace;
  570.     if buf^[cur] = #$27 then
  571.     begin
  572.    1: Inc(cur);
  573.       while (buf^[cur] <> #$27) and (cur < len) do Inc(cur);
  574.       if (cur < len) and (buf^[cur + 1] = #$27) then
  575.       begin
  576.         Inc(cur);
  577.         goto 1;
  578.       end;
  579.       if cur = len then Error := True
  580.       else Inc(cur);
  581.     end
  582.     else
  583.     begin
  584.       DoDigit;
  585.       if buf^[cur] = '.' then
  586.       begin
  587.         Inc(cur);
  588.         DoDigit;
  589.       end;
  590.     end;
  591.   end;
  592.  
  593.   procedure DoLabel;
  594.   begin
  595.     DoDigit;
  596.     if buf^[cur] = ':' then Inc(cur)
  597.     else Error := True;
  598.   end;
  599.  
  600.   procedure DoFunc;
  601.   label 1;
  602.   begin
  603.     DoFuncId;
  604.     if buf^[cur] = '(' then
  605.     begin
  606.       Inc(cur);
  607.       SkipSpace;
  608.       if buf^[cur] = ')' then
  609.       begin
  610.         Inc(cur);
  611.         exit;
  612.       end;
  613.   1:  DoExpression;
  614.       lastp := cur;
  615.       SkipSpace;
  616.       if buf^[cur] = ',' then
  617.       begin
  618.         Inc(cur);
  619.         goto 1;
  620.       end
  621.       else if buf^[cur] = ')' then Inc(cur)
  622.       else AddError('Need "," or ")" here');
  623.     end;
  624.   end;
  625.  
  626.   procedure DoFuncId;
  627.   begin
  628.     SkipSpace;
  629.     if buf^[cur] in ['A'..'Z', 'a'..'z'] then
  630.       while buf^[cur] in ['0'..'9', '_', '.', 'A'..'Z', 'a'..'z'] do Inc(cur)
  631.     else Error := True;
  632.   end;
  633.  
  634.   procedure DoCommand;
  635.   label 1;
  636.   var
  637.     nsm: Integer;
  638.   begin
  639.   1:Error := False;
  640.     nsm := cur;
  641.     lastp := cur;
  642.     bs := GetToken;
  643.     if bs = 'BEGIN' then DoBegin
  644.     else if bs = 'IF' then DoIf
  645.     else if bs = 'REPEAT' then DoRepeat
  646.     else if bs = 'WHILE' then DoWhile
  647.     else if bs = 'FOR' then DoFor
  648.     else if bs = 'GOTO' then DoGoto
  649.     else if (bs = 'END') or (bs = 'END;') then
  650.     begin
  651.       cur := nsm;
  652.       Error := False;
  653.     end
  654.     else if bs = 'UNTIL' then
  655.     begin
  656.       cur := nsm;
  657.       Error := False;
  658.     end
  659.     else
  660.     begin
  661.       cur := nsm;
  662.       DoLabel;
  663.       if Error then
  664.       begin
  665.         Error := False;
  666.         cur := nsm;
  667.         DoVariable;
  668.         if not Error then
  669.         begin
  670.           cur := nsm;
  671.           DoEqual;
  672.         end
  673.         else
  674.         begin
  675.           cur := nsm;
  676.           Error := False;
  677.           DoExpression;
  678.           MemoTo.Add(ttProc + Trim(CopyArr(nsm, cur - nsm)));
  679.         end;
  680.       end
  681.       else
  682.       begin
  683.         AddLabel(Trim(CopyArr(nsm, cur - nsm)), last);
  684.         goto 1;
  685.       end;
  686.     end;
  687.   end;
  688.  
  689. begin
  690.   CutList := TStringList.Create;
  691.   Error := False;
  692.   GetMem(buf, 32000);
  693.   FillChar(buf^, 32000, 0);
  694.   len := 0;
  695.   for i := 0 to MemoFrom.Count - 1 do
  696.   begin
  697.     s := MemoFrom[i] + #13;
  698.     while Pos(#9, s) <> 0 do
  699.       s[Pos(#9, s)] := ' ';
  700.     Move(s[1], buf^[len], Length(s));
  701.     Inc(len, Length(s));
  702.   end;
  703.  
  704.   cur := 0; labc := 0;
  705.   MemoTo.Clear;
  706.   MemoErr.Clear;
  707.   if len > 0 then
  708.     DoCommand;
  709.   FreeMem(buf, 32000);
  710.   CutList.Free;
  711.  
  712.   for i := 0 to MemoTo.Count - 1 do
  713.     if MemoTo[i][1] = ttGoto then
  714.     begin
  715.       s := Remain(MemoTo[i], 2) + ':';
  716.       for j := 0 to labc do
  717.         if labels[j].name = s then
  718.         begin
  719.           s := MemoTo[i]; s[2] := Chr(labels[j].n);
  720.           s[3] := Chr(labels[j].n div 256); MemoTo[i] := s;
  721.           break;
  722.         end;
  723.     end
  724.     else if MemoTo[i][1] = ttIf then
  725.     begin
  726.       s := FParser.Str2OPZ(Remain(MemoTo[i], 4));
  727.       MemoTo[i] := Copy(MemoTo[i], 1, 3) + s;
  728.     end
  729.     else if MemoTo[i][1] = ttProc then
  730.     begin
  731.       s := FParser.Str2OPZ(Remain(MemoTo[i], 2));
  732.       MemoTo[i] := Copy(MemoTo[i], 1, 1) + s;
  733.     end
  734.     else
  735.     begin
  736.       j := 1;
  737.       GetIdentify(MemoTo[i], j);
  738.       len := j;
  739.       s := FParser.Str2OPZ(Remain(MemoTo[i], j));
  740.       MemoTo[i] := Copy(MemoTo[i], 1, len) + s;
  741.     end;
  742. end;
  743.  
  744. procedure TfrInterpretator.DoScript(Memo: TStrings);
  745. var
  746.   i, j: Integer;
  747.   s, s1: String;
  748. begin
  749.   i := 0;
  750.   while i < Memo.Count do
  751.   begin
  752.     s := Memo[i];
  753.     j := 1;
  754.     if s[1] = ttIf then
  755.     begin
  756.       if FParser.CalcOPZ(Remain(s, 4)) = 0 then
  757.       begin
  758.         i := Ord(s[2]) + Ord(s[3]) * 256;
  759.         continue;
  760.       end;
  761.     end
  762.     else if s[1] = ttGoto then
  763.     begin
  764.       i := Ord(s[2]) + Ord(s[3]) * 256;
  765.       continue;
  766.     end
  767.     else if s[1] = ttProc then
  768.     begin
  769.       s1 := Remain(s, 2);
  770.       if AnsiUpperCase(s1) = 'EXIT(0)' then
  771.         exit;
  772.       FParser.CalcOPZ(s1);
  773.     end
  774.     else
  775.     begin
  776.       s1 := GetIdentify(s, j);
  777.       SetValue(s1, FParser.CalcOPZ(Remain(s, j)));
  778.     end;
  779.     Inc(i);
  780.   end;
  781. end;
  782.  
  783. procedure TfrInterpretator.SplitExpressions(Memo, MatchFuncs, SplitTo: TStrings;
  784.   Variables: TfrVariables);
  785. var
  786.   i, j: Integer;
  787.   s: String;
  788.   FuncSplitter: TfrFunctionSplitter;
  789. begin
  790.   FuncSplitter := TfrFunctionSplitter.Create(MatchFuncs, SplitTo, Variables);
  791.   i := 0;
  792.   while i < Memo.Count do
  793.   begin
  794.     s := Memo[i];
  795.     j := 1;
  796.     if s[1] = ttIf then
  797.       FuncSplitter.Split(Remain(s, 4))
  798.     else if s[1] = ttProc then
  799.       FuncSplitter.Split(Remain(s, 2))
  800.     else
  801.     begin
  802.       GetIdentify(s, j);
  803.       FuncSplitter.Split(Remain(s, j));
  804.     end;
  805.     Inc(i);
  806.   end;
  807.   FuncSplitter.Free;
  808. end;
  809.  
  810. procedure TfrInterpretator.GetValue(const Name: String; var Value: Variant);
  811. begin
  812. // abstract method
  813. end;
  814.  
  815. procedure TfrInterpretator.SetValue(const Name: String; Value: Variant);
  816. begin
  817. // abstract method
  818. end;
  819.  
  820. procedure TfrInterpretator.DoFunction(const Name: String; p1, p2, p3: Variant;
  821.   var val: Variant);
  822. begin
  823. // abstract method
  824. end;
  825.  
  826. end.
  827.