mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-01 11:23:45 +02:00
5f2c42d8c1
1. In frVarible removed unnecessary manipulation of memory with PString 2. To export filters can now be controlled via the function Setup. In the future we plan to implement the export options window for some of the filters. 3. In a script bug fixed constants for color. Uses all standard colors Lazarus ( previously only 16 colors ). 4. In the script added constants and mrOk mrCancel. You can use the built-in function for MessageBox. 5. The script Fixed bug with setting object properties in the case of several pages in the report. 6. Fixed a bug report from the designer view - did not work identified in the program of event report. git-svn-id: trunk@44281 -
981 lines
21 KiB
ObjectPascal
981 lines
21 KiB
ObjectPascal
|
|
{******************************************}
|
|
{ }
|
|
{ FastReport v2.3 }
|
|
{ Interpreter }
|
|
{ }
|
|
{ Copyright (c) 1998-2000 by Tzyganenko A. }
|
|
{ }
|
|
{******************************************}
|
|
|
|
unit LR_Intrp;
|
|
|
|
interface
|
|
|
|
{$I LR_Vers.inc}
|
|
|
|
uses Classes, SysUtils, Graphics, LR_Pars;
|
|
|
|
type
|
|
TCharArray = array [0..31999] of Char;
|
|
PCharArray = ^TCharArray;
|
|
|
|
type
|
|
|
|
{ TfrInterpretator }
|
|
|
|
TfrInterpretator = class(TObject)
|
|
private
|
|
Buf: PCharArray;
|
|
Cur:integer;
|
|
Len: Integer;
|
|
procedure SkipSpace;
|
|
function GetToken: String;
|
|
function CopyArr(ACur, ACnt: Integer): String;
|
|
private
|
|
FParser: TfrParser;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure GetValue(const {%H-}Name: String; var {%H-}Value: Variant); virtual;
|
|
procedure SetValue(const {%H-}Name: String; {%H-}Value: Variant); virtual;
|
|
procedure DoFunction(const {%H-}name: String; {%H-}p1, {%H-}p2, {%H-}p3: Variant;
|
|
var {%H-}val: Variant); virtual;
|
|
procedure PrepareScript(MemoFrom, MemoTo, MemoErr: TStringList); virtual;
|
|
procedure DoScript(Memo: TStringList); virtual;
|
|
end;
|
|
|
|
TfrVariables = class(TObject)
|
|
private
|
|
FList: TFpList;
|
|
procedure SetVariable(aName: String; AValue: Variant);
|
|
function GetVariable(aName: String): Variant;
|
|
procedure SetValue(Index: Integer; AValue: Variant);
|
|
function GetValue(Index: Integer): Variant;
|
|
function GetName(Index: Integer): String;
|
|
function GetCount: Integer;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Clear;
|
|
procedure Delete(Index: Integer);
|
|
function IndexOf(aName: String): Integer;
|
|
property Variable[aName: String]: Variant
|
|
read GetVariable write SetVariable; default;
|
|
property Value[Index: Integer]: Variant read GetValue write SetValue;
|
|
property Name[Index: Integer]: String read GetName;
|
|
property Count: Integer read GetCount;
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
uses Variants;
|
|
|
|
type
|
|
LRec = record
|
|
name: String[16];
|
|
n: Integer;
|
|
end;
|
|
|
|
PVariable = ^TVariable;
|
|
TVariable = record
|
|
//Name : PString;
|
|
Name : String;
|
|
Value: Variant;
|
|
end;
|
|
|
|
const
|
|
ttIf = #1;
|
|
ttGoto = #2;
|
|
ttProc = #3;
|
|
|
|
var
|
|
labels: Array[0..100] of lrec;
|
|
labc: Integer;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
constructor TfrVariables.Create;
|
|
begin
|
|
inherited Create;
|
|
FList := TFpList.Create;
|
|
end;
|
|
|
|
destructor TfrVariables.Destroy;
|
|
begin
|
|
Clear;
|
|
FList.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TfrVariables.Clear;
|
|
begin
|
|
while FList.Count > 0 do
|
|
Delete(0);
|
|
end;
|
|
|
|
procedure TfrVariables.SetVariable(aName: String; AValue: Variant);
|
|
var
|
|
i: Integer;
|
|
p: PVariable;
|
|
begin
|
|
for i := 0 to FList.Count - 1 do
|
|
if AnsiCompareText(PVariable(FList[i])^.Name, aName) = 0 then
|
|
begin
|
|
PVariable(FList[i])^.Value := AValue;
|
|
Exit;
|
|
end;
|
|
GetMem(p, SizeOf(TVariable));
|
|
FillChar(p^, SizeOf(TVariable), 0);
|
|
p^.Name := aName; //NewStr(aName);
|
|
p^.Value := AValue;
|
|
FList.Add(p);
|
|
end;
|
|
|
|
function TfrVariables.GetVariable(aName: String): Variant;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := Null;
|
|
for i := 0 to FList.Count - 1 do
|
|
if AnsiCompareText(PVariable(FList[i])^.Name, aName) = 0 then
|
|
begin
|
|
Result := PVariable(FList[i])^.Value;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrVariables.SetValue(Index: Integer; AValue: Variant);
|
|
begin
|
|
if (Index < 0) or (Index >= FList.Count) then Exit;
|
|
PVariable(FList[Index])^.Value := AValue;
|
|
end;
|
|
|
|
function TfrVariables.GetValue(Index: Integer): Variant;
|
|
begin
|
|
Result := 0;
|
|
if (Index < 0) or (Index >= FList.Count) then Exit;
|
|
Result := PVariable(FList[Index])^.Value;
|
|
end;
|
|
|
|
function TfrVariables.IndexOf(AName: String): Integer;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := -1;
|
|
for i := 0 to FList.Count - 1 do
|
|
if AnsiCompareText(PVariable(FList[i])^.Name, AName) = 0 then
|
|
begin
|
|
Result := i;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
function TfrVariables.GetCount: Integer;
|
|
begin
|
|
Result := FList.Count;
|
|
end;
|
|
|
|
function TfrVariables.GetName(Index: Integer): String;
|
|
begin
|
|
Result := '';
|
|
if (Index < 0) or (Index >= FList.Count) then Exit;
|
|
Result := PVariable(FList[Index])^.Name;
|
|
end;
|
|
|
|
procedure TfrVariables.Delete(Index: Integer);
|
|
var
|
|
p: PVariable;
|
|
begin
|
|
if (Index < 0) or (Index >= FList.Count) then Exit;
|
|
p := FList[Index];
|
|
//DisposeStr(p^.Name);
|
|
p^.Name:='';
|
|
p^.Value := 0;
|
|
FreeMem(p, SizeOf(TVariable));
|
|
FList.Delete(Index);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
function Remain(S: String; From: Integer): String;
|
|
begin
|
|
Result := Copy(s, From, Length(s) - 1);
|
|
end;
|
|
|
|
function GetIdentify(const s: String; var i: Integer): String;
|
|
var
|
|
k: Integer;
|
|
begin
|
|
while (i <= Length(s)) and (s[i] = ' ') do
|
|
Inc(i);
|
|
k := i;
|
|
while (i <= Length(s)) and (s[i] <> ' ') do
|
|
Inc(i);
|
|
Result := Copy(s, k, i - k);
|
|
end;
|
|
|
|
procedure TfrInterpretator.SkipSpace;
|
|
begin
|
|
while (Buf^[cur] <= ' ') and (Cur < Len) do Inc(Cur);
|
|
end;
|
|
|
|
function TfrInterpretator.GetToken: String;
|
|
var
|
|
ST, SC: Integer;
|
|
begin
|
|
if Cur<Len then
|
|
begin
|
|
repeat
|
|
SkipSpace;
|
|
ST := Cur; //Start of token
|
|
SC:=-1;
|
|
while (Buf^[Cur] > ' ') and (Cur < Len) and (SC=-1) do
|
|
begin
|
|
if Buf^[ST] <> '''' then
|
|
begin
|
|
case Buf^[Cur] of
|
|
'{':begin
|
|
//Skip {...} comment
|
|
SC := Cur; //Start of comment
|
|
while (Buf^[Cur] <> '}') and (cur < len) do Inc(cur);
|
|
Move(Buf^[Cur + 1], Buf^[SC], Len - Cur);
|
|
Dec(Len, Cur - SC + 1);
|
|
Cur := SC;
|
|
Continue;
|
|
end;
|
|
'/':if (Buf^[Cur + 1] = '/') then
|
|
begin
|
|
//Skip // comment
|
|
SC:= Cur; //Start of comment
|
|
while (Buf^[Cur] <> #13) and (Cur < Len) do Inc(Cur);
|
|
Move(Buf^[Cur + 1], Buf^[SC], Len - Cur);
|
|
Dec(Len, Cur - SC + 1);
|
|
Cur := SC;
|
|
Continue;
|
|
end;
|
|
end
|
|
end;
|
|
Inc(Cur);
|
|
end;
|
|
until (SC=-1) or (Cur>=Len);
|
|
Result := UpperCase(CopyArr(ST, Cur - ST));
|
|
end
|
|
else
|
|
Result:='';
|
|
end;
|
|
|
|
function TfrInterpretator.CopyArr(ACur, ACnt: Integer): String;
|
|
begin
|
|
SetLength(Result, ACnt);
|
|
Move(Buf^[ACur], Result[1], ACnt);
|
|
end;
|
|
|
|
{-----------------------------------------------------------------------------}
|
|
constructor TfrInterpretator.Create;
|
|
begin
|
|
inherited Create;
|
|
FParser := TfrParser.Create;
|
|
FParser.OnGetValue := @GetValue;
|
|
FParser.OnFunction := @DoFunction;
|
|
end;
|
|
|
|
destructor TfrInterpretator.Destroy;
|
|
begin
|
|
FParser.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TfrInterpretator.PrepareScript(MemoFrom, MemoTo, MemoErr: TStringList);
|
|
var
|
|
i, j, lastp: Integer;
|
|
s, bs: String;
|
|
Error: Boolean;
|
|
|
|
procedure DoCommand; forward;
|
|
procedure DoBegin; forward;
|
|
procedure DoIf; forward;
|
|
procedure DoRepeat; forward;
|
|
procedure DoWhile; forward;
|
|
procedure DoGoto; forward;
|
|
procedure DoEqual; forward;
|
|
procedure DoExpression; forward;
|
|
procedure DoSExpression; forward;
|
|
procedure DoTerm; forward;
|
|
procedure DoFactor; forward;
|
|
procedure DoVariable; forward;
|
|
procedure DoConst; forward;
|
|
procedure DoLabel; forward;
|
|
procedure DoFunc; forward;
|
|
procedure DoFuncId; forward;
|
|
|
|
function last: Integer;
|
|
begin
|
|
Result := MemoTo.Count;
|
|
end;
|
|
|
|
procedure AddLabel(s: String; n: Integer);
|
|
var
|
|
i: Integer;
|
|
f: Boolean;
|
|
begin
|
|
f := True;
|
|
for i := 0 to labc - 1 do
|
|
if labels[i].name = s then f := False;
|
|
if f then
|
|
begin
|
|
labels[labc].name := s;
|
|
labels[labc].n := n;
|
|
Inc(labc);
|
|
end;
|
|
end;
|
|
|
|
procedure AddError(s: String);
|
|
var
|
|
i, j, c: Integer;
|
|
s1: String;
|
|
begin
|
|
Error := True;
|
|
cur := lastp;
|
|
SkipSpace;
|
|
c := 0;
|
|
for i := 0 to cur do
|
|
if buf^[i] > ' ' then Inc(c);
|
|
i := 0;
|
|
j := 1;
|
|
while (c > 0) and (i < MemoFrom.Count) do
|
|
begin
|
|
s1 := MemoFrom[i];
|
|
j := 1;
|
|
while (j <= Length(s1)) and (c > 0) do
|
|
begin
|
|
if s1[j] = '{' then break;
|
|
if s1[j] > ' ' then Dec(c);
|
|
Inc(j);
|
|
end;
|
|
if c = 0 then break;
|
|
Inc(i);
|
|
end;
|
|
MemoErr.Add('Line ' + IntToStr(i + 1) + '/' + IntToStr(j - 1) + ': ' + s);
|
|
end;
|
|
|
|
procedure ProcessBrackets(var i: Integer);
|
|
var
|
|
c: Integer;
|
|
fl1, fl2: Boolean;
|
|
begin
|
|
fl1 := True; fl2 := True; c := 0;
|
|
Dec(i);
|
|
repeat
|
|
Inc(i);
|
|
if fl1 and fl2 then
|
|
if buf^[i] = '[' then
|
|
Inc(c) else
|
|
if buf^[i] = ']' then Dec(c);
|
|
if fl1 then
|
|
if buf^[i] = '"' then fl2 := not fl2;
|
|
if fl2 then
|
|
if buf^[i] = '''' then fl1 := not fl1;
|
|
until (c = 0) or (i >= len);
|
|
end;
|
|
|
|
{----------------------------------------------}
|
|
procedure DoDigit;
|
|
begin
|
|
while (buf^[cur] = ' ') and (cur < len) do Inc(cur);
|
|
if buf^[cur] in ['0'..'9'] then
|
|
while (buf^[cur] in ['0'..'9']) and (cur < len) do Inc(cur)
|
|
else Error := True;
|
|
end;
|
|
|
|
procedure DoBegin;
|
|
label 1;
|
|
begin
|
|
1:DoCommand;
|
|
if Error then Exit;
|
|
lastp := cur;
|
|
bs := GetToken;
|
|
if (bs = '') or (bs[1] = ';') then
|
|
begin
|
|
cur := cur - Length(bs) + 1;
|
|
goto 1;
|
|
end
|
|
else
|
|
if Pos('END', bs) = 1 then
|
|
cur := cur - Length(bs) + 3
|
|
else
|
|
AddError('Expected ";" or "end"');
|
|
end;
|
|
|
|
procedure DoIf;
|
|
var
|
|
nsm, nl, nl1: Integer;
|
|
begin
|
|
nsm := cur;
|
|
DoExpression;
|
|
if Error then Exit;
|
|
bs := ttIf + ' ' + CopyArr(nsm, cur - nsm);
|
|
nl := last;
|
|
MemoTo.Add(bs);
|
|
lastp := cur;
|
|
if GetToken = 'THEN' then
|
|
begin
|
|
DoCommand;
|
|
if Error then Exit;
|
|
nsm := cur;
|
|
if GetToken = 'ELSE' then
|
|
begin
|
|
nl1 := last;
|
|
MemoTo.Add(ttGoto + ' ');
|
|
bs := MemoTo[nl]; bs[2] := Chr(last); bs[3] := Chr(last div 256); MemoTo[nl] := bs;
|
|
DoCommand;
|
|
bs := MemoTo[nl1]; bs[2] := Chr(last); bs[3] := Chr(last div 256); MemoTo[nl1] := bs;
|
|
end
|
|
else
|
|
begin
|
|
bs := MemoTo[nl]; bs[2] := Chr(last); bs[3] := Chr(last div 256); MemoTo[nl] := bs;
|
|
cur := nsm;
|
|
end;
|
|
end
|
|
else AddError('Expected "then"');
|
|
end;
|
|
|
|
procedure DoRepeat;
|
|
label 1;
|
|
var
|
|
nl, nsm: Integer;
|
|
begin
|
|
nl := last;
|
|
1:DoCommand;
|
|
if Error then Exit;
|
|
lastp := cur;
|
|
bs := GetToken;
|
|
if (bs<>'') and (bs[1] = ';') then
|
|
begin
|
|
cur := cur - Length(bs) + 1;
|
|
goto 1;
|
|
end
|
|
else
|
|
if bs = 'UNTIL' then
|
|
begin
|
|
nsm := cur;
|
|
DoExpression;
|
|
MemoTo.Add(ttIf + Chr(nl) + Chr(nl div 256) + CopyArr(nsm, cur - nsm));
|
|
end
|
|
else AddError('Expected ";" or "until"');
|
|
end;
|
|
|
|
procedure DoWhile;
|
|
var
|
|
nl, nsm: Integer;
|
|
begin
|
|
nl := last;
|
|
nsm := cur;
|
|
DoExpression;
|
|
if Error then Exit;
|
|
MemoTo.Add(ttIf + ' ' + CopyArr(nsm, cur - nsm));
|
|
lastp := cur;
|
|
if GetToken = 'DO' then
|
|
begin
|
|
DoCommand;
|
|
MemoTo.Add(ttGoto + Chr(nl) + Chr(nl div 256));
|
|
bs := MemoTo[nl];
|
|
bs[2] := Chr(last);
|
|
bs[3] := Chr(last div 256);
|
|
MemoTo[nl] := bs;
|
|
end
|
|
else
|
|
AddError('Expected "do"');
|
|
end;
|
|
|
|
procedure DoGoto;
|
|
var
|
|
nsm: Integer;
|
|
begin
|
|
SkipSpace;
|
|
nsm := cur;
|
|
lastp := cur;
|
|
DoDigit;
|
|
if Error then AddError('Label in goto must be a number');
|
|
MemoTo.Add(ttGoto + Trim(CopyArr(nsm, cur - nsm)));
|
|
end;
|
|
|
|
procedure DoEqual;
|
|
var
|
|
s: String;
|
|
n, nsm: Integer;
|
|
begin
|
|
nsm := cur;
|
|
DoVariable;
|
|
s := Trim(CopyArr(nsm, cur - nsm)) + ' ';
|
|
lastp := cur;
|
|
bs := GetToken;
|
|
if (bs = ';') or (bs = '') or (bs = #0) then
|
|
begin
|
|
s := Trim(CopyArr(nsm, lastp - nsm));
|
|
MemoTo.Add(ttProc + s + '(0)');
|
|
cur := lastp;
|
|
end
|
|
else
|
|
if Pos(':=', bs) = 1 then
|
|
begin
|
|
cur := cur - Length(bs) + 2;
|
|
nsm := cur;
|
|
DoExpression;
|
|
n := Pos('[', s);
|
|
if n <> 0 then
|
|
begin
|
|
s := ttProc + 'SETARRAY(' + Copy(s, 1, n - 1) + ', ' +
|
|
Copy(s, n + 1, Length(s) - n - 2) + ', ' + CopyArr(nsm, cur - nsm) + ')';
|
|
end
|
|
else
|
|
s := s + CopyArr(nsm, cur - nsm);
|
|
MemoTo.Add(s);
|
|
end
|
|
else
|
|
AddError('Expected ":="');
|
|
end;
|
|
{-------------------------------------}
|
|
procedure DoExpression;
|
|
var
|
|
nsm: Integer;
|
|
begin
|
|
DoSExpression;
|
|
nsm := cur;
|
|
bs := GetToken;
|
|
if (Pos('>=', bs) = 1) or (Pos('<=', bs) = 1) or (Pos('<>', bs) = 1) then
|
|
begin
|
|
cur := cur - Length(bs) + 2;
|
|
DoSExpression;
|
|
end
|
|
else
|
|
if (bs<>'') and ((bs[1] = '>') or (bs[1] = '<') or (bs[1] = '=')) then
|
|
begin
|
|
cur := cur - Length(bs) + 1;
|
|
DoSExpression;
|
|
end
|
|
else
|
|
cur := nsm;
|
|
end;
|
|
|
|
procedure DoSExpression;
|
|
var
|
|
nsm: Integer;
|
|
begin
|
|
DoTerm;
|
|
nsm := cur;
|
|
bs := GetToken;
|
|
if (bs<>'') and ((bs[1] = '+') or (bs[1] = '-')) then
|
|
begin
|
|
cur := cur - Length(bs) + 1;
|
|
DoSExpression;
|
|
end
|
|
else
|
|
if Pos('OR', bs) = 1 then
|
|
begin
|
|
cur := cur - Length(bs) + 2;
|
|
DoSExpression;
|
|
end
|
|
else
|
|
cur := nsm;
|
|
end;
|
|
|
|
procedure DoTerm;
|
|
var
|
|
nsm: Integer;
|
|
begin
|
|
DoFactor;
|
|
nsm := cur;
|
|
bs := GetToken;
|
|
if (bs<>'') and ((bs[1] = '*') or (bs[1] = '/')) then
|
|
begin
|
|
cur := cur - Length(bs) + 1;
|
|
DoTerm;
|
|
end
|
|
else
|
|
if (Pos('AND', bs) = 1) or (Pos('MOD', bs) = 1) then
|
|
begin
|
|
cur := cur - Length(bs) + 3;
|
|
DoTerm;
|
|
end
|
|
else
|
|
cur := nsm;
|
|
end;
|
|
|
|
procedure DoFactor;
|
|
var
|
|
nsm: Integer;
|
|
begin
|
|
nsm := cur;
|
|
bs := GetToken;
|
|
if (bs<>'') and (bs[1] = '(') then
|
|
begin
|
|
cur := cur - Length(bs) + 1;
|
|
DoExpression;
|
|
SkipSpace;
|
|
lastp := cur;
|
|
if buf^[cur] = ')' then Inc(cur)
|
|
else AddError('Expected ")"');
|
|
end
|
|
else
|
|
if (bs<>'') and (bs[1] = '[') then
|
|
begin
|
|
cur := cur - Length(bs);
|
|
ProcessBrackets(cur);
|
|
SkipSpace;
|
|
lastp := cur;
|
|
if buf^[cur] = ']' then Inc(cur)
|
|
else AddError('Expected "]"');
|
|
end
|
|
else
|
|
if (bs<>'') and ((bs[1] = '+') or (bs[1] = '-')) then
|
|
begin
|
|
cur := cur - Length(bs) + 1;
|
|
DoExpression;
|
|
end
|
|
else
|
|
if bs = 'NOT' then
|
|
begin
|
|
cur := cur - Length(bs) + 3;
|
|
DoExpression;
|
|
end
|
|
else
|
|
begin
|
|
cur := nsm;
|
|
DoVariable;
|
|
if Error then
|
|
begin
|
|
Error := False;
|
|
cur := nsm;
|
|
DoConst;
|
|
if Error then
|
|
begin
|
|
Error := False;
|
|
cur := nsm;
|
|
DoFunc;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure DoVariable;
|
|
begin
|
|
SkipSpace;
|
|
if (buf^[cur] in ['a'..'z', 'A'..'Z']) then
|
|
begin
|
|
Inc(cur);
|
|
while buf^[cur] in ['0'..'9', '_', '.', 'A'..'Z', 'a'..'z'] do Inc(cur);
|
|
if buf^[cur] = '(' then
|
|
Error := True
|
|
else
|
|
if buf^[cur] = '[' then
|
|
begin
|
|
Inc(cur);
|
|
DoExpression;
|
|
if buf^[cur] <> ']' then
|
|
Error := True else
|
|
Inc(cur);
|
|
end;
|
|
end
|
|
else Error := True;
|
|
end;
|
|
|
|
procedure DoConst;
|
|
label
|
|
lblLine;
|
|
begin
|
|
SkipSpace;
|
|
if buf^[cur] = #$27 then
|
|
begin
|
|
|
|
lblLine:
|
|
|
|
Inc(cur);
|
|
while (buf^[cur] <> #$27) and (cur < len) do
|
|
begin
|
|
Inc(cur);
|
|
end;
|
|
|
|
if (cur < len) and (buf^[cur + 1] = #$27) then
|
|
begin
|
|
Inc(cur);
|
|
goto lblLine;
|
|
end;
|
|
|
|
if cur = len then Error := True
|
|
else Inc(cur);
|
|
end
|
|
else
|
|
begin
|
|
DoDigit;
|
|
if buf^[cur] = '.' then
|
|
begin
|
|
Inc(cur);
|
|
DoDigit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure DoLabel;
|
|
begin
|
|
DoDigit;
|
|
if buf^[cur] = ':' then Inc(cur)
|
|
else Error := True;
|
|
end;
|
|
|
|
procedure DoFunc;
|
|
label 1;
|
|
begin
|
|
DoFuncId;
|
|
if buf^[cur] = '(' then
|
|
begin
|
|
Inc(cur);
|
|
1: DoExpression;
|
|
lastp := cur;
|
|
SkipSpace;
|
|
if buf^[cur] = ',' then
|
|
begin
|
|
Inc(cur);
|
|
goto 1;
|
|
end
|
|
else if buf^[cur] = ')' then Inc(cur)
|
|
else AddError('Expected "," or ")"');
|
|
end;
|
|
end;
|
|
|
|
procedure DoFor;
|
|
var
|
|
nsm, nl: Integer;
|
|
loopvar: String;
|
|
S:string;
|
|
begin
|
|
nsm := cur;
|
|
DoEqual;
|
|
if Error then Exit;
|
|
bs := Trim(CopyArr(nsm, cur - nsm));
|
|
loopvar := Copy(bs, 1, Pos(':=', bs) - 1);
|
|
lastp := cur;
|
|
|
|
S:=GetToken;
|
|
|
|
if S = 'TO' then
|
|
begin
|
|
nsm := cur;
|
|
DoExpression;
|
|
if Error then Exit;
|
|
nl := last;
|
|
MemoTo.Add(ttIf + ' ' + loopvar + '<=' + CopyArr(nsm, cur - nsm));
|
|
|
|
lastp := cur;
|
|
if GetToken = 'DO' then
|
|
begin
|
|
DoCommand;
|
|
if Error then Exit;
|
|
MemoTo.Add(loopvar + ' ' + loopvar + '+1');
|
|
MemoTo.Add(ttGoto + Chr(nl) + Chr(nl div 256));
|
|
bs := MemoTo[nl];
|
|
bs[2] := Chr(last);
|
|
bs[3] := Chr(last div 256);
|
|
MemoTo[nl] := bs;
|
|
end
|
|
else
|
|
AddError('Need "do" here');
|
|
end
|
|
else
|
|
if S = 'DOWNTO' then
|
|
begin
|
|
nsm := cur;
|
|
DoExpression;
|
|
if Error then Exit;
|
|
nl := last;
|
|
MemoTo.Add(ttIf + ' ' + loopvar + '>=' + CopyArr(nsm, cur - nsm));
|
|
|
|
lastp := cur;
|
|
if GetToken = 'DO' then
|
|
begin
|
|
DoCommand;
|
|
if Error then Exit;
|
|
MemoTo.Add(loopvar + ' ' + loopvar + '-1');
|
|
MemoTo.Add(ttGoto + Chr(nl) + Chr(nl div 256));
|
|
bs := MemoTo[nl];
|
|
bs[2] := Chr(last);
|
|
bs[3] := Chr(last div 256);
|
|
MemoTo[nl] := bs;
|
|
end
|
|
else
|
|
AddError('Need "do" here');
|
|
end
|
|
else
|
|
AddError('Need "to" here');
|
|
end;
|
|
|
|
|
|
procedure DoFuncId;
|
|
begin
|
|
SkipSpace;
|
|
if buf^[cur] in ['A'..'Z', 'a'..'z'] then
|
|
while buf^[cur] in ['0'..'9', '_', '.', 'A'..'Z', 'a'..'z'] do Inc(cur)
|
|
else Error := True;
|
|
end;
|
|
|
|
procedure DoCommand;
|
|
label 1;
|
|
var
|
|
nsm: Integer;
|
|
begin
|
|
1:Error := False;
|
|
nsm := cur;
|
|
lastp := cur;
|
|
bs := GetToken;
|
|
if bs = 'BEGIN' then DoBegin
|
|
else
|
|
if bs = 'IF' then DoIf
|
|
else
|
|
if bs = 'REPEAT' then DoRepeat
|
|
else
|
|
if bs = 'WHILE' then DoWhile
|
|
else
|
|
if bs = 'GOTO' then DoGoto
|
|
else
|
|
if bs = 'FOR' then
|
|
DoFor
|
|
else
|
|
if Pos('END', bs) = 1 then
|
|
begin
|
|
cur := nsm;
|
|
Error := False;
|
|
end
|
|
else
|
|
begin
|
|
cur := nsm;
|
|
DoLabel;
|
|
if Error then
|
|
begin
|
|
Error := False;
|
|
cur := nsm;
|
|
DoVariable;
|
|
if not Error then
|
|
begin
|
|
cur := nsm;
|
|
DoEqual;
|
|
end
|
|
else
|
|
begin
|
|
cur := nsm;
|
|
Error := False;
|
|
DoExpression;
|
|
MemoTo.Add(ttProc + Trim(CopyArr(nsm, cur - nsm)));
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
AddLabel(Trim(CopyArr(nsm, cur - nsm)), last);
|
|
goto 1;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Error := False;
|
|
GetMem(buf, 32000);
|
|
FillChar(buf^, 32000, 0);
|
|
len := 0;
|
|
for i := 0 to MemoFrom.Count - 1 do
|
|
begin
|
|
s := ' ' + MemoFrom[i] + #13;
|
|
|
|
while Pos(#9, s) <> 0 do
|
|
s[Pos(#9, s)] := ' ';
|
|
|
|
Move(S[1], Buf^[len], Length(S));
|
|
Inc(len, Length(s));
|
|
end;
|
|
cur := 0; labc := 0;
|
|
MemoTo.Clear;
|
|
MemoErr.Clear;
|
|
if len > 0 then
|
|
DoCommand;
|
|
FreeMem(buf, 32000);
|
|
for i := 0 to MemoTo.Count - 1 do
|
|
if MemoTo[i][1] = ttGoto then
|
|
begin
|
|
s := Remain(MemoTo[i], 2) + ':';
|
|
for j := 0 to labc do
|
|
if labels[j].name = s then
|
|
begin
|
|
s := MemoTo[i]; s[2] := Chr(labels[j].n);
|
|
s[3] := Chr(labels[j].n div 256); MemoTo[i] := s;
|
|
break;
|
|
end;
|
|
end
|
|
else if MemoTo[i][1] = ttIf then
|
|
begin
|
|
s := FParser.Str2OPZ(Remain(MemoTo[i], 4));
|
|
MemoTo[i] := Copy(MemoTo[i], 1, 3) + s;
|
|
end
|
|
else if MemoTo[i][1] = ttProc then
|
|
begin
|
|
s := FParser.Str2OPZ(Remain(MemoTo[i], 2));
|
|
MemoTo[i] := Copy(MemoTo[i], 1, 1) + s;
|
|
end
|
|
else
|
|
begin
|
|
j := 1;
|
|
GetIdentify(MemoTo[i], j);
|
|
len := j;
|
|
s := FParser.Str2OPZ(Remain(MemoTo[i], j));
|
|
MemoTo[i] := Copy(MemoTo[i], 1, len) + s;
|
|
end;
|
|
end;
|
|
|
|
procedure TfrInterpretator.DoScript(Memo: TStringList);
|
|
var
|
|
i, j: Integer;
|
|
s, s1: String;
|
|
begin
|
|
i := 0;
|
|
while i < Memo.Count do
|
|
begin
|
|
s := Memo[i];
|
|
j := 1;
|
|
if s[1] = ttIf then
|
|
begin
|
|
if FParser.CalcOPZ(Remain(s, 4)) = 0 then
|
|
begin
|
|
i := Ord(s[2]) + Ord(s[3]) * 256;
|
|
continue;
|
|
end;
|
|
end
|
|
else if s[1] = ttGoto then
|
|
begin
|
|
i := Ord(s[2]) + Ord(s[3]) * 256;
|
|
continue;
|
|
end
|
|
else if s[1] = ttProc then
|
|
FParser.CalcOPZ(Remain(s, 2))
|
|
else
|
|
begin
|
|
s1 := GetIdentify(s, j);
|
|
SetValue(s1, FParser.CalcOPZ(Remain(s, j)));
|
|
end;
|
|
Inc(i);
|
|
end;
|
|
end;
|
|
|
|
procedure TfrInterpretator.GetValue(const Name: String; var Value: Variant);
|
|
begin
|
|
// abstract method
|
|
end;
|
|
|
|
procedure TfrInterpretator.SetValue(const Name: String; Value: Variant);
|
|
begin
|
|
// abstract method
|
|
end;
|
|
|
|
procedure TfrInterpretator.DoFunction(const name: String; p1, p2, p3: Variant;
|
|
var val: Variant);
|
|
begin
|
|
// abstract method
|
|
end;
|
|
|
|
end.
|