Difference between revisions of "Pascal Script Examples"

From Lazarus wiki
Jump to navigationJump to search
Line 1: Line 1:
<code>
+
<source>
 
   
 
   
 
  program psce;
 
  program psce;
Line 26: Line 26:
 
     function Execute: Boolean;
 
     function Execute: Boolean;
 
   end;
 
   end;
</code>
 
 
<code>
 
  
 
  var
 
  var
Line 48: Line 45:
 
   Write(s);
 
   Write(s);
 
  end;
 
  end;
+
 
 
 
   
 
   
 
  procedure MWritei(const i: Integer);
 
  procedure MWritei(const i: Integer);
Line 71: Line 67:
 
  end;
 
  end;
  
</code>
+
 
 
constructor TPSCE.Create;
 
constructor TPSCE.Create;
 
begin
 
begin
Line 198: Line 194:
  
  
</code>
+
</source>
  
 
--[[User:Forest|Forest]] 23:00, 22 Oct 2005 (CEST)
 
--[[User:Forest|Forest]] 23:00, 22 Oct 2005 (CEST)

Revision as of 22:03, 22 October 2005

 
 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)