Oakland CPM Archive/oakcpm.iso/cpm/calculat/calc224.lbr/CALC_E.IZC/CALC_E.INC

Text File | 1987-07-19 | 10KB | 406 lines

function fix_post(expr : str; var post_expr : str) : boolean;
var
   valid : boolean;
   token : str;
begin { procedure fix_post }
   valid := true;
   post_expr := '';
   while get_token(expr, token) do
      begin
      post_expr := post_expr + token + ' ';
      end;
   fix_post := valid;
end; { function fix_post }

function eval_post(expr : str; var val : number) : boolean;
type
   num_ptr = ^num_rec;
   num_rec = record
                num  : str;
                next : num_ptr;
             end;
var
   num_stack : num_ptr;
   result    : str;
   token     : str;
   valid     : boolean;

function empty(num_stack : num_ptr) : boolean;
begin { function empty }
   empty := num_stack = nil;
end; { function empty }

function pop(var num_stack : num_ptr) : str;
var
   prev : num_ptr;
begin { function pop }
   if empty(num_stack) then
      begin
      pop := '';
      writeln('Stack empty.');
      end
   else
      begin
      pop      := num_stack^.num;
      prev     := num_stack;
      num_stack := num_stack^.next;
      dispose(prev);
      end;
end; { function pop }

procedure push(var num_stack : num_ptr; num : str);
var
   new_num : num_ptr;
begin { procedure push }
   new(new_num);
   new_num^.num   := num;
   new_num^.next := num_stack;
   num_stack     := new_num;
end; { procdure push }

function top(num_stack : num_ptr) : str;
begin { function top }
   if empty(num_stack) then
      begin
      top := '';
      writeln('Stack empty.');
      end
   else
      top := num_stack^.num;
end; { function top }

function get_token(var s : str; var token : str) : boolean;
begin { function get_token }
   if s = '' then
      get_token := false
   else
      begin
      token := copy(s, 1, pos(' ', s) - 1);
      s := copy(s, pos(' ', s) + 1, length(s) - pos(' ', s));
      get_token := true;
      end;
end; { function get_token }




procedure add(num1, num2 : number; var result : number); forward;

procedure sub(num1, num2 : number; var result : number);

procedure sub_sub(num1, num2 : number; var result : number);
var
   temp   : integer;
   borrow : integer;
   b      : integer;
begin { procedure sub_sub }
   borrow := 0;
   for b := 1 to MAXB do
      begin
      temp := (num1.n[b] - borrow) - num2.n[b];
      if (temp < 0) then
         begin
         result.n[b] := temp + 256;
         borrow := 1;
         end
      else
         begin
         result.n[b] := temp;
         borrow := 0;
         end;
      end;
   if (borrow <> 0) then
      writeln('sub_sub: incorrect subtraction.');
end; { procedure sub_sub }

begin { procedure sub }
   if num1.s * num2.s = -1 then
      begin
      num2.s   := - num2.s;
      add(num1, num2, result);
      result.s := num1.s;
      end
   else
      if (numcmp(num1, num2) >= 0) then
         begin
         sub_sub(num1, num2, result);
         result.s := num1.s;
         end
      else
         begin
         sub_sub(num2, num1, result);
         result.s := - num1.s;
         end;
end; { procedure sub }

procedure add {num1, num2 : number; var result : number} ;

procedure add_add(num1, num2 : number; var result : number);
var
   b,
   carry : integer;
begin { procedure add_add }
   carry := 0;
   for b := 1 to MAXB do
      begin
      result.n[b] := (num1.n[b] + num2.n[b] + carry) mod 256;
      carry       := (num1.n[b] + num2.n[b] + carry) div 256;
      end;
   if (carry > 0) then
      writeln('numeric overflow.');
end; { procedure add_add }

begin { procedure add }
   if num1.s * num2.s = -1 then
      if num1.s = -1 then
         begin
         num1.s := 1;
         sub(num2, num1, result);
         end
      else
         begin
         num2.s := 1;
         sub(num1, num2, result);
         end
   else
      begin
      add_add(num1, num2, result);
      result.s := num1.s;
      end;
end; { procedure add }

procedure mul(num1, num2 : number; var result : number);
var
   b        : integer;
   i        : integer;
   m_result : number;
begin { procedure mul }
   zero(result);
   for b := 1 to MAXB do
      begin
      mult_ni(num1, num2.n[b], m_result);
      for i := MAXB downto 1 do
         begin
         if i >= b then
            m_result.n[i] := m_result.n[i - b + 1]
         else
            m_result.n[i] := 0;
         end;
      add(result, m_result, result);
      end;
   result.s := num1.s * num2.s;
end; { procedure mul }

procedure dvd(num1, num2 : number; var result, remainder : number);
var
   b        : integer;
   partial,
   part_res : number;

procedure dvd_dvd(num1, num2 : number; var result, remainder : number);
var
   b : integer;
begin { procedure dvd_dvd }
   zero(result);
   while (numcmp(num1, num2) >= 0) do
      begin
      sub(num1, num2, num1);
      add_ni(result, 1, result);
      end;
   remainder.n := num1.n;
end; { procedure dvd_dvd }

begin { procedure dvd }
   zero(remainder);
   for b := MAXB downto 1 do
      begin
      partial := remainder;
      mult_ni(partial, 256, partial);
      partial.n[1] := num1.n[b];
      dvd_dvd(partial, num2, part_res, remainder);
      result.n[b] := part_res.n[1];
      end;

   result.s    := num1.s * num2.s;
   remainder.s := 1;
end; { procedure dvd }


procedure pow(num1, num2 : number; var result : number);
begin { procedure pow }
   if odd(num2.n[1]) then
      result.s := num1.s
   else
      result.s := 1;

   zero(result);
   add_ni(result, 1, result);
   while (numcmp(num2, zero_n) <> 0) do
      begin
      mul(result, num1, result);
      add_ni(num2, -1, num2);
      end;
end; { procedure pow }

procedure fix_bit(var num : number);
begin { procedure fix_bit }
   if num.s = -1 then
      begin
      num.b := (neg_one - num.b);
      add_ni(num, 1, num);
      end;
   num.s := 1;
end; { procedure fix_bit }

procedure bit_and(num1, num2 : number; var result : number);
begin { procedure bit_and }
   fix_bit(num1);
   fix_bit(num2);
   result.b := num1.b * num2.b
end; { procedure bit_and }

procedure bit_or(num1, num2 : number; var result : number);
begin { procedure bit_or }
   fix_bit(num1);
   fix_bit(num2);
   result.b := num1.b + num2.b;
   result.s := 1;
end; { procedure bit_or }

procedure bit_xor(num1, num2 : number; var result : number);
begin { procedure bit_xor }
   fix_bit(num1);
   fix_bit(num2);
   result.b := (num1.b - num2.b) + (num2.b - num1.b);
   result.s := 1;
end; { procedure bit_xor }


function do_eval(num2, num1, op : str; var result : str) : boolean;
var
   dec1, dec2 : number;
   dec_result,
   dummy      : number;
   valid      : boolean;
begin { function do_eval }
   valid := true;
   if (num1 = '') or (num2 = '') then
      begin
      writeln('Unbalanced expression.');
      writeln(' - missing operands.');
      valid := false;
      end
   else if not todec(num1, in_rad, dec1) then
      valid := false
   else if not todec(num2, in_rad, dec2) then
      valid := false
   else if op = '+' then
      add(dec1, dec2, dec_result)
   else if op = '-' then
      sub(dec1, dec2, dec_result)
   else if op = '*' then
      mul(dec1, dec2, dec_result)
   else if op = '/' then
      if numcmp(dec2, zero_n) = 0 then
         begin
         writeln('Division by zero.');
         valid := false;
         end
      else
         dvd(dec1, dec2, dec_result, dummy)
   else if op = '%' then
      if numcmp(dec2, zero_n) = 0 then
         begin
         writeln('Division by zero.');
         valid := false;
         end
      else
         dvd(dec1, dec2, dummy, dec_result)
   else if op = '**' then
      pow(dec1, dec2, dec_result)
   else if op = '&' then
      bit_and(dec1, dec2, dec_result)
   else if op = '|' then
      bit_or(dec1, dec2, dec_result)
   else if op = '^' then
      bit_xor(dec1, dec2, dec_result)
   else
      begin
      writeln('Invalid operator: ''', op, '''.');
      valid := false;
      end;
   if valid then
      toother(dec_result, in_rad, result, false);
   do_eval := valid;
end; { function do_eval }

procedure factoral(num : str; var result : str);
var
   result_n,
   num_n     : number;
begin { procedure negate }

   zero(result_n);
   add_ni(result_n, 1, result_n);

   if not todec(num, in_rad, num_n) then
      begin
      result := '';
      valid  := false;
      end
   else
      begin
      while numcmp(num_n, zero_n) <> 0 do
         begin
         mul(result_n, num_n, result_n);
         add_ni(num_n, -1, num_n);
         end;
      toother(result_n, in_rad, result, false);
      end;
end; { procedure negate }

procedure negate(num : str; var result : str);
begin { procedure negate }
   if num[1] = '-' then
      result := copy(num, 2, length(num) - 1)
   else
      result := '-' + num;
end; { procedure negate }

begin { function eval_post }
   valid     := true;
   num_stack := nil;
   while get_token(expr, token) and valid do
      if is_num(token) then
         push(num_stack, token)
      else if (token = '!') then
         begin
         factoral(pop(num_stack), result);
         push(num_stack, result);
         end
      else if (token = '~') then
         begin
         negate(pop(num_stack), result);
         push(num_stack, result);
         end
      else if do_eval(pop(num_stack), pop(num_stack), token, result) then
         push(num_stack, result)
      else
         valid := false;
   if valid and empty(num_stack) then
      begin
      writeln(' - too many operator(s).');
      valid := false;
      end
   else if valid then
      valid := todec(pop(num_stack), in_rad, val);
   if not empty(num_stack) then
      begin
      writeln('Unbalanced expression ');
      writeln(' - missing operator(s).');
      valid := false;
      end;
   eval_post := valid;
end; { function eval_post }