Pascal Script Examples

program psce;
{$APPTYPE CONSOLE}

{$IFDEF FPC}
{$mode delphi}{$H+}
{$ENDIF}

uses
  SysUtils,interfaces,Classes,Forms,uPSCompiler, uPSR_std, uPSC_std, uPSR_classes, uPSC_classes,   uPSRuntime, uPSComponent,uPSDisassembly,
   uPSR_dateutils,uPSC_dateutils,uPSC_forms,uPSR_forms,uPSC_controls,uPSR_controls,uPSR_dll,uPSC_dll;

type
  TPSCE = class
   protected
   FScr: TPSScript;
   procedure SaveCompiled(var Data : String);
   procedure SaveDissasembly(var Data : String);
   procedure OnCompile(Sender: TPSScript);
   procedure OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
  public
   constructor Create;
   destructor Destroy; override;
   function Compile(const FileName: string): Boolean;
   function Execute: Boolean;
 end;

var
 aPSCE: TPSCE;
 SFile,Data : String;

procedure MWritedt(d : TDateTime);
var
 s : String;
begin
  s := DateToStr(d) + ' ' + TimeToStr(d);
  Write(s);
end;


procedure MWrites(const s: string);
begin
  Write(s);
end;

procedure MWritei(const i: Integer);
begin
  Write(i);
end;

procedure MWrited(const d: Double);
begin
 Write(d:0:1);
end;

procedure MWriteln;
begin
  Writeln;
end;

procedure MVal(const s: string; var n, z: Integer);
begin
  Val(s, n, z);
end;

constructor TPSCE.Create; begin

 FScr:=TPSScript.Create(nil);
 FScr.OnCompile:= OnCompile;
 FScr.OnExecImport := OnExecImport;

end;

destructor TPSCE.Destroy; begin

 FScr.Free;

end;

procedure TPSCE.SaveCompiled(var Data : String); var

 OutFile: string;
 Fx : Longint ;

begin

 OutFile := ExtractFilePath(ParamStr(0)) + ChangeFileExt(SFile,'.out');
 Fx:= FileCreate(OutFile) ;
 FileWrite(Fx,Data[1],Length(Data));
 FileClose (Fx) ;

end;

procedure TPSCE.SaveDissasembly(var Data : String); var

 OutFile: string;
 Fx : Longint ;

begin

 OutFile := ExtractFilePath(ParamStr(0)) + ChangeFileExt(SFile,'.dis');
 Fx:= FileCreate(OutFile) ;
 FileWrite(Fx,Data[1],Length(Data));
 FileClose (Fx) ;

end;

procedure TPSCE.OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter); begin RIRegister_Std(x); RIRegister_Classes(x,true); RIRegister_Forms(x); RIRegister_Controls(x); RegisterDateTimeLibrary_R(se); RegisterDLLRuntime(se); end;

procedure TPSCE.OnCompile(Sender: TPSScript); begin

 RegisterDateTimeLibrary_C(Sender.Comp);
 Sender.AddFunction(@MWrites, 'procedure Writes(const s: string)');
 Sender.AddFunction(@MWritedt,'procedure WriteDT(d : TDateTime)');
 Sender.AddFunction(@MWritei, 'procedure Writei(const i: Integer)');
 Sender.AddFunction(@MWrited, 'procedure Writed(const f: Double)');
 Sender.AddFunction(@MWriteln, 'procedure Writeln');
 Sender.AddFunction(@MVal, 'procedure Val(const s: string; var n, z: Integer)');
 SIRegister_Std(Sender.Comp);
 SIRegister_Classes(Sender.Comp,true);
 SIRegister_Forms(Sender.Comp);
 SIRegister_Controls(Sender.Comp);

end;

function TPSCE.Compile(const FileName: string): Boolean; var

 S: TStringList;
 i: Integer;

begin

 Result:=False;
 if FileExists(FileName) then begin
   S:=TStringList.Create;
   S.LoadFromFile(FileName);
   FScr.Script:=S;
   Result:=FScr.Compile;
   S.Free;
   if not Result then
     if FScr.CompilerMessageCount > 0 then
       for i:=0 to FScr.CompilerMessageCount-1 do
         Writeln(FScr.CompilerErrorToStr(i));
 end else Writeln('File not found: ', FileName);

end;

function TPSCE.Execute: Boolean; begin

 Result:=FScr.Execute;
 if not Result then
   Writeln('Run-time error:' + FScr.ExecErrorToString);

end;

begin

 Application.Initialize;
 aPSCE:=TPSCE.Create;
 if ParamCount = 0 then 
 begin
   Writeln('Usage: ', ExtractFileName(ParamStr(0)), ' [--compile|--dissasembly] <script.pss>');
   Writeln();
   Writeln('--compile : Save compiled script bytecode');
   Writeln('--dissasembly: Save dissasembly of script');
   Exit;
 end;
 
SFile := ParamStr(1);
if (ParamStr(1)='--compile') or (ParamStr(1)='--dissasembly') then
begin
 SFile := ParamStr(2);
 aPSCE.Compile(SFile);
 aPSCE.FScr.GetCompiled(Data);
 if Paramstr(1)='--compile' then aPSCE.SaveCompiled(Data);
 if Paramstr(1)='--dissasembly' then
  begin
   if not IFPS3DataToText(Data,Data) then Writeln('Cannot create dissasembly!')
   else
   aPSCE.SaveDissasembly(Data);
 end;
Exit;
end;

aPSCE.Compile(SFile);
aPSCE.Execute;
aPSCE.Free;

end.

--Forest 23:00, 22 Oct 2005 (CEST)