home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / kompon / d456 / CAJSCRPT.ZIP / ifps3 / demo / ifps3test1.pas < prev    next >
Pascal/Delphi Source File  |  2002-06-20  |  11KB  |  439 lines
  1. unit ifps3test1;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   ExtCtrls, StdCtrls, ifps3utl, ifpscomp, ifps3, Menus, ifps3lib_std, 
  8.   ifps3lib_stdr, ifps3common;
  9.  
  10. type
  11.   TMainForm = class(TForm)
  12.     Memo1: TMemo;
  13.     Memo2: TMemo;
  14.     Splitter1: TSplitter;
  15.     MainMenu1: TMainMenu;
  16.     Toosl1: TMenuItem;
  17.     Compile1: TMenuItem;
  18.     CompilewithTimer1: TMenuItem;
  19.     File1: TMenuItem;
  20.     Exit1: TMenuItem;
  21.     N1: TMenuItem;
  22.     SaveAs1: TMenuItem;
  23.     Save1: TMenuItem;
  24.     Open1: TMenuItem;
  25.     New1: TMenuItem;
  26.     OpenDialog1: TOpenDialog;
  27.     SaveDialog1: TSaveDialog;
  28.     N2: TMenuItem;
  29.     Stop1: TMenuItem;
  30.     N3: TMenuItem;
  31.     CompileandDisassemble1: TMenuItem;
  32.     procedure Compile1Click(Sender: TObject);
  33.     procedure FormCreate(Sender: TObject);
  34.     procedure CompilewithTimer1Click(Sender: TObject);
  35.     procedure Exit1Click(Sender: TObject);
  36.     procedure New1Click(Sender: TObject);
  37.     procedure Open1Click(Sender: TObject);
  38.     procedure Save1Click(Sender: TObject);
  39.     procedure SaveAs1Click(Sender: TObject);
  40.     procedure Memo1Change(Sender: TObject);
  41.     procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  42.     procedure Stop1Click(Sender: TObject);
  43.     procedure CompileandDisassemble1Click(Sender: TObject);
  44.   private
  45.     fn: string;
  46.     changed: Boolean;
  47.     function SaveTest: Boolean;
  48.   public
  49.     { Public declarations }
  50.   end;
  51.  
  52. var
  53.   MainForm: TMainForm;
  54.  
  55. implementation
  56. uses
  57.   ifps3test2, ifps3disasm, ifpidelphi, ifpidelphiruntime, ifpidll2, ifpidll2runtime;
  58. {$R *.DFM}
  59.  
  60. function MyOnUses(Sender: TIFPSPascalCompiler; const Name: string): Boolean;
  61. begin
  62.   if Name = 'SYSTEM' then
  63.   begin
  64.     TIFPSPascalCompiler(Sender).AddFunction('procedure Writeln(s: string);');
  65.     TIFPSPascalCompiler(Sender).AddFunction('function Readln(question: string): string;');
  66.     Sender.AddConstantN('NaN', 'extended')^.Value.Value := transExtendedtoStr(0.0 / 0.0);
  67.     Sender.AddConstantN('Infinity', 'extended')^.Value.Value := transExtendedtoStr(1.0 / 0.0);
  68.     Sender.AddConstantN('NegInfinity', 'extended')^.Value.Value := transExtendedtoStr(- 1.0 / 0.0);
  69.     RegisterDelphiFunctionC(Sender, 'function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string;');
  70.     RegisterStandardLibrary_C(Sender);
  71.     Result := True;
  72.   end
  73.   else
  74.   begin
  75.     TIFPSPascalCompiler(Sender).MakeError('', ecUnknownIdentifier, '');
  76.     Result := False;
  77.   end;
  78. end;
  79.  
  80. function MyWriteln(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
  81. var
  82.   PStart: Cardinal;
  83. begin
  84.   PStart := Stack.Count - 1;
  85.   MainForm.Memo2.Lines.Add(LGetStr(Stack, PStart));
  86.   Result := True;
  87. end;
  88.  
  89. function MyReadln(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
  90. var
  91.   PStart: Cardinal;
  92. begin
  93.   PStart := Stack.Count - 2;
  94.   LSetStr(Stack, PStart + 1, InputBox(MainForm.Caption, LGetStr(stack, PStart), ''));
  95.   Result := True;
  96. end;
  97.  
  98. function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string;
  99. begin
  100.   Result := s1 + ' ' + IntToStr(s2) + ' ' + IntToStr(s3) + ' ' + IntToStr(s4) + ' - OK!';
  101.   S5 := s5 + ' '+ result + ' -   OK2!';
  102. end;
  103.  
  104. function SpecialProcImport(Sender: TIFPSExec; p: PIFProcRec): Boolean;
  105. begin
  106.   Result := ProcessDllImport(TIFPSExec(Sender), P);
  107. end;
  108.  
  109. var
  110.   I: Integer;
  111.  
  112. procedure RunLine(Sender: TIFPSExec);
  113. begin
  114.   i := (i + 1) mod 15;
  115.   if i = 0 then Application.ProcessMessages;
  116. end;
  117.  
  118. function MyExportCheck(Sender: TIFPSPascalCompiler; Proc: PIFPSProcedure; const ProcDecl: string): Boolean;
  119. begin
  120.   Result := TRue;
  121. end;
  122.  
  123.  
  124. procedure TMainForm.Compile1Click(Sender: TObject);
  125. var
  126.   x1: TIFPSPascalCompiler;
  127.   x2: TIFPSExec;
  128.   s: string;
  129.  
  130.   procedure Outputtxt(const s: string);
  131.   begin
  132.     Memo2.Lines.Add(s);
  133.   end;
  134.  
  135.   procedure OutputMsgs;
  136.   var
  137.     l: Longint;
  138.     b: Boolean;
  139.   begin
  140.     b := False;
  141.     for l := 0 to x1.MsgCount - 1 do
  142.     begin
  143.       Outputtxt(IFPSMessageToString(x1.Msg[l]));
  144.       if (not b) and (x1.Msg[l]^.MessageType = pterror) then
  145.       begin
  146.         b := True;
  147.         Memo1.SelStart := X1.Msg[l]^.Position;
  148.       end;
  149.     end;
  150.   end;
  151. begin
  152.   if tag <> 0 then exit;
  153.   Memo2.Clear;
  154.   x1 := TIFPSPascalCompiler.Create;
  155.   x1.OnExportCheck := MyExportCheck;
  156.   x1.OnUses := MyOnUses;
  157.   x1.OnExternalProc := DllExternalProc;
  158.   if x1.Compile(Memo1.Text) then
  159.   begin
  160.     Outputtxt('Succesfully compiled');
  161.     OutputMsgs;
  162.     if not x1.GetOutput(s) then
  163.     begin
  164.       x1.Free;
  165.       Outputtxt('[Error] : Could not get data');
  166.       exit;
  167.     end;
  168.     x1.Free;
  169.     x2 := TIFPSExec.Create;
  170.     RegisterDLLRuntime(x2);
  171.     tag := longint(x2);
  172.     if sender <> nil then
  173.       x2.OnRunLine := RunLine;
  174.     x2.RegisterFunctionName('WRITELN', MyWriteln, nil, nil);
  175.     x2.RegisterFunctionName('READLN', MyReadln, nil, nil);
  176.     RegisterDelphiFunctionR(x2, @importtest, 'IMPORTTEST', cdRegister);
  177.     RegisterStandardLibrary_R(x2);
  178.     if not x2.LoadData(s) then begin
  179.       Outputtxt('[Error] : Could not load data');
  180.       x2.Free;
  181.       exit;
  182.     end;
  183.     x2.RunScript;
  184.     if x2.ExceptionCode <> ENoError then
  185.       Outputtxt('[Runtime Error] : ' + TIFErrorToString(x2.ExceptionCode, x2.ExceptionString) +
  186.         ' in ' + IntToStr(x2.ExceptionProcNo) + ' at ' + IntToSTr(x2.ExceptionPos))
  187.     else
  188.       OutputTxt('Successfully executed');
  189.  
  190.     tag := 0;
  191.     x2.Free;
  192.   end
  193.   else
  194.   begin
  195.     Outputtxt('Failed when compiling');
  196.     OutputMsgs;
  197.     x1.Free;
  198.   end;
  199. end;
  200.  
  201. procedure TMainForm.FormCreate(Sender: TObject);
  202. begin
  203.   Caption := 'Innerfuse Pascal Script III';
  204.   fn := '';
  205.   changed := False;
  206.   Memo1.Lines.Text := 'Program IFSTest;'#13#10'Begin'#13#10'End.';
  207. end;
  208.  
  209. procedure TMainForm.CompilewithTimer1Click(Sender: TObject);
  210. var
  211.   Freq, Time1, Time2: Comp;
  212.   x1: TIFPSPascalCompiler;
  213.   x2: TIFPSExec;
  214.   s: string;
  215.  
  216.   procedure Outputtxt(const s: string);
  217.   begin
  218.     Memo2.Lines.Add(s);
  219.   end;
  220.  
  221.   procedure OutputMsgs;
  222.   var
  223.     l: Longint;
  224.     b: Boolean;
  225.   begin
  226.     b := False;
  227.     for l := 0 to x1.MsgCount - 1 do
  228.     begin
  229.       Outputtxt(IFPSMessageToString(x1.Msg[l]));
  230.       if (not b) and (x1.Msg[l]^.MessageType = pterror) then
  231.       begin
  232.         b := True;
  233.         Memo1.SelStart := X1.Msg[l]^.Position;
  234.       end;
  235.     end;
  236.   end;
  237.  
  238. begin
  239.   if tag <> 0 then exit;
  240.   if not QueryPerformanceFrequency(TLargeInteger((@Freq)^)) then
  241.   begin
  242.     ShowMessage('Your computer does not support Performance Timers!');
  243.     exit;
  244.   end;
  245.   QueryPerformanceCounter(TLargeInteger((@Time1)^));
  246.  
  247.   Memo2.Clear;
  248.   x1 := TIFPSPascalCompiler.Create;
  249.   x1.OnUses := MyOnUses;
  250.   x1.OnExternalProc := DllExternalProc;
  251. //  x1.WriteDebugInfo := CreateDebugOutput1.Checked;
  252. // No debug info for timing
  253.   x1.AllowUnit := True;
  254.   if x1.Compile(Memo1.Text) then
  255.   begin
  256.     Outputtxt('Succesfully compiled');
  257.     OutputMsgs;
  258.     if not x1.GetOutput(s) then
  259.     begin
  260.       x1.Free;
  261.       Outputtxt('[Error] : Could not get data');
  262.       exit;
  263.     end;
  264.     x1.Free;
  265.     x2 := TIFPSExec.Create;
  266.     tag := longint(x2);
  267.     RegisterDLLRuntime(x2);
  268.     x2.RegisterFunctionName('WRITELN', MyWriteln, nil, nil);
  269.     x2.RegisterFunctionName('READLN', MyReadln, nil, nil);
  270.     RegisterDelphiFunctionR(x2, @importtest, 'IMPORTTEST', cdRegister);
  271.     RegisterStandardLibrary_R(x2);
  272.     if not x2.LoadData(s) then
  273.     begin
  274.       Outputtxt('[Error] : Could not load data');
  275.       x2.Free;
  276.       exit;
  277.     end;
  278.     x2.RunScript;
  279.     if x2.ExceptionCode <> ENoError then
  280.       Outputtxt('[Runtime Error] : ' + TIFErrorToString(x2.ExceptionCode, x2.ExceptionString) +
  281.         ' in ' + IntToStr(x2.ExceptionProcNo) + ' at ' + IntToSTr(x2.ExceptionPos))
  282.     else
  283.       OutputTxt('Successfully executed');
  284.  
  285.     tag := 0;
  286.     x2.Free;
  287.   end
  288.   else
  289.   begin
  290.     Outputtxt('Failed when compiling');
  291.     OutputMsgs;
  292.     x1.Free;
  293.  
  294.     exit;
  295.   end;
  296.  
  297.   QueryPerformanceCounter(TLargeInteger((@Time2)^));
  298.   Memo2.Lines.Add('Time: ' + Sysutils.FloatToStr((Time2 - Time1) / Freq) +
  299.     ' sec');
  300. end;
  301.  
  302. procedure TMainForm.Exit1Click(Sender: TObject);
  303. begin
  304.   Close;
  305. end;
  306.  
  307. procedure TMainForm.New1Click(Sender: TObject);
  308. begin
  309.   if not SaveTest then
  310.     exit;
  311.   Memo1.Lines.Text := 'Program IFSTest;'#13#10'Begin'#13#10'End.';
  312.   Memo2.Lines.Clear;
  313.   fn := '';
  314. end;
  315.  
  316. function TMainForm.SaveTest: Boolean;
  317. begin
  318.   if changed then
  319.   begin
  320.     case MessageDlg('File is not saved, save now?', mtWarning, mbYesNoCancel, 0) of
  321.       mrYes:
  322.         begin
  323.           Save1Click(nil);
  324.           Result := not changed;
  325.         end;
  326.       mrNo: Result := True;
  327.     else
  328.       Result := False;
  329.     end;
  330.   end
  331.   else
  332.     Result := True;
  333. end;
  334.  
  335. procedure TMainForm.Open1Click(Sender: TObject);
  336. begin
  337.   if not SaveTest then
  338.     exit;
  339.   if OpenDialog1.Execute then
  340.   begin
  341.     Memo1.Lines.LoadFromFile(OpenDialog1.FileName);
  342.     changed := False;
  343.     Memo2.Lines.Clear;
  344.     fn := OpenDialog1.FileName;
  345.   end;
  346. end;
  347.  
  348. procedure TMainForm.Save1Click(Sender: TObject);
  349. begin
  350.   if fn = '' then
  351.   begin
  352.     Saveas1Click(nil);
  353.   end
  354.   else
  355.   begin
  356.     Memo1.Lines.SaveToFile(fn);
  357.     changed := False;
  358.   end;
  359. end;
  360.  
  361. procedure TMainForm.SaveAs1Click(Sender: TObject);
  362. begin
  363.   SaveDialog1.FileName := '';
  364.   if SaveDialog1.Execute then
  365.   begin
  366.     fn := SaveDialog1.FileName;
  367.     Memo1.Lines.SaveToFile(fn);
  368.     changed := False;
  369.   end;
  370. end;
  371.  
  372. procedure TMainForm.Memo1Change(Sender: TObject);
  373. begin
  374.   changed := True;
  375. end;
  376.  
  377. procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
  378. begin
  379.   CanClose := SaveTest;
  380. end;
  381.  
  382. procedure TMainForm.Stop1Click(Sender: TObject);
  383. begin
  384.   if tag <> 0 then
  385.     TIFPSExec(tag).Stop;
  386. end;
  387.  
  388. procedure TMainForm.CompileandDisassemble1Click(Sender: TObject);
  389. var
  390.   x1: TIFPSPascalCompiler;
  391.   s, s2: string;
  392.  
  393.   procedure OutputMsgs;
  394.   var
  395.     l: Longint;
  396.     b: Boolean;
  397.   begin
  398.     b := False;
  399.     for l := 0 to x1.MsgCount - 1 do
  400.     begin
  401.       Memo2.Lines.Add(IFPSMessageToString(x1.Msg[l]));
  402.       if (not b) and (x1.Msg[l]^.MessageType = pterror) then
  403.       begin
  404.         b := True;
  405.         Memo1.SelStart := X1.Msg[l]^.Position;
  406.       end;
  407.     end;
  408.   end;
  409. begin
  410.   if tag <> 0 then exit;
  411.   Memo2.Clear;
  412.   x1 := TIFPSPascalCompiler.Create;
  413.   x1.OnExternalProc := DllExternalProc;
  414.   x1.OnUses := MyOnUses;
  415.   if x1.Compile(Memo1.Text) then
  416.   begin
  417.     Memo2.Lines.Add('Succesfully compiled');
  418.     OutputMsgs;
  419.     if not x1.GetOutput(s) then
  420.     begin
  421.       x1.Free;
  422.       Memo2.Lines.Add('[Error] : Could not get data');
  423.       exit;
  424.     end;
  425.     x1.Free;
  426.     IFPS3DataToText(s, s2);
  427.     dwin.Memo1.Text := s2;
  428.     dwin.showmodal;
  429.   end
  430.   else
  431.   begin
  432.     Memo2.Lines.Add('Failed when compiling');
  433.     OutputMsgs;
  434.     x1.Free;
  435.   end;
  436. end;
  437.  
  438. end.
  439.