FPC и PascalScript

Родная технология, позволяющая использовать "программу в программе"

Итак, делаем форму, TMemo и три кнопки TButton. Внутри Memo:

function TestFunc(s1,s2:string):boolean;
begin
    Result:=true;
end;

procedure TestProc;
begin
    ShowMessage('TestProc!');
end;

var i: integer;
    s: string;
begin
    s := '';
    for i:=65 to 75 do
        s:=s + chr(i);
    ShowMessage(GetCWD()+':'+s);
end.

Код главного юнита главной программы: Unit1.pas:

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, uPSComponent, Forms,
  Controls, Graphics, Dialogs, StdCtrls, uPSUtils, uPSCompiler;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Memo1: TMemo;
    PSScript1: TPSScript;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure PSScript1Compile(Sender: TPSScript);
    procedure PSScript1VerifyProc(Sender: TPSScript;
      Proc: TPSInternalProcedure; const Decl: tbtstring; var Error: Boolean);
  private
    { private declarations }
  public
    { public declarations }
  end;

  function GetCWD():string;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

function GetCWD():string;
begin
    Result:=ExtractFilePath(Application.ExeName);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
    PSScript1.Script.Assign(Memo1.Lines);
    if PSScript1.Compile then
        PSScript1.Execute
    else
        ShowMessage(PSScript1.CompilerErrorToStr(0));
end;

procedure TForm1.Button2Click(Sender: TObject);
type
    TProc = procedure of object;
var
    M: TProc;
begin
    M := TProc(PSScript1.GetProcMethod('TestProc'));
    if @M = nil then
        raise Exception.Create('Unable to call TestProc');
    M;
end;

procedure TForm1.Button3Click(Sender: TObject);
type
    TFunc = function(s1,s2:string):boolean of object;
var
    F: TFunc;
    b: boolean;
begin
    F := TFunc(PSScript1.GetProcMethod('TestFunc'));
    if @F = nil then
        raise Exception.Create('Unable to call TestFunc');
    b:=F('s1','s2');
    if b then ShowMessage('TRUE');
end;

procedure TForm1.PSScript1Compile(Sender: TPSScript);
begin
    Sender.AddFunction(@ShowMessage,'procedure ShowMessage(const aMsg: string);');
    Sender.AddFunction(@GetCWD,'function GetCWD():string;');
end;

procedure TForm1.PSScript1VerifyProc(Sender: TPSScript;
  Proc: TPSInternalProcedure; const Decl: tbtstring; var Error: Boolean);
begin
    if Proc.Name = 'TestProc' then begin
      if not ExportCheck(Sender.Comp, Proc, [btReturnAddress], []) then
      begin
        Sender.Comp.MakeError('', ecCustomError,
          'Function header for TestProc does not match.');
        Error := True;
      end
      else begin
        Error := False;
      end;
    end
    else if Proc.Name = 'TestFunc' then begin
      if not ExportCheck(Sender.Comp, Proc, [btS16, btString, btString], [pmIn,pmIn]) then
      begin
        Sender.Comp.MakeError('', ecCustomError,
          'Function header for TestFunc does not match.');
        Error := True;
      end
      else begin
        Error := False;
      end;
    end
    else
      Error := False;
end;

end.