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