Calc

  <expr> ::= <term> + | - <term>

  <term> ::= <factor> * | / <factor>

<factor> ::= <value> ^ <factor> | <value> !

 <value> ::= [ + | - ] ( <expr> ) | <result> | <real>

<result> ::= <name> ( <expr> )

  <name> ::= <letter> { <letter> | <digit> }

  <real> ::= <number> [ . ] [ <number> ] [ e <scale> ]

<number> ::= <digit> { <digit> }

 <scale> ::= [ + | - ] <number>

 <digit> ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9

{28-Apr-05; J. Matthews; GPL; no warranty}

program Calc;

const

  maxString = 80;

  bang = '!';

  dot = '.';

  minus = '-';

  parOpen = '(';

  parClose = ')';

  plus = '+';

  power = '^';

  slash = '/';

  space = ' ';

  star = '*';

type

  String = array [1..maxString] of char;

var

  s : String;

  i, len, width, dec : integer;

  t, nul, tab : char;

  sn, done : boolean;

procedure LowerCase (var s : String; len : integer);

var i : integer;

begin

  for i := 1 to len do

    if s[i] in ['A'..'Z'] then

      s[i] := chr(ord(s[i]) + 32)

end; {LowerCase}

function IsDigit (c : char) : boolean;

begin

  IsDigit := c in ['0'..'9', dot]

end; {IsDigit}

function ParseInt (var s : String; var i : integer) : integer;

var

  n, sign : integer;

begin

  while (s[i] = space) or (s[i] = tab) do i := i + 1;

  if (s[i] = minus) then sign := -1

  else sign := 1;

  if (s[i] = plus) or (s[i] = minus) then i := i + 1;

  n := 0;

  while s[i] in ['0'..'9'] do begin

    n := 10 * n + ord(s[i]) - ord('0');

    i := i + 1

  end;

  ParseInt := sign * n

end; {ParseInt}

function ParseReal (var s : String; var i : integer) : real;

var

  v : real; j, decimal, exponent : integer;

begin

  while s[i] in [space, tab] do i := i + 1;

  v := 0.0; decimal := 0; exponent := 0;

  while (isdigit(s[i])) do begin {parse decimal number}

    if s[i] = dot then decimal := i

    else v := 10 * v + (ord(s[i]) - ord('0'));

    i := i + 1;

  end;

  if decimal > 0 then

    for j := 1 to (i - decimal - 1) do v := v / 10;

  if s[i] = 'e' then begin {handle scientific notation}

    i := i + 1;

    exponent := ParseInt(s, i);

    if exponent > 0 then

      for j := 1 to exponent do v := v * 10

    else if exponent < 0 then

      for j := 1 to abs(exponent) do v := v / 10

  end;

  ParseReal := v

end; {ParseReal}

function DoDivision (x, y : real) : real;

begin

  if y <> 0 then DoDivision := x / y

  else begin

    Writeln('Please don''t divide by zero!');

    DoDivision := 0

  end

end; {DoDivision}

function DoFactorial (x : real) : real;

var v : real; i, j : integer;

begin

  v := 1; j := abs(trunc(x));

  if (j = 0) or (j = 1) then DoFactorial := 1

  else if j > 69 then Writeln('Arithemtic overflow.')

  else for i := j downto 2 do v := v * i;

  if x < 0 then DoFactorial := -v

  else DoFactorial := v

end; {DoLn}

function DoLn (x : real) : real;

begin

  if x > 0.0 then DoLn := ln(x)

  else begin

    Writeln('Natural log argument must be positive.');

    DoLn := 0.0

  end

end; {DoLn}

function DoPower (b, e : real) : real;

var p : integer; u, v : real;

begin

  v := 1; u := b; p := trunc(e);

  if ((e - p) < 0.00001) and (p > 0) then begin

  {handle positive integral exponents}

    while p > 0 do begin

      while not odd(p) do begin

        p := p div 2; u := sqr(u)

      end;

      p := p - 1; v := u * v

    end;

    DoPower := v

  end

  {else use natural logarithm}

  else DoPower := exp(e * DoLn(b))  

end; {Power}

function DoSqrt (x : real) : real;

begin

  if x > 0.0 then DoSqrt := sqrt(x)

  else begin

    Writeln('Square root argument must be positive.');

    DoSqrt := 0.0

  end

end; {DoSqrt}

procedure SkipToken (var s : String; var i : integer);

begin

  while s[i] in ['a'..'z'] do i := i + 1;

end; {SkipToken}

function SkipSpace (var s : String; var i : integer) : char;

begin

  while (s[i] in [space, tab]) do i := i + 1;

  SkipSpace := s[i]

end;

function Expression (var s : string; var i : integer) : real;

var v : real; t : char; j : integer;

  function Term (var s : String; var i : integer) : real;

  var v : real; t : char;

    function Factor (var s : String; var i : integer) : real;

    var v : real; t : char;

      function Value (var s : String; var i : integer) : real;

      var v : real; t : char;

      begin

        v := 0.0;

        t := SkipSpace(s, i);

        if t = parOpen then begin {nested expression}

          i := i + 1;

          v := Expression(s, i);

          if (SkipSpace(s, i) = parClose) then i := i + 1

          else Writeln('Missing parenthesis in expression.')

        end

        else if t = plus then begin {unary plus}

          i := i + 1; v := Value(s, i)

        end

        else if t = minus then begin {unary minus}

          i := i + 1; v := -Value(s, i)

        end

        else if IsDigit(t) then begin {real number}

          v := ParseReal(s, i)

        end

        else if t in ['a','c','e','l','p','s','t'] then begin {function}

          j := i; SkipToken(s, i);

          if s[j] = 'a' then

            if s[j+1] = 'b' then v := abs(Value(s, i))

            else if s[j+1] = 't' then v := arctan(Value(s, i));

          if s[j] = 'c' then v := cos(Value(s, i));

          if s[j] = 'e' then

            if s[j+1] = 'x' then v := exp(Value(s, i))

            else v := exp(1); {e}

          if s[j] = 'l' then v := DoLn(Value(s, i));

          if s[j] = 'p' then v := 3.14159265358979;

          if s[j] = 's' then

            if s[j+1] = 'i' then v := sin(Value(s, i))

            else if s[j+1] = 'q' then v := DoSqrt(Value(s, i));

          if s[j] = 't' then begin

            v := Value(s, i); v := sin(v)/cos(v)

          end

        end

        else Writeln('Syntax error.');

        Value := v

      end; {Value}

    begin

    v := Value(s, i);

    t := SkipSpace(s, i);

    while t in [bang, power] do begin

      i := i + 1;

      case t of

        bang: v := DoFactorial(v);

        power: v := DoPower(v, Factor(s, i))

      end;

      t := SkipSpace(s, i)

    end;

    Factor := v

    end; {Factor}

  begin

    v := Factor(s, i);

    t := SkipSpace(s, i);

    while t in [star, slash, power] do begin

      i := i + 1;

      case t of

        star: v := v * Factor(s, i);

        slash: v := DoDivision(v, Factor(s, i));

        power: v := DoPower(v, Factor(s, i))

      end;

      t := SkipSpace(s, i)

    end;

    Term := v

  end; {Term}

begin

  v := Term(s, i);

  t := SkipSpace(s, i);

  while t in [plus, minus] do begin

    i := i + 1;

    case t of

      plus: v := v + Term(s, i);

      minus: v := v - Term(s, i)

    end;

    t := SkipSpace(s, i)

  end;

  Expression := v

end; {Expression}

function Length (var s : String) : integer;

var i : integer;

begin

  i := maxString;

  while (s[i] = space) and (i <> 1) do i := i - 1;

  if (s[i] = space) and (i = 1) then i := 0;

  Length := i;

end; {Length}

procedure SetDecimal (var s : String; var i, dec : integer);

begin

  SkipToken(s, i);

  dec := trunc(ParseReal(s, i));

  if dec > 15 then dec := 15;

  if dec < 0 then dec := 0;

  Writeln('Decimal precision set to ', dec);

end; {SetDecimal}

procedure SetWidth (var s : String; var i, width : integer);

begin

  SkipToken(s, i);

  width := trunc(ParseReal(s, i));

  if width > 80 then width := 80;

  if width < 0 then width := 0;

  Writeln('Decimal width set to ', width);

end; {SetWidth}

procedure SetNotation (var sn : boolean);

begin

  sn := not(sn);

  if sn then Writeln('Scientific notation on.')

  else Writeln('Scientific notation off.')

end; {SetNotation}

procedure Format (var s : String; var i : integer);

begin

  if sn then Writeln(Expression(s, i):width)

  else Writeln(Expression(s, i):width:dec)

end; {Format}

function FileCheck : boolean;

begin

FileCheck := false;

#a

 jsr _mli

 db  $C4 ;Get_File_Info

 dw finfo

 bne fexit

 ldy #5 ;result offset

 lda #1 ;true

 sta (_sp),y

fexit equ *

#

end; {FileCheck}

#a

fname str "calc.txt"

finfo db 10

 dw fname

 ds 15

#

procedure Execute;

var s : String; i, len : integer; f : file of char;

begin

  if FileCheck then begin

    reset(f, 'calc.txt');

    while not(eof(f)) do begin

      i := 1;

      repeat

        s[i] := f^; i := i + 1; get(f)

      until f^ = chr(13);

      get(f);

      s[i] := nul;

      for i := 1 to i - 1 do Write(s[i]); Write(' = ');

      i := 1;

      t := SkipSpace(s, i);

      Format(s, i)

    end

  end

  else Writeln('File "calc.txt" not found.')

end; {Execute}

procedure Help;

begin

  Writeln;

  Writeln('+--------------------+');

  Writeln('| Welcome to Calc v1 |');

  Writeln('+--------------------+');

  Writeln;

  Writeln('A scientific calculator by J. Matthews');

  Writeln;

  Writeln('Operators (increasing precedence):');

  Writeln(' +, -, *, /, !, ^, unary +/-, ()');

  Writeln;

  Writeln('Functions & constants:');

  Writeln(' sqrt(), ln(), exp(), atan()');

  Writeln(' cos(), sin(), tan(), e, pi');

  Writeln;

  Writeln('Commands (may be abbreviated):');

  Writeln(' width #: set output field width to #');

  Writeln(' decimal #: set the precision to #');

  Writeln(' notation: toggle scientific notation');

  Writeln(' xecute: execute the file "calc.txt"');

  Writeln(' help: print this help screen');

  Writeln(' quit: exit the program');

  Writeln

end; {Help}

begin

#a ; clear screen

 stx _t

 jsr $FC58

 ldx _t

#

  nul := chr(0); tab := chr(9);

  width := 12; dec:= 6; sn := false; done := false;

  Help;

  repeat

    Write('> '); Readln(s);

    len := Length(s);

    s[len + 1] := nul; {terminate string}

    if len > 0 then begin

      LowerCase(s, len);

      i := 1;

      t := SkipSpace(s, i);

      if t = 'd' then SetDecimal(s, i, dec)

      else if t = 'h' then Help

      else if t = 'n' then SetNotation(sn)

      else if t = 'q' then done := true

      else if t = 'w' then SetWidth(s, i, width)

      else if t = 'x' then Execute

      else Format(s, i)

    end

  until done

end. {Calc}