Компилятор синтаксических выражений

К сему прилагается слегка комментированный исходный код. Вряд ли кому нужны комментарии типа:

Ну вот и все... Буду рад если вам это пригодиться. Если какие пожелания - пишите. Конструктивная критика - пишите. Неконструктивная критика - тоже пишите - у меня файлы удаляются без помещения в корзину.

Это Unit1.pas

unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons,StrEx,Math; type TForm1 = class(TForm) Edit1: TEdit; BitBtn1: TBitBtn; Label1: TLabel; Memo1: TMemo; Button1: TButton; Edit2: TEdit; Label2: TLabel; Button2: TButton; procedure BitBtn1Click(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Edit1Change(Sender: TObject); procedure FormCreate(Sender: TObject); procedure Button2Click(Sender: TObject); private { Private declarations } public { Public declarations } end; TProc=procedure; var Form1: TForm1; A:array of real; CS:array of Byte; DS:array of Real; Res,X,Y:real; proc:TProc; function preCalc(Ex:String):real; function Prepare(Ex:String):real; function SecindBracket(Ex:String;first:integer):Integer; implementation {$R *.DFM} // это про скобки... это просто и не заслуживает большого внимания. function SecindBracket(Ex:String;first:integer):Integer; var i,BrQ:integer; begin Result:=0; case Ex[first] of '(': begin i:=first+1; BrQ:=0; while (i<=length(Ex)) do begin if (BrQ=0) and (Ex[i]=')') then begin Result:=i;exit;end; if Ex[i]='(' then Inc(BrQ) else if Ex[i]=')' then Dec(BrQ); i:=i+1; end; end; ')': begin i:=first-1; BrQ:=0; while (i>0) do begin if (BrQ=0) and (Ex[i]='(') then begin Result:=i;exit;end; if Ex[i]='(' then Inc(BrQ) else if Ex[i]=')' then Dec(BrQ); i:=i-1; end; end; end; end; // а вот тут мы собственно и формируем процедуру function Prepare(Ex:String):real; begin SetLength(Ds,1); // вот это будет заголовок SetLength(CS,6); cs[0]:=$8b; cs[1]:=$05; cs[2]:=(integer(@ds) and $000000FF) shr 0; cs[3]:=(integer(@ds) and $0000FF00) shr 8; cs[4]:=(integer(@ds) and $00FF0000) shr 16; cs[5]:=(integer(@ds) and $FF000000) shr 24; // вот это - вычисление X:=1; //догадайтесь зачем :) preCalc(Ex); // а вот это - завершение SetLength(CS,high(CS)+7); cs[high(CS)-5]:=$DD; cs[high(CS)-4]:=$1D; cs[high(CS)-3]:=(integer(@res) and $000000FF) shr 0; cs[high(CS)-2]:=(integer(@res) and $0000FF00) shr 8; cs[high(CS)-1]:=(integer(@res) and $00FF0000) shr 16; cs[high(CS)-0]:=(integer(@res) and $FF000000) shr 24; SetLength(CS,high(CS)+2); // ну и не забудем про RET cs[high(CS)]:=$C3;// ret proc:=pointer(cs); end; // будем формировать код рассчета. function preCalc(Ex:String):real; var Sc,i,j:integer; s,s1:String; A,B:real; const Op: array [0..3] of char =('+','-','/','*'); begin s:=''; // да всегда инициализируйте переменные ваши for i:=1 to length(Ex) do if ex[i]<>' ' then s:=s+ex[i]; // чтобы под ногами не путались :) while SecindBracket(s,Length(s))=1 do s:=copy(s,2,Length(s)-2);// скобки if s='' then begin Result:=0; ShowMessage('Error !'); exit; end; val(s,Result,i); // это число ? а какое ? if i=0 then begin // ага это число. так и запишем Form1.Memo1.Lines.Add('fld '+FloatToStr(result)); SetLength(Ds,high(ds)+2); Ds[high(ds)]:=Result; SetLength(CS,high(CS)+4); cs[high(Cs)]:=high(ds)*8; cs[high(Cs)-1]:=$40; cs[high(Cs)-2]:=$DD; exit; end; if (s='x') or (s='X') then begin // опа, да это же Икс ! Form1.Memo1.Lines.Add('fld X'); SetLength(CS,high(CS)+7); cs[high(CS)-5]:=$DD; cs[high(CS)-4]:=$05; cs[high(CS)-3]:=(integer(@x) and $000000FF) shr 0; cs[high(CS)-2]:=(integer(@x) and $0000FF00) shr 8; cs[high(CS)-1]:=(integer(@x) and $00FF0000) shr 16; cs[high(CS)-0]:=(integer(@x) and $FF000000) shr 24; end; // это все еще выражение :( ох не кончились наши мучения i:=-1; j:=0; while j<=1 do Begin i:=length(s); Sc:=0; while i>0 do begin // ну скобки надо обойти if s[i]=')' then Inc(Sc); if s[i]='(' then Dec(Sc); if Sc<>0 then begin dec(i); continue; end; if (s[i]=Op[j*2]) then begin j:=j*2+10; break; end; if (s[i]=Op[j*2+1]) then begin j:=j*2+11; break; end; dec(i); end; inc(j); End; //('+','-','/','*'); // а вот и рекурсия - все что справа и слева от меня пусть обработает ... // ой да это же я:) Ну а я так уж и быть сформирую код операции в середине :) case j of 11: begin preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); Form1.Memo1.Lines.Add('FAddp St(1),st'); // cs //fAddP st(1),st // [DE C1] SetLength(CS,high(CS)+3); cs[high(Cs)]:=$C1; // вот такой код сформируем cs[high(Cs)-1]:=$DE; end; // далее - аналогично для каждой операции 12: begin preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); Form1.Memo1.Lines.Add('FSubP St(1),st'); //fSubP st(1),st // [DE E9] SetLength(CS,high(CS)+3); cs[high(Cs)]:=$E9; cs[high(Cs)-1]:=$DE; end; 13: begin try preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); Form1.Memo1.Lines.Add('fdivP st(1),st'); //fDivP st(1),st // [DE F9] SetLength(CS,high(CS)+3); cs[high(Cs)]:=$F9; cs[high(Cs)-1]:=$DE; except ShowMessage('Division by zero !... '); preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); exit; end; end; 14: begin preCalc(copy(s,1,i-1) ); preCalc(copy(s,i+1,length(s)-i) ); Form1.Memo1.Lines.Add('FMulp St(1),st'); //fMulP st(1),st // [DE C9] SetLength(CS,high(CS)+3); cs[high(Cs)]:=$C9; cs[high(Cs)-1]:=$DE; end; end; end; // Вычисляй procedure TForm1.BitBtn1Click(Sender: TObject); begin x:=StrToFloat(Edit2.text); if (@proc<>nil) then proc; // Вычисляй Label1.caption:=FloatToStr( res ); end; // это всякие сервисные функции procedure TForm1.Button1Click(Sender: TObject); begin Memo1.Clear; Prepare(Edit1.text); BitBtn1.Enabled:=true; end; procedure TForm1.Edit1Change(Sender: TObject); begin BitBtn1.Enabled:=false; end; procedure TForm1.FormCreate(Sender: TObject); begin Edit1.OnChange(self); end; // а это для того чтобы посмотреть какой за быстрый получился код procedure TForm1.Button2Click(Sender: TObject); //Speed test var t:TDateTime; i:integer; const N=$5000000; //количество повторений begin if @proc=nil then exit; t:=now; for i:=0 to N do begin x:=i; proc; x:=res; end; t:=now-t; Memo1.lines.add('work time for '+inttostr(N)+' repeats ='+TimeToStr(t)+' sec'); Memo1.lines.add('='+FloatToStr(t)+ ' days' ); end; end.

а это Unit1.dfm

object Form1: TForm1
  Left = 175
  Top = 107
  Width = 596
  Height = 375
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 448
    Top = 56
    Width = 6
    Height = 13
    Caption = '[]'
  end
  object Label2: TLabel
    Left = 19
    Top = 12
    Width = 13
    Height = 13
    Caption = 'X='
  end
  object Edit1: TEdit
    Left = 16
    Top = 32
    Width = 417
    Height = 21
    TabOrder = 0
    Text = '((24/2)+3*(7-x))'
    OnChange = Edit1Change
  end
  object BitBtn1: TBitBtn
    Left = 448
    Top = 32
    Width = 75
    Height = 22
    TabOrder = 1
    OnClick = BitBtn1Click
    Kind = bkOK
  end
  object Memo1: TMemo
    Left = 16
    Top = 80
    Width = 241
    Height = 249
    TabOrder = 2
  end
  object Button1: TButton
    Left = 448
    Top = 2
    Width = 75
    Height = 25
    Caption = 'prepare'
    TabOrder = 3
    OnClick = Button1Click
  end
  object Edit2: TEdit
    Left = 36
    Top = 8
    Width = 53
    Height = 21
    TabOrder = 4
    Text = '2'
  end
  object Button2: TButton
    Left = 264
    Top = 80
    Width = 75
    Height = 25
    Caption = 'Speed test'
    TabOrder = 5
    OnClick = Button2Click
  end
end

Сергей Втюрин aka Nemo

Смотрите также материалы по темам:

[Компиляторы]

Обсуждение материала [ 11-10-2005 07:27 ] 6 сообщений

Что это и зачем или Немного наглой саморекламы

Что он может или Какие мы маленькие

Так зачем же это нужно.

Отдельное спасибо

Но к делу

Как все это работает:

Это Unit1.pas

а это Unit1.dfm

	"Knowledge itself is power" F.Bacon
Поиск \| Карта сайта \| Помощь \| О проекте \| ТТХ