скрыть

скрыть

  Форум  

Delphi FAQ - Часто задаваемые вопросы

| Базы данных | Графика и Игры | Интернет и Сети | Компоненты и Классы | Мультимедиа |
| ОС и Железо | Программа и Интерфейс | Рабочий стол | Синтаксис | Технологии | Файловая система |



Google  
 

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



Автор: Сергей Втюрин aka Nemo

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

Эта программа представляет собой простенький компилятор синтаксических выражений. "Ну опять", - скажет невнимательный читатель, но мы то с тобой внимательные, и понимаем что компилятор, это совсем не то что валяется на каждом программистском сайте. В отличие от парсера (или интерпретатора) такую штуку встретить можно несколько реже. Если честно, то когда она мне была нужна, я ее нигде не встретил. И поэтому родилась эта программа.

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

Да в общем-то немного, и ценности в ней мало :). Она может вычислять выражения (тип - вещественное число с плавающей точкой (на момент написания это называлось Real)) с использованием операций (+,-,/,*). Мало... А разве сложно дописать пару строк чтобы обработать Y или экспоненту коли они будут нужны?

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

В силу своей огромной нескромности я полагаю, что кому-нибудь это все может быть интересно как пример непосредственного формирования кода в памяти и его исполнения.

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

(да я знаю, что благодарности помещают в конце, но там их редко кто читает :)) так вот отдельное спасибо: Спасибо человеку, который сделал из меня программиста. Спасибо Королеве Елене Филипповой. Если вы здесь, то вы знаете за что.:) Эта программа написана в то время когда меня можно было легко "взять на "слабо"". Так вот спасибо тому кто меня подначил на ее написание :)

Но к делу

Взявшись оформлять этот пример для общественности, я понял, что меняются не только времена и люди, но и исходники лежащие в архиве. Да их не узнать! Да неужели это писал я? Да... точно... странно... Но ведь он все еще работает! Вдвойне странно... Так что если что - сильно не ругаться - я был молодой и временами делал некрасивости. Старинный закон гласит: последняя ошибка программы выявляется через 7 лет эксплуатации. Если вы заметили ошибку, которой не заметил я - то буду благодарен, если вы мне о ней напишите. Я, пожалуй, не буду следовать примеру Д. Кнута и высылать деньги за замеченные ошибки, но спасибо скажу :).

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

Компилятор он и есть компилятор. Сначала выражение надо скомпилировать. Делается это с помощью функции

function Prepare(Ex:String):real; 

которая вызывает

function preCalc(Ex:String):real;

формирующую код, вычисляющий заданное выражение. Как можно догадаться, Ex - это строка, содержащая математическое выражение. Функция preCalc рекурсивна и распознавая полученную математику, попутно формируя исполняемый код. Она имеет мало проверок на корректность и нет нужды вводить туда мусор и радоваться, когда увидите что все повисло. Помните правило GIGO (Garbage in Garbage Out). Не надо также ставить 0 под знак деления. Но это уже не моя ошибка :)))

ВНИМАНИЕ:

ограничение на глубина рекурсии: полученый код не должен помещать в стек более 8 значений.Снятие этого ограничения опять же лишь вопрос практической реализации.

Для понятности формируемый код представляется в ближайшем Memo. Функция возвращает: а фиг его знает что она возвращает :) лучше не обращайте внимания :) Скомпилировали? Теперь можно и запускать: При компиляции мы сформировали процедуру с красноречивым названием:

proc:TProc;

где

type TProc=procedure;

пример запуска можно найти в

procedure TForm1.BitBtn1Click(Sender: TObject);

Также встречаются процедуры и функции:

function SecindBracket(Ex:String;first:integer):Integer; 

вот уж и не помню, отчего появилось такое красивое название (скорее всего от очепятки), но все это призвано обработать скобки в выражении ,

procedure TForm1.BitBtn1Click(Sender: TObject); // Вычисляй

запускает вычисление, а также

procedure TForm1.Button2Click(Sender: TObject); // Speed test

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

I:=0; // обнуляем счетчик  

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


// Это 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






Copyright © 2004-2016 "Delphi Sources". Delphi World FAQ




Группа ВКонтакте   Ссылка на Twitter   Группа на Facebook