1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
unit Main;
{$mode objfpc}{$H+}
interface
uses
Classes, ExtCtrls, StdCtrls, SysUtils, FileUtil, Forms, Controls, Graphics,
Dialogs, TAFuncSeries, TAGraph;
type
TForm1 = class(TForm)
btnRefresh: TButton;
Chart1: TChart;
Chart1FuncSeries1: TFuncSeries;
edFormula: TEdit;
Panel1: TPanel;
procedure btnRefreshClick(Sender: TObject);
procedure Chart1FuncSeries1Calculate(const AX: Double; out AY: Double);
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
uses
uPSCompiler, uPSRuntime, uPSUtils;
type
TUserFunction = function (AX: Double): Double of object;
var
exec: TPSExec;
userFunc: TUserFunction;
function ScriptOnExportCheck(
ASender: TPSPascalCompiler; AProc: TPSInternalProcedure;
const AProcDecl: string): Boolean;
begin
if AProc.Name = 'FN' then
if not ExportCheck(ASender, AProc, [btDouble, btDouble], [pmIn]) then begin
ASender.MakeError('', ecTypeMismatch, '');
exit(false);
end;
Result := true;
end;
function ScriptOnUses(ASender: TPSPascalCompiler; const AName: string): Boolean;
begin
Result := AName = 'SYSTEM';
end;
procedure CompileScript(const AScript: string);
var
data: string;
begin
FreeAndNil(exec);
with TPSPascalCompiler.Create do
try
OnUses := @ScriptOnUses;
OnExportCheck := @ScriptOnExportCheck;
AllowNoBegin := true;
AllowNoEnd := true;
if not Compile(AScript) then exit;
GetOutput(data);
finally
Free;
end;
exec := TPSExec.Create;
if not exec.LoadData(data) then begin
FreeAndNil(exec);
exit;
end;
userFunc := TUserFunction(exec.GetProcAsMethodN('FN'));
if userFunc = nil then
FreeAndNil(exec);
end;
{ TForm1 }
procedure TForm1.btnRefreshClick(Sender: TObject);
begin
CompileScript(
'function fn(x: Double): Double; begin Result := ' + edFormula.Text +
'; end;');
with edFormula do
if exec = nil then
Color := clRed
else
Color := clDefault;
Chart1FuncSeries1.Active := true;
Chart1.Invalidate;
end;
procedure TForm1.Chart1FuncSeries1Calculate(const AX: Double; out AY: Double);
begin
if exec = nil then
AY := AX
else
AY := userFunc(AX);
end;
finalization
FreeAndNil(exec);
end.
|
