home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
PASCAL
/
PARSTP20
/
PARSER.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-10-25
|
24KB
|
683 lines
(******************************************************************************
* parser *
* Ron Loewy, 1992. A mathematical recursive decent parser +-/*^ and functions *
* Version 2.0, Oct. 1993. *
******************************************************************************)
unit parser;
{$ifdef ovl}
{$O+,F+}
{$endif}
interface
uses
parseDB
;
type
TokenType = (Delimiter,Non,variable,Digit,endExpr,Error,Func);
TokenPtr = ^TokenRec;
TokenRec = Record
Next : TokenPtr;
Start,Close : Byte;
end;
var
parserErrStr : string;
ErrAt : Byte;
function GetExpr(const s : string; var valid : Boolean) : Real;
implementation
var
macro : string;
Old_Exit : pointer;
c : char;
i, m : byte;
ppText : string; { holds var of function .. }
type
charSet = set of char;
const
seperators : charSet = [' ', #9, '\', ';', '*', '/', '^',
'+', '=', '-', '%', ')'];
(******************************************************************************
* skipBlanks *
* skip blanks defined in the seperators variables, and update o *
******************************************************************************)
procedure skipBlanks(var s : string; var o : byte);
var
ls : byte;
const
seperators : charSet = [' ', #9];
begin
ls := length(S);
while((s[o] in seperators) and
(o <= ls)) do
inc(o);
end; {skipBlanks}
(******************************************************************************
* makeUpper *
* receive a string, and convert it to upper-case *
******************************************************************************)
function makeUpper(s : string) : string;
var
i : byte;
begin
for i := 1 to length(s) do
if (s[i] in ['a' .. 'z']) then
s[i] := upCase(s[i]);
makeUpper := s;
end; {makeUpper}
(******************************************************************************
* readWord *
* Return the next word found from the current string, and updates the offset *
* variable. if mu is true, return the upper case word. *
******************************************************************************)
function readWord(var s : string; var o : byte; mu : boolean;
const seperators : charSet) : string;
var
v : string;
ls : byte;
begin
skipBlanks(s, o);
v := '';
ls := length(s);
while ((not (s[o] in seperators)) and
(o <= ls)) do begin
v := v + s[o];
inc(o);
end;
if (mu) then
v := makeUpper(v);
if ((v[length(v)] = #255) and (v <> #255)) then begin
v := copy(v, 1, length(v) - 1);
dec(o);
end;
readWord := v;
end; {readWord}
(******************************************************************************
* DoErr *
******************************************************************************)
procedure DoErr(var n : TokenType);
begin
n := Error;
ErrAt := i; {globl err pos}
end; {doErr}
(******************************************************************************
* doReadWord *
******************************************************************************)
function doReadWord : string;
var
WordIn : string;
begin
WordIn := '';
While (not(Macro [i] in
[' ','\',';','*','/','^','+','=','-','%','(',')']))
and (i <= Length(Macro)) do
begin
WordIn := WordIn + UpCase(Macro[i]);
Inc(i);
end;
doReadWord := WordIn;
end; {doreadWord}
(******************************************************************************
* ReadNumber *
******************************************************************************)
function ReadNumber : Real;
var
Number : Real;
Code : Integer;
StrNum : string;
begin
StrNum := doReadWord;
if StrNum[1] = '.' then StrNum := '0' + StrNum;
Val(StrNum,Number,Code);
if Code <> 0 then Number := 0;
ReadNumber := Number;
end; {readNumber}
procedure Level1(var Result : Real; var n : TokenType) ; forward;
(******************************************************************************
* getFuncOrVar *
******************************************************************************)
procedure getFuncOrVar(var n : tokenType);
begin
m := i;
ppText := readWord(macro, m, true, seperators);
if ((pos('(', ppText) <> 0) or (ppText = 'PI') or (ppText = 'E')) then
n := func
else
n := variable;
end; {getFuncOrVar}
(******************************************************************************
* GetToken *
******************************************************************************)
function GetToken : TokenType;
var
Temp : string;
n : TokenType;
begin
SkipBlanks(macro, i);
if (Macro[i] in ['+','-','/','*','=','^','%','(',')']) then
n := Delimiter
else if (Macro[i] in ['0'..'9','.']) then
n := Digit
else if (Macro[i] = ';') then
n := endExpr
else if (Macro[i] in ['a'..'z','A'..'Z'])
then getFuncOrVar(n)
else
n := Non;
GetToken := n;
end; {getToken}
(******************************************************************************
* MatchFunc *
******************************************************************************)
function MatchFunc(Match : string; var Result : Real; var n : TokenType) :
Boolean;
var
j : Byte;
begin
j := i; {restore i if no match}
if (doReadWord = Match) then begin
MatchFunc := True;
skipblanks(macro, i);
if (Macro [i] <> '(') then DoErr(n)
else begin
Inc(i);
n := GetToken;
Level1(Result,n);
SkipBlanks(macro, i); {Reach closing parenthasis}
if Macro[i] <> ')' then DoErr(n);
Inc(i);
SkipBlanks(macro, i);
end;
end else begin
MatchFunc := False;
i := j; {no Func Match, restore}
end;
end; {matchFunc}
(******************************************************************************
* MatchToken *
******************************************************************************)
function MatchToken(Match : string) : boolean;
var
j : byte;
begin
j := i;
if (doreadWord = match) then MatchToken := True
else begin
MatchToken := False;
i := j;
end; {else}
end; {matchToken}
(******************************************************************************
* doPI *
******************************************************************************)
function doPI(var r:real) : boolean;
begin
doPI := matchToken('PI');
r := pi;
end; {doPI}
(******************************************************************************
* doE *
******************************************************************************)
function doE(var r:real) : boolean;
begin
doE := matchToken('E');
r := exp(1.0);
end; {doE}
(******************************************************************************
* DoSin *
******************************************************************************)
function DoSin(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('SIN',Result,n);
Result := sin(Result);
DoSin := r;
end; {doSin}
(******************************************************************************
* DoExp *
******************************************************************************)
function DoExp(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('EXP',Result,n);
Result := exp(Result);
DoExp := r;
end; {doSin}
(******************************************************************************
* DoCos *
******************************************************************************)
function DoCos(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('COS',Result,n);
Result := cos(Result);
DoCos := r;
end; {doCos}
(******************************************************************************
* DoLn *
******************************************************************************)
function DoLn(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('LN',Result,n);
if (Result > 0.0) then Result := ln(Result)
else DoErr(n);
DoLn := r;
end; {doLn}
(******************************************************************************
* DoLog10 *
******************************************************************************)
function DoLog10(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('LOG10',Result,n);
if (Result > 0.0) then Result := ln(Result)/ln(10.0)
else DoErr(n);
DoLog10 := r;
end; {doLog10}
(******************************************************************************
* DoLog2 *
******************************************************************************)
function DoLog2(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('LOG2',Result,n);
if (Result > 0.0) then Result := ln(Result)/ln(2.0)
else DoErr(n);
DoLog2 := r;
end; {doLog2}
(******************************************************************************
* DoAbs *
******************************************************************************)
function DoAbs(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('ABS',Result,n);
Result := Abs(Result);
DoAbs := r;
end; {doAbs}
(******************************************************************************
* DoArcTan *
******************************************************************************)
function DoArcTan(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('ARCTAN',Result,n);
Result := ArcTan(Result);
DoArcTan := r;
end; {doArcTan}
(******************************************************************************
* DoSqr *
******************************************************************************)
function DoSqr(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('SQR',Result,n);
Result := Sqr(Result);
DoSqr := r;
end; {doSqr}
(******************************************************************************
* DoSqrt *
******************************************************************************)
function DoSqrt(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('SQRT',Result,n);
Result := Sqrt(Result);
DoSqrt := r;
end; {doSqrt}
(******************************************************************************
* DoTan *
******************************************************************************)
function DoTan(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('TAN',Result,n);
if ( cos(result) <> 0 ) then
Result := Sin(Result) / cos(Result)
else doErr(n);
DoTan := r;
end; {doTan}
(******************************************************************************
* DoCoTan *
******************************************************************************)
function DoCoTan(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('COTAN',Result,n);
if ( sin(result) <> 0 ) then
Result := cos(Result) / sin(Result)
else doErr(n);
DoCoTan := r;
end; {doCoTan}
(******************************************************************************
* DoArcSin *
******************************************************************************)
function DoArcSin(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('ARCSIN',Result,n);
if (abs(Result) < 1.0) then
Result := arcTan(Result/sqrt(1-result*result))
else doErr(n);
DoArcSin := r;
end; {doArcSin}
(******************************************************************************
* DoArcCos *
******************************************************************************)
function DoArcCos(var Result : Real; var n : TokenType) : Boolean;
var
r : Boolean;
begin
r := MatchFunc('ARCCOS',Result,n);
if ((Result <> 0.0) and (result < 1.0)) then
Result := arcTan(sqrt(1-result*result)/result)
else doErr(n);
DoArcCos := r;
end; {doArcCos}
(******************************************************************************
* DoFunc *
******************************************************************************)
procedure DoFunc(var Result : Real; var n : TokenType);
begin
case Macro [i] of
's','S' : begin
if not(DoSin(Result,n)) then
if not(DoSqr(Result,n)) then
if not(DoSqrt(Result,n)) then
DoErr(n);
end;
'c','C' : begin
if not(DoCos(Result,n)) then
if not(DoCoTan(result,n)) then
DoErr(n);
end;
'l','L' : begin
if not(DoLn(Result,n)) then
if not(doLog10(result,n)) then
if not(doLog2(result,n)) then
DoErr(n);
end;
'a','A' : begin
if not(DoAbs(Result,n)) then
if not(DoArcTan(Result,n)) then
if not(doArcSin(Result,n)) then
if not(doArcCos(result,n))
then DoErr(n);
end;
'e','E' : begin
if not(DoExp(Result,n)) then
if not(doE(result)) then
DoErr(n);
end;
't','T' : begin
if not(doTan(result,n)) then
doErr(n);
end;
'p','P' : begin
if not(doPI(result)) then
doErr(n);
end;
else DoErr(n);
end; {case}
end;
(******************************************************************************
* Primitive *
******************************************************************************)
procedure Primitive(var Result : Real; var n : TokenType);
begin
if (n = variable) then begin
i := m;
if (symbolTbl^.bringByKey(ppText)) then
result := symbolTbl^.current^.value
else begin
result := 0.0;
symbolTbl^.current^.value := 0.0;
symbolTbl^.writeByKey(ppText);
end;
end else if (n = Digit) then
Result := ReadNumber
else if (n = Func) then
DoFunc(Result,n);
SkipBlanks(macro, i);
end;
(******************************************************************************
* Level6 *
* handle parenthasis *
******************************************************************************)
procedure Level6(var Result : Real; var n : TokenType);
begin
if ((n = Delimiter) and (Macro [i] = '(')) then begin
Inc(i);
n := GetToken;
Level1(Result,n);
SkipBlanks(macro, i); {Reach closing parenthasis}
if (Macro[i] <> ')') then
DoErr(n);
Inc(i);
SkipBlanks(macro, i);
end else
Primitive(Result,n);
end; { level6}
(******************************************************************************
* Level5 *
******************************************************************************)
procedure Level5(var Result : Real; var n : TokenType);
var
op : Char;
begin
op := Macro [i];
if (op in ['-','+']) then
Inc(i);
n := GetToken;
Level6(Result,n);
if (op = '-') then
Result := - (Result);
end; { level5 }
(******************************************************************************
* Sign *
* returns -1 if num < 0, 1 otherwise *
******************************************************************************)
function Sign(Number : Real) : Real;
begin
if (Number < 0.0) then Sign := -1.0
else Sign := 1.0;
end; { sign }
(******************************************************************************
* Level4 *
******************************************************************************)
procedure Level4(var Result : Real; var n : TokenType);
var
Hold : Real;
begin
Level5(Result,n);
if (n <> Error) then
if (macro[i] = '^') then begin
Inc(i);
n := GetToken;
Level4(Hold,n);
if (Result = 0.0) then
if (hold = 0.0) then
result := 1.0
else
result := 0.0
else
Result := Sign(Result) * Exp(Hold * Ln(Abs(Result)));
SkipBlanks(macro, i);
end; { case of ^ }
end; {level4}
(******************************************************************************
* Level3 *
* handle multiply/divide *
******************************************************************************)
procedure Level3(var Result : Real; var n : TokenType);
var
Hold : Real;
op : Char;
begin
Level4(Result,n);
if (n <> Error) then begin
SkipBlanks(macro, i);
While Macro [i] in ['*','/','%'] do begin
op := Macro[i];
Inc(i);
n := GetToken;
Level4(Hold,n);
if op = '*' then Result := Result * Hold
else begin
if (hold = 0.0) then doErr(n)
else
if op = '/' then Result := Result / Hold
else Result := Trunc(Result) mod Trunc(Hold);
end;
SkipBlanks(macro, i);
end;
end; {not error}
end; { level 3 }
(******************************************************************************
* Level2 *
* handle add/sub *
******************************************************************************)
procedure Level2(var Result : Real; var n : TokenType);
var
Hold : Real;
op : Char;
begin
Level3(Result,n);
if (n <> Error) then begin
SkipBlanks(macro, i);
While (Macro [i] in ['+','-']) do begin
op := Macro [i];
inc(i);
n := GetToken;
Level3(Hold,n);
if op = '+' then Result := Result + Hold
else Result := Result - Hold;
SkipBlanks(macro, i);
end; {while}
end; {not error}
end; { level2 }
(******************************************************************************
* Level1 *
* handle assign *
******************************************************************************)
procedure Level1(var Result : Real; var n : TokenType);
var
Slot : Char;
mt : TokenType;
j : Byte;
mv : string;
begin
if (n = variable) then begin
j := i; {save i}
i := m;
mv := ppText;
mt := GetToken;
if ((mt = Delimiter) and (Macro [i] = '=') and (i <=length(Macro)))
then begin
Inc(i);
n := GetToken;
Level2(Result,n);
symbolTbl^.current^.value := Result;
symbolTbl^.writeByKey(mv);
end else begin
i := j; {restore ..}
level2(Result,n);
end; {not a variable = ...}
end {variable case} else
Level2(Result,n);
end; { level 1 }
(******************************************************************************
* GetExpr *
******************************************************************************)
function GetExpr;
var
Result : Real;
n : TokenType;
begin
macro := s;
i := 1;
Result := 0; {if no result returned}
n := GetToken;
if (Not (n in [endExpr,Non])) then
Level1(Result,n);
if ((n <> endExpr) and (i < Length(Macro))) then
Dec(i);
GetExpr := Result;
if (n = Error) then
Valid := False
else
Valid := True;
end; {getExpr}
(******************************************************************************
* error_exit *
* whenever we exit, we do it from here, and clean the memory .. *
******************************************************************************)
procedure error_exit; far;
begin
dispose(symbolTbl, done);
end; {error_exit}
(******************************************************************************
* MAIN *
******************************************************************************)
begin
new(symbolTbl, create('ST'));
Old_Exit := exitproc;
exitproc := @Error_Exit;
end.
