Паскаль / 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.