home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / ipo-101.zip / Samples.zip / CALC.PAS < prev    next >
Pascal/Delphi Source File  |  1998-11-15  |  18KB  |  607 lines

  1. program calc (f, out);
  2. type
  3.    token_kind = (EXPtok, MULtok, DIVtok, PLUStok, MINUStok,
  4.                  ASSIGNtok, FUNCStok, CONStok, VARStok,
  5.                  OPEN_PARENtok, CLOSE_PARENtok,
  6.                  NUMBERtok,
  7.                  EOLtok, STOPtok, EMPTYtok);
  8.    func_kind = (func_sin, func_cos, func_tan, func_log, func_ln, func_sqrt);
  9.    cons_kind = (cons_pi);
  10.    vars_kind = 'a'..'z';
  11.    token = record
  12.       lineno, linepos : integer;
  13.       case kind : token_kind of
  14.          EXPtok, MULtok, DIVtok, PLUStok, MINUStok, ASSIGNtok : ();
  15.          OPEN_PARENtok, CLOSE_PARENtok : ();
  16.          NUMBERtok : (n : real);
  17.          FUNCStok : (fk : func_kind);
  18.          CONStok : (ck : cons_kind);
  19.          VARStok : (vk : vars_kind);
  20.          EOLtok, STOPtok, EMPTYtok : ()
  21.       end;
  22.  
  23. var
  24.    f, out : text;
  25.    line : string;
  26.    linepos, linelen, lineno : integer;
  27.    curr, next : token;
  28.    letter : set of vars_kind;
  29.    digit : set of '0'..'9';
  30.    whitespace : set of char;
  31.    v : 'a'..'z';
  32.    vars : array['a'..'z'] of real;
  33.    MulOps, AddOps : set of token_kind;
  34.  
  35.    procedure PrintValue(r : real);
  36.    const
  37.       MAX = 18;
  38.    var
  39.       temp : real;
  40.       negative : boolean;
  41.       digits, after : integer;
  42.    begin
  43.       if r < 0 then
  44.          begin
  45.             negative := true;
  46.             temp := -r;
  47.             digits := 2;
  48.          end
  49.       else
  50.          begin
  51.             negative := false;
  52.             temp := r;
  53.             digits := 1
  54.          end;
  55.       if temp > 1e18 then
  56.          begin
  57.             write(out, r);
  58.             exit
  59.          end;
  60.       while temp >= 10 do
  61.          begin
  62.             inc(digits);
  63.             temp := temp / 10;
  64.          end;
  65.       after := MAX-digits;
  66.       if after > 12 then after := 12;
  67.       write(out, r:MAX+1:after);
  68.    end;
  69.  
  70. (*************************************************************************)
  71. (********************** The error handler ********************************)
  72.    procedure error(s : string);
  73.    begin
  74.       writeln(out, 'ERROR: Line ', lineno:2, ':', s);
  75.       halt
  76.    end;
  77. (*************************************************************************)
  78.  
  79.    procedure prompt;
  80.    begin
  81.       write(out, 'calc: ');
  82.       flush(out)
  83.    end;
  84.  
  85.  
  86. (*************************************************************************)
  87. (********************** The lexer ****************************************)
  88. (*
  89. lexical tokens = exit, stop, end, a..z, pi, sin, cos, tan, log, ln, sqrt,
  90.                  =, +, -, *, /, mul, div, **, (, )
  91. *)
  92.    procedure PrintToken;
  93.    begin
  94.       case curr.kind of
  95.       STOPtok: writeln(out, '<STOP>');
  96.       VARStok:
  97.          begin
  98.             write(out, '<VAR> ');
  99.             writeln(out, curr.vk);
  100.          end;
  101.       CONStok:
  102.          begin
  103.             write(out, '<CONSTANT> ');
  104.             case curr.ck of
  105.             cons_pi: writeln(out, 'pi')
  106.             end; (* case curr.ck *)
  107.          end;
  108.       FUNCStok:
  109.          begin
  110.            write(out, '<FUNCTION> ');
  111.            case curr.fk of
  112.            func_sin: writeln(out, 'sin');
  113.            func_cos: writeln(out, 'cos');
  114.            func_tan: writeln(out, 'tan');
  115.            func_log: writeln(out, 'log');
  116.            func_ln: writeln(out, 'ln');
  117.            func_sqrt: writeln(out, 'sqrt');
  118.            end; (* case curr.fk *)
  119.          end;
  120.       ASSIGNtok: writeln(out, '=');
  121.       PLUStok: writeln(out, '+');
  122.       MINUStok: writeln(out, '-');
  123.       MULtok: writeln(out, '*');
  124.       DIVtok: writeln(out, '/');
  125.       EXPtok: writeln(out, '**');
  126.       OPEN_PARENtok: writeln(out, '<(>');
  127.       CLOSE_PARENtok: writeln(out, '<)>');
  128.       NUMBERtok:
  129.          begin
  130.             PrintValue(curr.n); writeln(out)
  131.          end;
  132.       EOLtok: writeln(out, '<EOL>');
  133.       EMPTYtok: writeln(out, '<EMPTY>');
  134.       end (* case *)
  135.    end;
  136.  
  137.    procedure GetToken;
  138.  
  139.       procedure GetNext;
  140.       var
  141.          c : char;
  142.  
  143.          procedure SingleToken(k : token_kind);
  144.          begin
  145.             inc(linepos);
  146.             curr.kind := k;
  147.             curr.lineno := lineno
  148.          end;
  149.  
  150.          procedure GetNumberToken;
  151.          var
  152.             s : string;
  153.             r : real;
  154.             i : integer;
  155.          begin
  156.             s := copy(line, linepos);
  157.             val(s, r, i);
  158.             if (i=0) or (i > 1) then
  159.                begin
  160.                   curr.kind := NUMBERtok;
  161.                   curr.n := r;
  162.                   curr.lineno := lineno;
  163.                   if i=0 then
  164.                      linepos := linelen+1
  165.                   else
  166.                      inc(linepos, i-1);
  167.                   exit
  168.                end;
  169.             error('Number is invalid')
  170.          end;
  171.  
  172.          procedure GetLetterToken;
  173.          var
  174.             first, last : integer;
  175.             c : char;
  176.             s : string;
  177.  
  178.             procedure identify(s : string);
  179.             begin
  180.                if length(s) = 1 then
  181.                   begin
  182.                      curr.kind := VARStok;
  183.                      curr.vk := s[1]
  184.                   end
  185.                else if (s = 'exit') or (s = 'end') or (s = 'stop') then
  186.                   curr.kind := STOPtok
  187.                else if s = 'pi' then
  188.                   begin
  189.                      curr.kind := CONStok;
  190.                      curr.ck := cons_pi
  191.                   end
  192.                else if s = 'sin' then
  193.                   begin
  194.                      curr.kind := FUNCStok;
  195.                      curr.fk := func_sin
  196.                   end
  197.                else if s = 'cos' then
  198.                   begin
  199.                      curr.kind := FUNCStok;
  200.                      curr.fk := func_cos
  201.                   end
  202.                else if s = 'tan' then
  203.                   begin
  204.                      curr.kind := FUNCStok;
  205.                      curr.fk := func_tan
  206.                   end
  207.                else if s = 'log' then
  208.                   begin
  209.                      curr.kind := FUNCStok;
  210.                      curr.fk := func_log
  211.                   end
  212.                else if s = 'ln' then
  213.                   begin
  214.                      curr.kind := FUNCStok;
  215.                      curr.fk := func_ln
  216.                   end
  217.                else if s = 'sqrt' then
  218.                   begin
  219.                      curr.kind := FUNCStok;
  220.                      curr.fk := func_sqrt
  221.                   end
  222.                else if s = 'mul' then
  223.                   curr.kind := MULtok
  224.                else if s = 'div' then
  225.                   curr.kind := DIVtok
  226.                else
  227.                   error('Invalid syntax');
  228.                curr.lineno := lineno;
  229.             end;
  230.  
  231.          begin (* GetLetterToken *)
  232.             c := line[linepos];
  233.             first := linepos;
  234.             last := first;
  235.             while (last+1 <= linelen) and (line[last+1] in letter) do
  236.                 inc(last);
  237.             s := copy(line, first, last-first+1);
  238.             linepos := last+1;
  239.             identify(s)
  240.          end; (* GetLetterToken *)
  241.  
  242.       begin (* GetNext *)
  243.          if curr.kind = STOPtok then
  244.             exit;
  245.          if next.kind <> EMPTYtok then
  246.             begin
  247.                curr := next;
  248.                lineno := curr.lineno;
  249.                linepos := curr.linepos;
  250.                next.kind := EMPTYtok;
  251.                exit
  252.             end;
  253.          while linepos <= linelen do
  254.             begin
  255.                c := line[linepos];
  256.                case c of
  257.                '=':
  258.                   begin
  259.                      SingleToken(ASSIGNtok);
  260.                      exit
  261.                   end;
  262.                '+':
  263.                   begin
  264.                      SingleToken(PLUStok);
  265.                      exit
  266.                   end;
  267.                '-':
  268.                   begin
  269.                      SingleToken(MINUStok);
  270.                      exit
  271.                   end;
  272.                '*':
  273.                   if (linepos < linelen) and (line[linepos+1] = '*') then
  274.                      begin
  275.                         linepos := linepos + 2;
  276.                         curr.kind := EXPtok;
  277.                         exit
  278.                      end
  279.                   else
  280.                      begin
  281.                        SingleToken(MULtok);
  282.                        exit
  283.                      end;
  284.                '/':
  285.                   begin
  286.                      SingleToken(DIVtok);
  287.                      exit
  288.                   end;
  289.                '(':
  290.                   begin
  291.                      SingleToken(OPEN_PARENtok);
  292.                      exit
  293.                   end;
  294.                ')':
  295.                   begin
  296.                      SingleToken(CLOSE_PARENtok);
  297.                      exit
  298.                   end;
  299.                otherwise
  300.                   begin
  301.                      if c in digit then
  302.                         begin
  303.                            GetNumberToken;
  304.                            exit
  305.                         end
  306.                      else if c in letter then
  307.                         begin
  308.                            GetLetterToken;
  309.                            exit
  310.                         end
  311.                      else if c in whitespace then
  312.                         inc(linepos)
  313.                      else
  314.                         error('Text not recognized')
  315.                   end;
  316.                end (* case *)
  317.             end; (* while *)
  318.          curr.kind := EOLtok;
  319.       end; (* GetNext *)
  320.  
  321.       procedure NewLine;
  322.       begin
  323.          prompt;
  324.          if eof(f) then
  325.             begin
  326.                curr.kind := STOPtok;
  327.                curr.lineno := lineno;
  328.                line := "";
  329.                linelen := length(line);
  330.                linepos := 1;
  331.                exit
  332.             end;
  333.          readln(f, line);
  334.          line := lowercase(trim(line));
  335.          linelen := length(line);
  336.          inc(lineno);
  337.          linepos := 1;
  338.          if linelen = 0 then
  339.             curr.kind := STOPtok
  340.          else
  341.             curr.kind := EMPTYtok
  342.       end;
  343.  
  344.    begin (* GetToken *)
  345.       if (lineno = 0) or (curr.kind = EOLtok) then
  346.          NewLine;
  347.       if curr.kind = STOPtok then
  348.          exit;
  349.       curr.kind := EMPTYtok;
  350.       GetNext;
  351.       curr.lineno := lineno;
  352.       curr.linepos := linepos;
  353.       (* PrintToken *)
  354.    end; (* GetToken *)
  355.  
  356.    procedure GetNextToken;
  357.    var
  358.       temp : token;
  359.       i : integer;
  360.    begin
  361.       if (curr.kind = EOLtok) or (curr.kind = STOPtok) or (next.kind <> EMPTYtok) then
  362.          error('Bad call to NextToken');
  363.       i := lineno;
  364.       temp := curr;
  365.       GetToken;
  366.       next := curr;
  367.       curr := temp;
  368.       linepos := i;
  369.       lineno := curr.lineno
  370.    end;
  371.  
  372.    procedure skip(k : token_kind);
  373.    begin
  374.       (*
  375.       PrintToken;
  376.       writeln(out, 'skip ', ord(curr.kind), ord(k));
  377.       *)
  378.       if curr.kind <> k then
  379.          error('Invalid syntax');
  380.       GetToken;
  381.       (* writeln(out, 'skipped') *)
  382.    end;
  383.  
  384. (*************************************************************************)
  385.  
  386.    procedure eval;
  387.    var
  388.       r : real;
  389.  
  390.       function power(a, b : real) : real;
  391.       begin
  392.          exit(exp(ln(a)*b))
  393.       end;
  394.  
  395.       function expression : real;
  396.       var
  397.          v : 'a'..'z';
  398.  
  399.          function eval_rhs : real;
  400.          var
  401.             lhs : real;
  402.  
  403.             function eval_mul_expr : real;
  404.             var
  405.                lhs : real;
  406.  
  407.                function eval_factor : real;
  408.                var
  409.                   r, arg : real;
  410.  
  411.                   function eval_paren : real;
  412.                   var
  413.                      r : real;
  414.                   begin
  415.                      (* writeln(out, 'eval_paren'); *)
  416.                      skip(OPEN_PARENtok);
  417.                      r := eval_rhs;
  418.                      skip(CLOSE_PARENtok);
  419.                      exit(r)
  420.                   end;
  421.  
  422.                begin
  423.                   (* writeln(out, 'eval_factor'); *)
  424.                   case curr.kind of
  425.                   FUNCStok:
  426.                      case curr.fk of
  427.                      func_sin:
  428.                         begin
  429.                            skip(FUNCStok);
  430.                            (* writeln(out, 'Calling eval_paren 1'); *)
  431.                            arg := eval_paren;
  432.                            r := sin(arg)
  433.                         end;
  434.                      func_cos:
  435.                         begin
  436.                            skip(FUNCStok);
  437.                            (* writeln(out, 'Calling eval_paren 2'); *)
  438.                            arg := eval_paren;
  439.                            r := cos(arg)
  440.                          end;
  441.                      func_tan:
  442.                         begin
  443.                            skip(FUNCStok);
  444.                            (* writeln(out, 'Calling eval_paren 3'); *)
  445.                            arg := eval_paren;
  446.                            r := tan(arg)
  447.                         end;
  448.                      func_log:
  449.                         begin
  450.                            skip(FUNCStok);
  451.                            (* writeln(out, 'Calling eval_paren 4'); *)
  452.                            arg := eval_paren;
  453.                            r := log(arg)
  454.                         end;
  455.                      func_ln:
  456.                         begin
  457.                            skip(FUNCStok);
  458.                            (* writeln(out, 'Calling eval_paren 5'); *)
  459.                            arg := eval_paren;
  460.                            r := ln(arg)
  461.                         end;
  462.                      func_sqrt:
  463.                         begin
  464.                            skip(FUNCStok);
  465.                            (* writeln(out, 'Calling eval_paren 6'); *)
  466.                            arg := eval_paren;
  467.                            r := sqrt(arg)
  468.                         end;
  469.                      end; (* case curr.fk *)
  470.                   CONStok:
  471.                       case curr.ck of
  472.                       cons_pi:
  473.                          begin
  474.                             r := pi;
  475.                             (* writeln(out, 'Before'); *)
  476.                             skip(CONStok);
  477.                             (* writeln(out, 'After') *)
  478.                          end;
  479.                       end;
  480.                   VARStok:
  481.                      begin
  482.                         r := vars[curr.vk];
  483.                         skip(VARStok)
  484.                      end;
  485.                   NUMBERtok:
  486.                      begin
  487.                         r := curr.n;
  488.                         skip(NUMBERtok)
  489.                      end;
  490.                   OPEN_PARENtok:
  491.                      begin
  492.                         (* writeln(out, 'Calling eval_paren 7'); *)
  493.                         r := eval_paren;
  494.                      end;
  495.                   otherwise error('Invalid factor')
  496.                   end; (* case *)
  497.                   exit(r)
  498.                end;
  499.  
  500.                function eval_exp_expr : real;
  501.                var
  502.                   lhs : real;
  503.                begin
  504.                   (* writeln(out, 'eval_exp_expr'); *)
  505.                   lhs := eval_factor;
  506.                   if curr.kind = EXPtok then
  507.                      begin
  508.                         skip(EXPtok);
  509.                         lhs := power(lhs, eval_factor)
  510.                      end;
  511.                   exit(lhs)
  512.                end;
  513.  
  514.             begin (* eval_mul_expr *)
  515.                (* writeln(out, 'eval_mul_expr'); *)
  516.                lhs := eval_exp_expr;
  517.                while curr.kind in MulOps do
  518.                   case curr.kind of
  519.                   MULtok:
  520.                      begin
  521.                         skip(MULtok);
  522.                         lhs := lhs * eval_exp_expr
  523.                      end;
  524.                   DIVtok:
  525.                      begin
  526.                         skip(DIVtok);
  527.                         lhs := lhs / eval_exp_expr
  528.                      end;
  529.                   end; (* case *)
  530.                exit(lhs)
  531.             end; (* eval_mul_expr *)
  532.  
  533.          begin (* eval_rhs *)
  534.             (* writeln(out, 'eval_rhs'); *)
  535.             lhs := eval_mul_expr;
  536.             while curr.kind in AddOps do
  537.                case curr.kind of
  538.                PLUStok:
  539.                   begin
  540.                      skip(PLUStok);
  541.                      lhs := lhs + eval_mul_expr
  542.                   end;
  543.                MINUStok:
  544.                   begin
  545.                      skip(MINUStok);
  546.                      lhs := lhs - eval_mul_expr
  547.                   end;
  548.                end; (* case *)
  549.             exit(lhs)
  550.          end; (* eval_rhs *)
  551.  
  552.       begin (* expression *)
  553.          (* writeln(out, 'expression'); *)
  554.          if curr.kind <> VARStok then
  555.             begin
  556.                r := eval_rhs;
  557.                exit(r)
  558.             end;
  559.          GetNextToken;
  560.          if next.kind = ASSIGNtok then
  561.             begin
  562.                v := curr.vk;
  563.                skip(VARStok);
  564.                skip(ASSIGNtok);
  565.                r := eval_rhs;
  566.                vars[v] := r;
  567.                exit(r)
  568.             end;
  569.          r := eval_rhs;
  570.          exit(r)
  571.       end; (* expression *)
  572.  
  573.    begin (* eval *)
  574.       if curr.kind = STOPtok then
  575.          exit;
  576.       (* writeln (out, 'expression'); *)
  577.       r := expression;
  578.       PrintValue(r);
  579.       writeln(out);
  580.       skip(EOLtok)
  581.    end; (* eval *)
  582.  
  583. begin
  584.    letter := ['a'..'z'];
  585.    digit := ['0'..'9'];
  586.    MulOps := [MULtok, DIVtok];
  587.    AddOps := [PLUStok, MINUStok];
  588.    whitespace := [chr(0)..' '];
  589.    for v := 'a' to 'z' do
  590.       vars[v] := 0;
  591.    reset(f);
  592.    rewrite(out);
  593.    lineno := 0;
  594.    next.kind := EMPTYtok;
  595.    GetToken;
  596.    while curr.kind <> STOPtok do
  597.       eval;
  598.    (*
  599.    while (not eof(input)) and (not done) do
  600.       begin
  601.          prompt;
  602.          readln(inp);
  603.          eval
  604.       end
  605.    *)
  606. end.
  607.