Power-Programmierung/CD1.mdf/pascal/library/dos/nicol/sti_expr/sti_expr.pas

Pascal/Delphi Source File | 1979-12-31 | 9.0 KB | 315 lines

unit STI_EXPR;                              { expression parser             }

interface

Var
  STI_CALCErrorMsg  : string;               { returned error message        }
  BuffPos           : word;                 { position in buffer            }


function STI_Expression(Var Inbuffer; Size : word) : real;

{---------------------------------------------------------------------------}

implementation

Const
  BUFFSIZE         = 255;                   { size of the buffer            }

  NUMBER           = 1;                     { a number TOKEN                }
  LEFTBRACKET      = 2;                     { (                             }
  RIGHTBRACKET     = 3;                     { )                             }

  PLUS             = 4;                     { +                             }
  MINUS            = 5;                     { -                             }
  TIMES            = 6;                     { *                             }
  DIVIDE           = 8;                     { /                             }
  SHIFTRIGHT       = 9;                     { SHR                           }
  SHIFTLEFT        = 10;                    { SHL                           }
  MODULO           = 11;                    { MOD                           }
  ANDOP            = 13;                    { AND                           }
  OROP             = 14;                    { OR                            }

  ARCTANGENT       = 15;                    { ARCTAN                        }
  COSINE           = 16;                    { COS                           }
  EXPONENTIAL      = 17;                    { EXP                           }
  SINE             = 20;                    { SIN                           }
  SQUARE           = 21;                    { SQR                           }
  SQUAREROOT       = 22;                    { SQRT                          }


Type
  BigStr = Packed Array[0..255] of char;    { a buffer : just like a string }

Var
  Buffer    : ^BigStr;
  Token     : string;
  TokenType : byte;
  MaxLength : word;

{---------------------------------------------------------------------------}

procedure KeySearch(Key : string);          { SLOWLY find a keyword         }
                                            { assign TOKEN to TokenType     }
begin
  if Key = 'SHR'     then TokenType := SHIFTRIGHT     else
  if Key = 'SHL'     then TokenType := SHIFTLEFT      else
  if Key = 'MOD'     then TokenType := MODULO         else
  if Key = 'AND'     then TokenType := ANDOP          else
  if Key = 'OR'      then TokenType := OROP           else

  if Key = 'ARCTAN'  then TokenType := ARCTANGENT     else
  if Key = 'COS'     then TokenType := COSINE         else
  if Key = 'EXP'     then TokenType := EXPONENTIAL    else
  if Key = 'SIN'     then TokenType := SINE           else
  if Key = 'SQR'     then TokenType := SQUARE         else
  if Key = 'SQRT'    then TokenType := SQUAREROOT     else
    begin
      STI_CALCErrorMsg := 'UnKnown Identifier';
    end;

end;

{---------------------------------------------------------------------------}

procedure GetToken;                         { dig a token out of the buffer }

Var
  Dummy : string;

begin
  Dummy := '';
  Token := '';
  TokenType := 0;
  while (Buffer^[BuffPos] < #33) and (BuffPos < MaxLength) do
    Inc(BuffPos);
  case Buffer^[BuffPos] of
    '0'..'9' : begin
                 while (Buffer^[BuffPos] in ['0'..'9','.']) and (BuffPos <= MaxLength) do
                   begin
                     Dummy := Dummy + Buffer^[BuffPos];
                     Inc(BuffPos);
                   end;
                 TokenType := NUMBER;
               end;
    '(',')'  : begin
                 Dummy := Buffer^[BuffPos];
                 case Dummy[1] of
                   '('  : TokenType := LEFTBRACKET;
                   ')'  : TokenType := RIGHTBRACKET;
                 end;
                 Inc(BuffPos);
               end;
    '^','%',
    '+','-',
    '*','/'  : begin
                 Dummy := Buffer^[BuffPos];
                 case Dummy[1] of
                   '+'  : TokenType := PLUS;
                   '-'  : TokenType := MINUS;
                   '*'  : TokenType := TIMES;
                   '/'  : TokenType := DIVIDE;
                   '^'  : TokenType := EXPONENTIAL;
                   '%'  : TokenType := MODULO;
                 end;
                 Inc(BuffPos);
               end;
    'A'..'Z',
    'a'..'z' : begin
                 while (UpCase(Buffer^[BuffPos]) in ['A'..'Z']) and (BuffPos < MaxLength) do
                   begin
                     Dummy := Dummy + Buffer^[BuffPos];
                     Inc(BuffPos);
                   end;
                 KeySearch(Dummy);
               end;
  end;{case}
  Token    := Dummy;
end;

{---------------------------------------------------------------------------}

procedure Unary(Op : byte; Var Result : real); { unary operators            }

begin
  case Op of
    PLUS        : Result := abs(Result);
    MINUS       : Result := -Result;
    ARCTANGENT  : Result := ArcTan(Result);
    COSINE      : Result := Cos(Result);
    SINE        : Result := Sin(Result);
    SQUARE      : Result := Sqr(Result);
    SQUAREROOT  : Result := Sqrt(Result);
  end;
end;

{---------------------------------------------------------------------------}

procedure DoArith(Op : byte; Var A,B : real); { do the arithmetic           }

begin
  case Op of
    PLUS           : A := A +         B;
    MINUS          : A := A -         B;
    TIMES          : A := A *         B;
    DIVIDE         : A := A /         B;
    MODULO         : A := Trunc(A) mod Trunc(B);
    SHIFTRIGHT     : A := Trunc(A) shr Trunc(B);
    SHIFTLEFT      : A := Trunc(A) shl Trunc(B);
    ANDOP          : A := Trunc(A) and Trunc(B);
    OROP           : A := Trunc(A) or  Trunc(B);
    EXPONENTIAL    : begin
                     end;
  end;
end;

{---------------------------------------------------------------------------}

procedure Primitive(Var Result : Real);     { simple value                  }

Var
  Test : integer;

begin
  if TokenType <> NUMBER then
    STI_CALCErrorMsg := 'Number Expected'
  else
    begin
      Val(Token,Result,Test);
      if Test <> 0 then
        STI_CALCErrorMsg := 'Bad numeric format';
      GetToken;
    end;
end;

{---------------------------------------------------------------------------}

procedure Level2(Var Result : Real); forward;

procedure Level6(Var Result : Real);

Var
  Dummy : real;

begin
  if TokenType = LEFTBRACKET then
    begin
      GetToken;
      Level2(Result);
      if TokenType <> RIGHTBRACKET then
        STI_CALCErrorMsg := ') Expected';
      GetToken;
    end
  else
    begin
      Primitive(Result);
    end;
end;

{---------------------------------------------------------------------------}

procedure Level5(Var Result : Real);

Var
  Dummy : real;
  Oper  : byte;

begin
  Oper := 0;
  if (TokenType = PLUS) or (TokenType = MINUS) or
     ((TokenType >= ARCTANGENT) and (TokenType <= SQUAREROOT)) then
    begin
      Oper := TokenType;
      GetToken;
    end;
  Level6(Result);
  if Oper <> 0 then
    begin
      Unary(Oper,Result);
    end;
end;

{---------------------------------------------------------------------------}

procedure Level4(Var Result : Real);

Var
  Dummy : real;
  Oper  : byte;

begin
  Level5(Result);
  if TokenType = EXPONENTIAL then
    begin
      Oper := TokenType;
      GetToken;
      Level4(Dummy);
      DoArith(Oper,Result,Dummy);
    end;
end;

{---------------------------------------------------------------------------}

procedure Level3(Var Result : Real);

Var
  Dummy : real;
  Oper  : byte;

begin
  Level4(Result);
  while (TokenType = TIMES) or (TokenType = DIVIDE) or
        ((TokenType >= SHIFTRIGHT) and (TokenType <= OROP)) do
    begin
      Oper := TokenType;
      GetToken;
      Level4(Dummy);
      DoArith(Oper,Result,Dummy);
    end;
end;

{---------------------------------------------------------------------------}

procedure Level2(Var Result : Real);

Var
  Dummy : real;
  Oper  : byte;

begin
  Level3(Result);
  while (TokenType = PLUS) or (TokenType = MINUS) do
    begin
      Oper := TokenType;
      GetToken;
      Level3(Dummy);
      DoArith(Oper,Result,Dummy);
    end;
end;

{---------------------------------------------------------------------------}

function STI_Expression(Var Inbuffer; Size : word) : real;

Var
  Dummy  : BigStr absolute InBuffer;
  Result : Real;

begin
  Buffer    := addr(Dummy[1]);
  BuffPos   := 0;
  MaxLength := Size;
  STI_CALCErrorMsg  := '';
  GetToken;
  if Token = '' then
    begin
      STI_CALCErrorMsg := 'No Expression To Parse';
    end;
  Level2(Result);                           { recursively descend the parse }
  STI_Expression := Result;
end;

{---------------------------------------------------------------------------}

begin
end.