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

program cgicalc(output);
const
MaxBuffer=800;
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
buffer : string[MaxBuffer];
line : string;
fullpath : filename;
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;
r : real;

procedure PrintValue(r : real);
const
MAX = 18;
var
temp : real;
negative : boolean;
digits, after : integer;
s : string;
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(r);
exit
end;
while temp >= 10 do
begin
inc(digits);
temp := temp / 10;
end;
after := MAX-digits;
if after > 12 then after := 12;
str(r:MAX+1:after, s);
write(trim(s))
(* write(r:MAX+1:after); *)
end;

(*************************************************************************)
(********************** The error handler ********************************)
procedure error(s : string);
begin
writeln('ERROR: Line ', lineno:2, ':', s);
writeln('</body>');
writeln('</html>');
flush(output);
halt
end;
(*************************************************************************)

(*************************************************************************)
(********************** The lexer ****************************************)
(*
lexical tokens = exit, stop, end, a..z, pi, sin, cos, tan, log, ln, sqrt,
=, +, -, *, /, mul, div, **, (, )
*)
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 *)

begin (* GetToken *)
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;

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

function eval : real;
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'); *)
eval := expression;
(*
PrintValue(r);
skip(EOLtok)
*)
end; (* eval *)

procedure GetCGIData;
var
len, i : 0..maxint;
err : integer;
ContentLength : string;
c : char;
begin
buffer := '';
ContentLength := getenv('CONTENT_LENGTH');
if ContentLength <> '' then
val(ContentLength, len, err)
else
len := 0;
for i := 1 to len do
begin
read(c);
buffer := buffer + c
end;
end;

procedure ParseCGIData;
var
i, num, p, err : integer;
EncodedVariable, DecodedVariable, name, value : string;
begin
num := CountWords(buffer, '&');
for i := 1 to num do
begin
EncodedVariable := CopyWord(buffer, i, '&');
DecodedVariable := URLDecode(EncodedVariable);
p := pos('=', DecodedVariable);
if p > 0 then
begin
name := trim(copy(DecodedVariable, 1, p-1));
value := trim(copy(DecodedVariable, p+1));
if name = 'line' then
line := value;
if (length(name) = 1) and (name[1] in letter) then
val(value, vars[name[1]], err)
end
end
end;

begin
writeln('Content-type: text/html');
writeln;
writeln('<html>');
writeln('<head>');
writeln('<title>CGI Calculator</title>');
writeln('</head>');
writeln('<body>');

fsplit(getenv('SCRIPT_NAME'), fullpath, ,);
letter := ['a'..'z'];
digit := ['0'..'9'];
MulOps := [MULtok, DIVtok];
AddOps := [PLUStok, MINUStok];
whitespace := [chr(0)..' '];
for v := 'a' to 'z' do
vars[v] := 0;
line := '0';
GetCGIData;
ParseCGIData;
linelen := length(line);
linepos := 1;
curr.kind := EMPTYtok;
next.kind := EMPTYtok;
GetToken;
r := eval;

writeln('<form method="POST" action="', fullpath, 'calc.cgi">');
for v := 'a' to 'z' do
begin
write('<input type="hidden" name="', v, '"');
write(' value="');
PrintValue(vars[v]);
writeln('">')
end;
write('<p><input type="text" name="line" size="60" value="');
PrintValue(r);
writeln('">');
writeln('<input type="submit" value="Submit" name="cmdSubmit">');
writeln('<input type="reset" value="Reset" name="cmdReset">');
writeln('</form>');
writeln('</body>');
writeln('</html>');
end.