program calc(input, output);
{
   CALC -- interactive multi-base expression evaluator

   (C) 1987  Eric Hammond
}
{
   programmer: Eric Hammond
   last update: 07.20.1987
}
{
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

Version history of CALC:

   01/  /87      1.00   Original version written in VAX Pascal.
   :             :      :
   06/  /87      2.00   Converted to MS-DOS Turbo Pascal.
   :             :      :
   06/30/87      2.20   Added capabilities for large numbers.
                        Several bugs fixed.
   06/30/87      2.21   Added unary negation.
   06/30/87      2.22   Added factorial operator.
   07/20/87      2.23   Converted to CP/M Turbo Pascal.
                        Fixed another bug.
   07/12/87      2.24   Fixed long multiplication algorythm.

=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

If you have any questions, comments, suggestions, or  have  found
any bugs in CALC, please contact:

     Eric Hammond
     10040 Daly Rd.
     Cincinnati, OH 45231

Or leave  a message to Eric Hammond  on  the  Cincinnati  Osborne
Group (COG) MBBS RCP/M.   513/481-1417  (2400/1200/300, 8, N, 1).

=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
}

const
   VERSION = 'v2.24';

{$i calc_d.inc}

procedure help;
begin { procedure help }
   writeln;
   writeln;
   writeln('Calc ', VERSION, '  (C) 1987 Eric Hammond');
   writeln;
   writeln('commands:');
   writeln;
   writeln('I nn       - set Input  radix (nn in decimal)');
   writeln('O nn       - set Output radix (nn in decimal)');
   writeln('expression - evaluate');
   writeln('P expr     - display Postfix conversion, and evaluate');
   writeln('R rpn_expr - evaluate an RPN (postfix) expression');
   writeln('?          - help');
   writeln('X          - eXit');
   writeln;
   writeln('operators used in expressions:');
   writeln;
   writeln('( )        parentheses');
   writeln('!          factorial');
   writeln('-          unary negation');
   writeln('**         raising to a power');
   writeln('*  /  %    multiplication, division, modulus');
   writeln('+  -       addition, subtraction');
   writeln('&          bitwise and');
   writeln('|  ^       bitwise or, bitwise exclusive or');
end; { procedure help }

{$i calc_b.inc}

procedure trim_str(var s : str);
begin { procedure trim_str }
   if length(s) > 1 then
      while (s[1] = ' ') and (length(s) > 1) do
         s := copy(s, 2, length(s) - 1);
   if length(s) > 1 then
      while (s[length(s)] = ' ') and (length(s) > 1) do
         s := copy(s, 1, length(s) - 1);
   s := s + ' ';
end; { procedure trim_str }

procedure get_inst(var inst : char; var args : str);
var
   inline_s : str;
begin { procedure get_inst }
   writeln;
   write('[', in_rad : 2, '] : ');
   readln(inline_s);
   trim_str(inline_s);
   if inline_s = '' then
      inst := ' '
   else if inline_s[1] in ['0'..'9', 'a'..'f', 'A'..'F', '(', '-'] then
      begin
      inst := '*';
      args := inline_s;
      end
   else
      begin
      inst := inline_s[1];
      args := copy(inline_s, 2, length(inline_s) - 1);
      trim_str(args);
      end;
end; { procedure get_inst }

procedure set_radix(var radix : integer; new_val : str; direction : str);
var
   new_rad : integer;
   err     : integer;
begin { procedure set_rad }
   new_val := copy(new_val, 1, length(new_val) - 1);
   val(new_val, new_rad, err);
   if (err <> 0) then
      new_rad := radix;
   if (new_rad >= LORAD) and (new_rad <= HIRAD) then
      begin
      radix := new_rad;
      writeln(direction, ' radix set to ', radix :1);
      end
   else
      writeln('Invalid radix (', LORAD : 1, '-', HIRAD : 1, ').');
end; { procedure set_rad }

function is_op(token : str) : boolean;
begin { function is_op }
   is_op := (token[1] in OPCHARS + PARENS);
end; { function is_op }

function is_num(token : str) : boolean;
begin { function is_num }
   if token = '' then
      is_num := false
   else if token [1] in NUMDIGIT then
      is_num := true
   else
      is_num := false;
end; { functioon is_num }

function get_token(var s : str; var token : str) : boolean;
var
   dummy : str;

procedure get_in_set(var s, token : str; c_set : char_set; in_set : boolean);
var
   is_more : boolean;
begin { procedure get_in_set }
   is_more := true;
   token   := '';
   while (length(s) >= 1) and is_more do
      if (s[1] in c_set) = in_set then
         begin
         get_token := true;
         token     := token + s[1];
         s         := copy(s, 2, length(s) - 1)
         end
      else
         is_more := false
end; { procedure get_in_set }

begin { function get_token }
   token := '';
   if s <> '' then
      get_in_set(s, dummy, WHITESPACE, true);
   if s = '' then
      get_token := false
   else if s[1] in NUMDIGIT then
      begin
      get_in_set(s, token, NUMDIGIT, true);
      get_token := true;
      end
   else if s[1] in OPCHARS then
      begin
      token     := s[1];
      s         := copy(s, 2, length(s) - 1);
      if (token = '*') and (length(s) > 0) then if (s[1] = '*') then
            begin
            token     := token + s[1];
            s         := copy(s, 2, length(s) - 1);
            end;
      get_token := true;
      end
   else if s[1] in PARENS then
      begin
      token := s[1];
      s := copy(s, 2, length(s) - 1);
      get_token := true;
      end
   else
      begin
      token := s[1];
      s := copy(s, 2, length(s) - 1);
      get_token := true;
      end;
end; { function get_token }

{$i calc_p.inc}

{$i calc_e.inc}

function eval_expr(expr               : str;
                   in_rad, out_rad    : integer;
                   var val, post_expr : str;
                   in_post            : boolean) : boolean;
var
   valid     : boolean;
   dec_val   : number;
begin { function eval_expr }
   valid := true;
   val   := '';
   if expr = '' then
      begin
      writeln('No expression given.');
      valid := false;
      end
   else 
      begin
      if in_post then
         begin
         if not fix_post(expr, post_expr) then
            begin
            writeln('Invalid postfix expression.');
            valid := false;
            end
         end
      else if not conv_post(expr, post_expr) then
         begin
         writeln('Unable to convert to postfix.');
         valid := false;
         end;
      if valid then
         if not eval_post(post_expr, dec_val) then
            begin
            writeln('Unable to evaluate postfix.');
            valid := false;
            end
         else if out_rad = 10 then
            toother(dec_val, out_rad, val, false)
         else
            toother(dec_val, out_rad, val, true);
      end;
   eval_expr := valid;
end; { function eval_expr }

procedure put_val(expr            : str;
                  in_rad, out_rad : integer;
                  sho_post        : boolean;
                  in_post         : boolean);
var
   val,
   post_expr : str;
begin { procedure put_val }
   if eval_expr(expr, in_rad, out_rad, val, post_expr, in_post) then
      begin
      if sho_post then
         writeln('     = ', post_expr);
      writeln('[', out_rad : 2, '] = ', val);
      end
   else
      writeln('Invalid expression.');
end; { procedure put_val }

begin { main }
   writeln;
   writeln('Calc ', VERSION, '  (C) 1987 Eric Hammond');
   writeln;
   writeln('Type ''?'' for help.');

   zero(zero_n);

   in_rad  := 10;
   out_rad := 10;
   repeat
      get_inst(inst, args);
      if inst <> 'X' then
         case inst of
            'I', 'i' : set_radix(in_rad, args, 'Input');
            'O', 'o' : set_radix(out_rad, args, 'Output');
            '*'      : put_val(args, in_rad, out_rad, false, false);
            'P', 'p' : put_val(args, in_rad, out_rad, true, false);
            'R', 'r' : put_val(args, in_rad, out_rad, false, true);
            '?'      : help;
            ' '      : ;
            'X', 'x' : ;
         else
            writeln('Invalid instruction ''', inst,''' (use ''?'' for help).');
         end;
   until inst in ['X', 'x'];
end. { main }