home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / TURBOPAS / PARS.PQS / PARS.PAS
Pascal/Delphi Source File  |  2000-06-30  |  7KB  |  266 lines
  1. program Parser;
  2.  
  3. {adapted to Turbo Pascal by Glenn Brooke 5/6/86 from a program
  4.  by Herbert Shcildt.
  5.  
  6.  this program reads an expression and returns the result.  It can
  7.  handle up to 26 one letter (A-Z) variables and real numbers.
  8.  Supports +,-,*,/,and powers.  Not bad!  Speed isn't too bad, either.
  9.  
  10.  This kind of a program is really best as a function in your own program,
  11.  so that the user can enter an expression, and the program can compute
  12.  the result.  For example, a function plotting program can simply ask
  13.  for a function like 2*X + (3.14/X^4)/1.23, and plot the curve from
  14.  -5 to +5.  Quite powerful!
  15.  
  16. }
  17. type
  18.     str80 = string[80];
  19.     Ttype = (Delimiter, Variable, Number);
  20. var
  21.    token, prog : str80;
  22.    TokType : Ttype;
  23.    code, t : integer;
  24.    result : real;
  25.    vars : array[0..25] of real;      {26 variables}
  26.  
  27. function IsAlpha(ch : char) : boolean;
  28. {true if ch is letter in alphabe}
  29. begin
  30.      IsAlpha := (Upcase(ch) in ['A'..'Z'])
  31. end;
  32.  
  33. function IsWhite(ch : char) : boolean;
  34. {true if newline, space or tab}
  35. begin
  36.      IsWhite := (ch= ' ') or (ch=chr(9)) or (ch=chr(13));
  37. end;
  38.  
  39. function IsDelim(ch : char) : boolean;
  40. begin
  41.      if pos(ch,' +-/*%^=()$')<>0 then IsDelim := true
  42.      else IsDelim := false
  43. end;
  44.  
  45. function Isdigit(ch : char) : boolean;
  46. begin
  47.      Isdigit := ch in ['0'..'9']
  48. end;
  49.  
  50. procedure GetToken;
  51. var temp : str80;
  52. begin
  53.      token := '';
  54.      while (IsWhite(prog[t])) do t := succ(t);
  55.      if prog[t]='$' then token := '$';
  56.      if pos(prog[t],'+-*/%^=()')<>0 then
  57.         begin
  58.         TokType := Delimiter;
  59.         token := prog[t];    {is an operator}
  60.         t := succ(t);
  61.         end
  62.      else if IsAlpha(prog[t]) then
  63.           begin
  64.           while (not IsDelim(prog[t])) do
  65.                 begin
  66.                 token := token + prog[t];    {build token}
  67.                 t := succ(t)
  68.                 end;
  69.           TokType := Variable;
  70.           end
  71.      else if IsDigit(prog[t]) then
  72.           begin
  73.           while (not IsDelim(prog[t])) do
  74.                 begin
  75.                 token := token + prog[t];   {build number}
  76.                 t := succ(t);
  77.                 Toktype := number;
  78.                 end;
  79.           end;
  80. end; {GetToken}
  81.  
  82. procedure PutBack;  {put back unused token}
  83. begin
  84.      t := t - length(token)
  85. end;
  86.  
  87. procedure Serror(i : integer);  {print error msg}
  88. begin
  89.      case i of
  90.           1 : writeln('Syntax error');
  91.           2 : writeln('Unbalanced parentheses');
  92.           3 : writeln('No expression Present')
  93.      end;
  94. end;
  95.  
  96. function Pwr(a,b : real) : real;
  97. {raise a to the b power}
  98. var t : integer;
  99.     temp : real;
  100. begin
  101.      if a= 0 then pwr := 1
  102.      else
  103.          begin
  104.          temp := a;
  105.          for t := trunc(b) downto 2 do a := a * temp;
  106.          Pwr := a
  107.          end
  108. end;
  109.  
  110. function FindVar(s : str80) : real;
  111. var t : integer;
  112. begin
  113.      FindVar := vars[ord(upcase(s[1]))-ord('A')]
  114. end;
  115.  
  116. procedure Arith(op : char; var result, operand : real);
  117. begin
  118.      case op of
  119.           '+' : result := result + operand;
  120.           '-' : result := result - operand;
  121.           '*' : result := result * operand;
  122.           '/' : result := result / operand;
  123.           '^' : result := Pwr(result,operand);
  124.     end
  125. end;
  126.  
  127. {***********  Expression Parser w/ variables and assignment  ********}
  128. procedure Level2(var result : real); forward;
  129. procedure Level1(var result : real); forward;
  130. procedure Level3(var result : real); forward;
  131. procedure Level4(var result : real); forward;
  132. procedure Level5(var result : real); forward;
  133. procedure Level6(var result : real); forward;
  134. procedure Primitive(var result : real); forward;
  135.  
  136.  
  137. procedure GetExp(var result: real);
  138. begin
  139.      GetToken;
  140.      if length(token) <> 0 then Level1(result) else Serror(3)
  141. end;
  142.  
  143. procedure Level1;
  144. var hold : real;
  145.     temp : Ttype;
  146.     slot : integer;
  147.     TempToken : str80;
  148. begin
  149.      if Toktype = Variable then
  150.         begin
  151.         {save old token}
  152.         temptoken := token;
  153.         temp := toktype;
  154.         slot := ord(upcase(token[1]))-ord('A');
  155.         GetToken;  {see if there is an = for assignment}
  156.         if token[1] <> '=' then  {restore}
  157.            begin
  158.            Putback;
  159.            token := temptoken;
  160.            toktype := temp;
  161.            level2(result)
  162.            end
  163.         else {is assignment}
  164.              begin
  165.              Gettoken;
  166.              Level2(result);
  167.              vars[slot] := result;
  168.              end;
  169.         end
  170.     else Level2(result)
  171. end; {Level1}
  172.  
  173.  
  174. procedure Level2;
  175. var op : char;
  176.     hold : real;
  177. begin
  178.      Level3(result);
  179.      op := token[1];
  180.      while ((op='+') or (op='-')) do
  181.            begin
  182.            Gettoken;
  183.            Level3(hold);
  184.            arith(op, result, hold);
  185.            op := token[1]
  186.            end;
  187. end; {Level2}
  188.  
  189. procedure Level3;
  190. var op : char;
  191.     hold : real;
  192.  
  193. begin
  194.      Level4(result);
  195.      op := token[1];
  196.      while ((op='*') or (op='/')) do
  197.            begin
  198.            Gettoken;
  199.            level4(hold);
  200.            arith(op, result, hold);
  201.            op := token[1]
  202.            end;
  203. end; {Level3}
  204.  
  205. procedure Level4;
  206. var hold : real;
  207. begin
  208.      Level5(result);
  209.      if token[1] = '^' then
  210.         begin
  211.         GetToken;
  212.         Level4(hold);
  213.         arith('^',result, hold);    {exponent}
  214.         end
  215. end;
  216.  
  217. procedure Level5;
  218. var op : char;
  219. begin
  220.      op := ' ';
  221.      if ((tokType=Delimiter) and ((token[1]='+') or (token[1]= '-'))) then
  222.         begin  {unary plus or minus}
  223.                op := token[1];
  224.                Gettoken
  225.         end;
  226.      Level6(result);
  227.      if op='-' then result := -result
  228. end; {level5}
  229.  
  230. procedure Level6;
  231. begin
  232.      if (token[1]='(') and (Toktype=Delimiter) then
  233.         begin {parenthesized expression}
  234.         GetToken;
  235.         Level2(result);
  236.         if token[1]<>')' then Serror(2);  {unbalanced}
  237.         GetToken;
  238.         end
  239.      else Primitive(result);
  240. end; {Level6}
  241.  
  242.  
  243. procedure Primitive;
  244. begin
  245.      if TokType=Number then val(token, result, code)
  246.      else if TokType=Variable then result := FindVar(token)
  247.      else serror(1);
  248.      GetToken
  249. end; {Primitive}
  250.  
  251.  
  252.  
  253.  
  254. {**************************  Main Test body  ******************}
  255. begin
  256.      for t := 0 to 25 do vars[t] := 0;  {initialize variables}
  257.      repeat
  258.            t := 1;
  259.            write('  Enter an expression  (quit to stop) : ');
  260.            readln(prog);
  261.            prog := prog + '$';
  262.            GetExp(result);
  263.            writeln(result);
  264.      until prog = 'quit$';
  265. end.
  266.