Паскаль / do9 / iriepas201 / Irie Pascal / samples / calc

(**********************************************
**
*)
program calc (f, out);
type
   token_kind = (EXPtok, MULtok, DIVtok, PLUStok, MINUStok,
                 ASSIGNtok, FUNCStok, CONStok, VARStok,
                 OPEN_PARENtok, CLOSE_PARENtok,
                 NUMBERtok,
                 EOLtok, STOPtok, EMPTYtok);
   func_kind = (func_sin, func_cos, func_tan, func_log, func_ln, func_sqrt);
   cons_kind = (cons_pi);
   vars_kind = 'a'..'z';
   token = record
      lineno, linepos : integer;
      case kind : token_kind of
         EXPtok, MULtok, DIVtok, PLUStok, MINUStok, ASSIGNtok : ();
         OPEN_PARENtok, CLOSE_PARENtok : ();
         NUMBERtok : (n : real);
         FUNCStok : (fk : func_kind);
         CONStok : (ck : cons_kind);
         VARStok : (vk : vars_kind);
         EOLtok, STOPtok, EMPTYtok : ()
      end;

var
   f, out : text;
   line : string;
   linepos, linelen, lineno : integer;
   curr, next : token;
   letter : set of vars_kind;
   digit : set of '0'..'9';
   whitespace : set of char;
   v : 'a'..'z';
   vars : array['a'..'z'] of real;
   MulOps, AddOps : set of token_kind;

   procedure PrintValue(r : real);
   const
      MAX = 18;
   var
      temp : real;
      negative : boolean;
      digits, after : integer;
   begin
      if r < 0 then
         begin
            negative := true;
            temp := -r;
            digits := 2;
         end
      else
         begin
            negative := false;
            temp := r;
            digits := 1
         end;
      if temp > 1e18 then
         begin
            write(out, r);
            exit
         end;
      while temp >= 10 do
         begin
            inc(digits);
            temp := temp / 10;
         end;
      after := MAX-digits;
      if after > 12 then after := 12;
      write(out, r:MAX+1:after);
   end;

(*************************************************************************)
(********************** The error handler ********************************)
   procedure error(s : string);
   begin
      writeln(out, 'ERROR: Line ', lineno:2, ':', s);
      halt
   end;
(*************************************************************************)

   procedure prompt;
   begin
      write(out, 'calc: ');
      flush(out)
   end;


(*************************************************************************)
(********************** The lexer ****************************************)
(*
lexical tokens = exit, stop, end, a..z, pi, sin, cos, tan, log, ln, sqrt,
                 =, +, -, *, /, mul, div, **, (, )
*)
(*$W44-*)
   procedure PrintToken;
(*$W44+*)
   begin
      case curr.kind of
      STOPtok: writeln(out, '<STOP>');
      VARStok:
         begin
            write(out, '<VAR> ');
            writeln(out, curr.vk);
         end;
      CONStok:
         begin
            write(out, '<CONSTANT> ');
            case curr.ck of
            cons_pi: writeln(out, 'pi')
            end; (* case curr.ck *)
         end;
      FUNCStok:
         begin
           write(out, '<FUNCTION> ');
           case curr.fk of
           func_sin: writeln(out, 'sin');
           func_cos: writeln(out, 'cos');
           func_tan: writeln(out, 'tan');
           func_log: writeln(out, 'log');
           func_ln: writeln(out, 'ln');
           func_sqrt: writeln(out, 'sqrt');
           end; (* case curr.fk *)
         end;
      ASSIGNtok: writeln(out, '=');
      PLUStok: writeln(out, '+');
      MINUStok: writeln(out, '-');
      MULtok: writeln(out, '*');
      DIVtok: writeln(out, '/');
      EXPtok: writeln(out, '**');
      OPEN_PARENtok: writeln(out, '<(>');
      CLOSE_PARENtok: writeln(out, '<)>');
      NUMBERtok:
         begin
            PrintValue(curr.n); writeln(out)
         end;
      EOLtok: writeln(out, '<EOL>');
      EMPTYtok: writeln(out, '<EMPTY>');
      end (* case *)
   end;

   procedure GetToken;

      procedure GetNext;
      var
         c : char;

         procedure SingleToken(k : token_kind);
         begin
            inc(linepos);
            curr.kind := k;
            curr.lineno := lineno
         end;

         procedure GetNumberToken;
         var
            s : string;
            r : real;
            i : integer;
         begin
            s := copy(line, linepos);
            val(s, r, i);
            if (i=0) or (i > 1) then
               begin
                  curr.kind := NUMBERtok;
                  curr.n := r;
                  curr.lineno := lineno;
                  if i=0 then
                     linepos := linelen+1
                  else
                     inc(linepos, i-1);
                  exit
               end;
            error('Number is invalid')
         end;

         procedure GetLetterToken;
         var
            first, last : integer;
            c : char;
            s : string;

            procedure identify(s : string);
            begin
               if length(s) = 1 then
                  begin
                     curr.kind := VARStok;
                     curr.vk := s[1]
                  end
               else if (s = 'exit') or (s = 'end') or (s = 'stop') then
                  curr.kind := STOPtok
               else if s = 'pi' then
                  begin
                     curr.kind := CONStok;
                     curr.ck := cons_pi
                  end
               else if s = 'sin' then
                  begin
                     curr.kind := FUNCStok;
                     curr.fk := func_sin
                  end
               else if s = 'cos' then
                  begin
                     curr.kind := FUNCStok;
                     curr.fk := func_cos
                  end
               else if s = 'tan' then
                  begin
                     curr.kind := FUNCStok;
                     curr.fk := func_tan
                  end
               else if s = 'log' then
                  begin
                     curr.kind := FUNCStok;
                     curr.fk := func_log
                  end
               else if s = 'ln' then
                  begin
                     curr.kind := FUNCStok;
                     curr.fk := func_ln
                  end
               else if s = 'sqrt' then
                  begin
                     curr.kind := FUNCStok;
                     curr.fk := func_sqrt
                  end
               else if s = 'mul' then
                  curr.kind := MULtok
               else if s = 'div' then
                  curr.kind := DIVtok
               else
                  error('Invalid syntax');
               curr.lineno := lineno;
            end;

         begin (* GetLetterToken *)
            c := line[linepos];
            first := linepos;
            last := first;
            while (last+1 <= linelen) and (line[last+1] in letter) do
                inc(last);
            s := copy(line, first, last-first+1);
            linepos := last+1;
            identify(s)
         end; (* GetLetterToken *)

      begin (* GetNext *)
         if curr.kind = STOPtok then
            exit;
         if next.kind <> EMPTYtok then
            begin
               curr := next;
               lineno := curr.lineno;
               linepos := curr.linepos;
               next.kind := EMPTYtok;
               exit
            end;
         while linepos <= linelen do
            begin
               c := line[linepos];
               case c of
               '=':
                  begin
                     SingleToken(ASSIGNtok);
                     exit
                  end;
               '+':
                  begin
                     SingleToken(PLUStok);
                     exit
                  end;
               '-':
                  begin
                     SingleToken(MINUStok);
                     exit
                  end;
               '*':
                  if (linepos < linelen) and (line[linepos+1] = '*') then
                     begin
                        linepos := linepos + 2;
                        curr.kind := EXPtok;
                        exit
                     end
                  else
                     begin
                       SingleToken(MULtok);
                       exit
                     end;
               '/':
                  begin
                     SingleToken(DIVtok);
                     exit
                  end;
               '(':
                  begin
                     SingleToken(OPEN_PARENtok);
                     exit
                  end;
               ')':
                  begin
                     SingleToken(CLOSE_PARENtok);
                     exit
                  end;
               otherwise
                  begin
                     if c in digit then
                        begin
                           GetNumberToken;
                           exit
                        end
                     else if c in letter then
                        begin
                           GetLetterToken;
                           exit
                        end
                     else if c in whitespace then
                        inc(linepos)
                     else
                        error('Text not recognized')
                  end;
               end (* case *)
            end; (* while *)
         curr.kind := EOLtok;
      end; (* GetNext *)

      procedure NewLine;
      begin
         prompt;
         if eof(f) then
            begin
               curr.kind := STOPtok;
               curr.lineno := lineno;
               line := "";
               linelen := length(line);
               linepos := 1;
               exit
            end;
         readln(f, line);
         line := lowercase(trim(line));
         linelen := length(line);
         inc(lineno);
         linepos := 1;
         if linelen = 0 then
            curr.kind := STOPtok
         else
            curr.kind := EMPTYtok
      end;

   begin (* GetToken *)
      if (lineno = 0) or (curr.kind = EOLtok) then
         NewLine;
      if curr.kind = STOPtok then
         exit;
      curr.kind := EMPTYtok;
      GetNext;
      curr.lineno := lineno;
      curr.linepos := linepos;
      (* PrintToken *)
   end; (* GetToken *)

   procedure GetNextToken;
   var
      temp : token;
      i : integer;
   begin
      if (curr.kind = EOLtok) or (curr.kind = STOPtok) or (next.kind <> EMPTYtok) then
         error('Bad call to NextToken');
      i := lineno;
      temp := curr;
      GetToken;
      next := curr;
      curr := temp;
      linepos := i;
      lineno := curr.lineno
   end;

   procedure skip(k : token_kind);
   begin
      (*
      PrintToken;
      writeln(out, 'skip ', ord(curr.kind), ord(k));
      *)
      if curr.kind <> k then
         error('Invalid syntax');
      GetToken;
      (* writeln(out, 'skipped') *)
   end;

(*************************************************************************)

   procedure eval;
   var
      r : real;

      function power(a, b : real) : real;
      begin
         exit(exp(ln(a)*b))
      end;

      function expression : real;
      var
         v : 'a'..'z';

         function eval_rhs : real;
         var
            lhs : real;

            function eval_mul_expr : real;
            var
               lhs : real;

               function eval_factor : real;
               var
                  r, arg : real;

                  function eval_paren : real;
                  var
                     r : real;
                  begin
                     (* writeln(out, 'eval_paren'); *)
                     skip(OPEN_PARENtok);
                     r := eval_rhs;
                     skip(CLOSE_PARENtok);
                     exit(r)
                  end;

               begin
                  (* writeln(out, 'eval_factor'); *)
                  case curr.kind of
                  FUNCStok:
                     case curr.fk of
                     func_sin:
                        begin
                           skip(FUNCStok);
                           (* writeln(out, 'Calling eval_paren 1'); *)
                           arg := eval_paren;
                           r := sin(arg)
                        end;
                     func_cos:
                        begin
                           skip(FUNCStok);
                           (* writeln(out, 'Calling eval_paren 2'); *)
                           arg := eval_paren;
                           r := cos(arg)
                         end;
                     func_tan:
                        begin
                           skip(FUNCStok);
                           (* writeln(out, 'Calling eval_paren 3'); *)
                           arg := eval_paren;
                           r := tan(arg)
                        end;
                     func_log:
                        begin
                           skip(FUNCStok);
                           (* writeln(out, 'Calling eval_paren 4'); *)
                           arg := eval_paren;
                           r := log(arg)
                        end;
                     func_ln:
                        begin
                           skip(FUNCStok);
                           (* writeln(out, 'Calling eval_paren 5'); *)
                           arg := eval_paren;
                           r := ln(arg)
                        end;
                     func_sqrt:
                        begin
                           skip(FUNCStok);
                           (* writeln(out, 'Calling eval_paren 6'); *)
                           arg := eval_paren;
                           r := sqrt(arg)
                        end;
                     end; (* case curr.fk *)
                  CONStok:
                      case curr.ck of
                      cons_pi:
                         begin
                            r := pi;
                            (* writeln(out, 'Before'); *)
                            skip(CONStok);
                            (* writeln(out, 'After') *)
                         end;
                      end;
                  VARStok:
                     begin
                        r := vars[curr.vk];
                        skip(VARStok)
                     end;
                  NUMBERtok:
                     begin
                        r := curr.n;
                        skip(NUMBERtok)
                     end;
                  OPEN_PARENtok:
                     begin
                        (* writeln(out, 'Calling eval_paren 7'); *)
                        r := eval_paren;
                     end;
                  otherwise error('Invalid factor')
                  end; (* case *)
                  exit(r)
               end;

               function eval_exp_expr : real;
               var
                  lhs : real;
               begin
                  (* writeln(out, 'eval_exp_expr'); *)
                  lhs := eval_factor;
                  if curr.kind = EXPtok then
                     begin
                        skip(EXPtok);
                        lhs := power(lhs, eval_factor)
                     end;
                  exit(lhs)
               end;

            begin (* eval_mul_expr *)
               (* writeln(out, 'eval_mul_expr'); *)
               lhs := eval_exp_expr;
               while curr.kind in MulOps do
                  case curr.kind of
                  MULtok:
                     begin
                        skip(MULtok);
                        lhs := lhs * eval_exp_expr
                     end;
                  DIVtok:
                     begin
                        skip(DIVtok);
                        lhs := lhs / eval_exp_expr
                     end;
                  end; (* case *)
               exit(lhs)
            end; (* eval_mul_expr *)

         begin (* eval_rhs *)
            (* writeln(out, 'eval_rhs'); *)
            lhs := eval_mul_expr;
            while curr.kind in AddOps do
               case curr.kind of
               PLUStok:
                  begin
                     skip(PLUStok);
                     lhs := lhs + eval_mul_expr
                  end;
               MINUStok:
                  begin
                     skip(MINUStok);
                     lhs := lhs - eval_mul_expr
                  end;
               end; (* case *)
            exit(lhs)
         end; (* eval_rhs *)

      begin (* expression *)
         (* writeln(out, 'expression'); *)
         if curr.kind <> VARStok then
            begin
               r := eval_rhs;
               exit(r)
            end;
         GetNextToken;
         if next.kind = ASSIGNtok then
            begin
               v := curr.vk;
               skip(VARStok);
               skip(ASSIGNtok);
               r := eval_rhs;
               vars[v] := r;
               exit(r)
            end;
         r := eval_rhs;
         exit(r)
      end; (* expression *)

   begin (* eval *)
      if curr.kind = STOPtok then
         exit;
      (* writeln (out, 'expression'); *)
      r := expression;
      PrintValue(r);
      writeln(out);
      skip(EOLtok)
   end; (* eval *)

begin
   letter := ['a'..'z'];
   digit := ['0'..'9'];
   MulOps := [MULtok, DIVtok];
   AddOps := [PLUStok, MINUStok];
   whitespace := [chr(0)..' '];
   for v := 'a' to 'z' do
      vars[v] := 0;
   reset(f);
   rewrite(out);
   lineno := 0;
   next.kind := EMPTYtok;
   GetToken;
   while curr.kind <> STOPtok do
      eval;
end.