------------------------------------------------------------------------------
-- --
-- A D A C A L C U L A T O R --
-- --
------------------------------------------------------------------------------
-- Copyright (C) 1999 by Eugene Nonko, cm@liceum.secna.ru --
------------------------------------------------------------------------------
-- expr0 ::= Variable Assign expr1 | expr1
-- expr1 ::= expr2 | expr2 '+' expr2 ... | expr2 '-' expr2 ...
-- expr2 ::= expr3 | expr3 '*' expr3 ... | expr3 '/' expr3 ...
-- expr3 ::= expr4 | expr4 Power expr3
-- expr4 ::= Number | '(' expr1 ')' | '-' expr4 | '+' expr4 |
-- Predefined_Function '(' expr1 ')'
with Ada.Text_IO,
Ada.Characters.Latin_1,
Ada.Strings.Unbounded,
Ada.Numerics,
Ada.Numerics.Generic_Elementary_Functions,
Stack,
List;
use Ada.Text_IO,
Ada.Characters.Latin_1,
Ada.Strings.Unbounded,
Ada.Numerics;
procedure Calculator is
type Value_Type is digits 8;
package Value_Type_IO is
new Float_IO (Value_Type);
use Value_Type_IO;
package Value_Type_Functions is
new Generic_Elementary_Functions (Value_Type);
use Value_Type_Functions;
Syntax_Error, No_Expression_Error, Divide_By_Zero : exception;
type Predefined_Function_Type is
access function (X : Value_Type) return Value_Type;
package Variables is
new List (Value_Type, Unbounded_String);
package Predefined_Functions is
new List (Predefined_Function_Type, Unbounded_String);
package Value_Stack is new Stack (Value_Type, 64);
use Value_Stack;
function Calculate return Value_Type is
type Token_Type is
('+', '-', '*', '/', '(', ')', Power, Assign,
Number, Variable, Predefined_Function, End_Of_Line);
package Token_Stack is new Stack (Token_Type, 8);
procedure Parse_Expr0 is
Token : Token_Type;
Value : Value_Type;
Identifier, Last_Identifier : Unbounded_String;
function Get_Token return Token_Type is
EOL : Boolean;
C : Character;
function Is_Space (C : Character) return Boolean is
begin -- Is_Space
return C = HT or else C = Space;
end Is_Space;
function Is_Letter_Or_Digit (C : Character) return Boolean is
begin -- Is_Letter_Or_Digit
case C is
when 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' =>
return True;
when others =>
return False;
end case;
end Is_Letter_Or_Digit;
begin -- Get_Token
if not Token_Stack.Empty then
return Token_Stack.Pop;
end if;
loop
Look_Ahead (C, EOL);
if EOL then
return End_Of_Line;
end if;
exit when not Is_Space (C);
Get (C);
end loop;
case C is
when '+' =>
Get (C);
return '+';
when '-' =>
Get (C);
return '-';
when '*' =>
Get (C);
Look_Ahead (C, EOL);
if EOL or else C /= '*' then
return '*';
end if;
Get (C);
return Power;
when '/' =>
Get (C);
return '/';
when '^' =>
Get (C);
return Power;
when '(' =>
Get (C);
return '(';
when ')' =>
Get (C);
return ')';
when ':' =>
Get (C);
Look_Ahead (C, EOL);
if EOL or else C /= '=' then
raise Syntax_Error;
end if;
Get (C);
return Assign;
when 'A' .. 'Z' | 'a' .. 'z' | '_' =>
Identifier := Null_Unbounded_String;
loop
Identifier := Identifier & C;
Get (C);
Look_Ahead (C, EOL);
exit when EOL or else not Is_Letter_Or_Digit (C);
end loop;
if Predefined_Functions.Search (Identifier) then
return Predefined_Function;
end if;
return Variable;
when '0' .. '9' =>
begin
Get (Value);
return Number;
exception
when others =>
raise Syntax_Error;
end;
when others =>
raise Syntax_Error;
end case;
raise Syntax_Error;
end Get_Token;
procedure Parse_Expr1 is
procedure Parse_Expr2 is
procedure Parse_Expr3 is
procedure Parse_Expr4 is
Func : Predefined_Function_Type;
begin -- Parse_Expr4
Token := Get_Token;
case Token is
when Variable =>
Push (Variables.Get (Identifier));
when Predefined_Function =>
Func := Predefined_Functions.Get (Identifier);
if Get_Token /= '(' then
raise Syntax_Error;
end if;
Parse_Expr1;
if Get_Token /= ')' then
raise Syntax_Error;
end if;
Push (Func (Pop));
when Number =>
Push (Value);
when '+' =>
Parse_Expr4;
when '-' =>
Parse_Expr4;
Push (-Pop);
when '(' =>
Parse_Expr1;
if Get_Token /= ')' then
raise Syntax_Error;
end if;
when others =>
Token_Stack.Push (Token);
end case;
end Parse_Expr4;
begin -- Parse_Expr3
Parse_Expr4;
loop
Token := Get_Token;
case Token is
when Power =>
Parse_Expr3;
Push (Pop ** Pop);
when others =>
Token_Stack.Push (Token);
exit;
end case;
end loop;
end Parse_Expr3;
Divisor : Value_Type;
begin -- Parse_Expr2
Parse_Expr3;
loop
Token := Get_Token;
case Token is
when '*' =>
Parse_Expr3;
Push (Pop * Pop);
when '/' =>
Parse_Expr3;
Divisor := Pop;
if Divisor = Value_Type (0) then
raise Divide_By_Zero;
else
Push (Pop / Divisor);
end if;
when others =>
Token_Stack.Push (Token);
exit;
end case;
end loop;
end Parse_Expr2;
begin -- Parse_Expr1
Parse_Expr2;
loop
Token := Get_Token;
case Token is
when '+' =>
Parse_Expr2;
Push (Pop + Pop);
when '-' =>
Parse_Expr2;
Swap;
Push (Pop - Pop);
when others =>
Token_Stack.Push (Token);
exit;
end case;
end loop;
end Parse_Expr1;
begin -- Parse_Expr0
Token := Get_Token;
if Token = Variable then
Token := Get_Token;
if Token = Assign then
Last_Identifier := Identifier;
Parse_Expr1;
Variables.Set (Last_Identifier, Get);
return;
else
Token_Stack.Push (Token);
Token_Stack.Push (Variable);
end if;
else
Token_Stack.Push (Token);
end if;
Parse_Expr1;
end Parse_Expr0;
begin -- Calculate
Value_Stack.Drop_All;
Token_Stack.Drop_All;
Parse_Expr0;
Skip_Line;
case Capacity is
when 0 =>
raise No_Expression_Error;
when 1 =>
return Pop;
when others =>
raise Syntax_Error;
end case;
exception
when No_Expression_Error =>
raise;
when others =>
Skip_Line;
raise;
end Calculate;
function Arctan (X : Value_Type) return Value_Type is
begin -- Arctan
return Value_Type_Functions.Arctan (X);
end Arctan;
function Arccot (X : Value_Type) return Value_Type is
begin -- Arccot
return Value_Type_Functions.Arccot (X);
end Arccot;
function Abs_Function (X : Value_Type) return Value_Type is
begin -- Abs_Function
return abs X;
end Abs_Function;
function Sgn (X : Value_Type) return Value_Type is
begin -- Sgn
if X > 0.0 then
return 1.0;
elsif X < 0.0 then
return -1.0;
else
return 0.0;
end if;
end Sgn;
procedure Put_Adaptive (X : Value_Type) is
S : String (1 .. 80);
First : Positive := S'First;
Last : Positive := S'Last;
begin -- Put_Adaptive
Put (To => S, Item => X, Aft => Value_Type'Digits, Exp => 0);
while S (First) = ' ' loop
First := First + 1;
end loop;
while S (Last) = '0' loop
Last := Last - 1;
end loop;
if S (Last) = '.' then
Last := Last - 1;
end if;
Put (S (First .. Last));
end Put_Adaptive;
begin -- Calculator
Variables.Add (To_Unbounded_String ("pi"), Pi);
Variables.Add (To_Unbounded_String ("e"), e);
Predefined_Functions.Add (To_Unbounded_String ("abs"), Abs_Function'Access);
Predefined_Functions.Add (To_Unbounded_String ("sgn"), Sgn'Access);
Predefined_Functions.Add (To_Unbounded_String ("sin"), Sin'Access);
Predefined_Functions.Add (To_Unbounded_String ("cos"), Cos'Access);
Predefined_Functions.Add (To_Unbounded_String ("tan"), Tan'Access);
Predefined_Functions.Add (To_Unbounded_String ("cot"), Cot'Access);
Predefined_Functions.Add (To_Unbounded_String ("exp"), Exp'Access);
Predefined_Functions.Add (To_Unbounded_String ("log"), Log'Access);
Predefined_Functions.Add (To_Unbounded_String ("sqrt"), Sqrt'Access);
Predefined_Functions.Add (To_Unbounded_String ("arcsin"), Arcsin'Access);
Predefined_Functions.Add (To_Unbounded_String ("arccos"), Arccos'Access);
Predefined_Functions.Add (To_Unbounded_String ("arctan"), Arctan'Access);
Predefined_Functions.Add (To_Unbounded_String ("arccot"), Arccot'Access);
Predefined_Functions.Add (To_Unbounded_String ("sinh"), Sinh'Access);
Predefined_Functions.Add (To_Unbounded_String ("cosh"), Cosh'Access);
Predefined_Functions.Add (To_Unbounded_String ("tanh"), Tanh'Access);
Predefined_Functions.Add (To_Unbounded_String ("coth"), Coth'Access);
Predefined_Functions.Add (To_Unbounded_String ("arcsinh"), Arcsinh'Access);
Predefined_Functions.Add (To_Unbounded_String ("arccosh"), Arccosh'Access);
Predefined_Functions.Add (To_Unbounded_String ("arctanh"), Arctanh'Access);
Predefined_Functions.Add (To_Unbounded_String ("arccoth"), Arccoth'Access);
loop
declare
Result : Value_Type;
begin
Put ("? ");
Result := Calculate;
Put ("= ");
Put_Adaptive (Result);
New_Line;
exception
when Overflow_Error =>
Put_Line ("stack overflow");
when Underflow_Error | Syntax_Error =>
Put_Line ("syntax error");
when Variables.Item_Not_Found_Error =>
Put_Line ("undefined variable");
when Argument_Error | Constraint_Error =>
Put_Line ("invalid argument");
when Divide_By_Zero =>
Put_Line ("divide by zero");
when No_Expression_Error =>
exit;
end;
end loop;
end Calculator;
package body List is
type Node;
type Node_Pointer is access Node;
type Node is
record
Next : Node_Pointer;
Identifier : Identifier_Type;
Value : Item_Type;
end record;
First_Node : Node_Pointer := null;
procedure Add (Identifier : Identifier_Type; Value : Item_Type) is
New_Node : Node_Pointer := new Node'
(Next => First_Node, Identifier => Identifier, Value => Value);
begin -- Add
First_Node := New_Node;
end Add;
function Get (Identifier : Identifier_Type) return Item_Type is
Cur_Node : Node_Pointer := First_Node;
begin -- Get
while Cur_Node /= null loop
if Cur_Node.Identifier = Identifier then
return Cur_Node.Value;
end if;
Cur_Node := Cur_Node.Next;
end loop;
raise Item_Not_Found_Error;
end Get;
procedure Set (Identifier : Identifier_Type; Value : Item_Type) is
Cur_Node : Node_Pointer := First_Node;
begin -- Set
while Cur_Node /= null loop
if Cur_Node.Identifier = Identifier then
Cur_Node.Value := Value;
return;
end if;
Cur_Node := Cur_Node.Next;
end loop;
Add (Identifier, Value);
end Set;
function Search (Identifier : Identifier_Type) return Boolean is
Cur_Node : Node_Pointer := First_Node;
begin -- Search
while Cur_Node /= null loop
if Cur_Node.Identifier = Identifier then
return True;
end if;
Cur_Node := Cur_Node.Next;
end loop;
return False;
end Search;
end List;
-- Generic list package, used to create variable and function lists
generic
type Item_Type is private;
type Identifier_Type is private;
package List is
-- Adds item to list without duplication checks
procedure Add (Identifier : Identifier_Type; Value : Item_Type);
-- Gets item value, if item is not present, then raise Item_Not_Found_Error
function Get (Identifier : Identifier_Type) return Item_Type;
-- Sets item's value to Value, adds item if needed
procedure Set (Identifier : Identifier_Type; Value : Item_Type);
-- Returns true if item present in list
function Search (Identifier : Identifier_Type) return Boolean;
Item_Not_Found_Error : exception;
end List;
package body Stack is
Stack_Depth_Constant : constant Positive := Stack_Depth;
subtype Stack_Pointer_Type is Positive range 1 .. Stack_Depth_Constant;
Stack_Data : array (Stack_Pointer_Type) of Item_Type;
Stack_Pointer : Stack_Pointer_Type := 1;
procedure Push (Item : Item_Type) is
begin -- Push
if Stack_Pointer = Stack_Depth_Constant then
raise Overflow_Error;
else
Stack_Data (Stack_Pointer) := Item;
Stack_Pointer := Stack_Pointer + 1;
end if;
end Push;
function Pop return Item_Type is
begin -- Pop
if Stack_Pointer = 1 then
raise Underflow_Error;
else
Stack_Pointer := Stack_Pointer - 1;
return Stack_Data (Stack_Pointer);
end if;
end Pop;
function Get return Item_Type is
begin -- Get
if Stack_Pointer = 1 then
raise Underflow_Error;
else
return Stack_Data (Stack_Pointer - 1);
end if;
end Get;
procedure Empty is
begin -- Empty
Stack_Pointer := 1;
end Empty;
function Is_Empty return Boolean is
begin -- Is_Empty
return Stack_Pointer = 1;
end Is_Empty;
procedure Swap is
Temp : Item_Type := Stack_Data (Stack_Pointer - 1);
begin -- Swap
if Stack_Pointer < 3 then
raise Underflow_Error;
else
Stack_Data (Stack_Pointer - 1) := Stack_Data (Stack_Pointer - 2);
Stack_Data (Stack_Pointer - 2) := Temp;
end if;
end Swap;
procedure Drop is
begin -- Drop
if Stack_Pointer = 1 then
raise Underflow_Error;
else
Stack_Pointer := Stack_Pointer - 1;
end if;
end Drop;
function Capacity return Natural is
begin -- Capacity
return Natural (Stack_Pointer) - 1;
end Capacity;
end Stack;
-- Generic stack package, used to create value and token stacks
generic
type Item_Type is private;
Stack_Depth : Positive;
package Stack is
-- Pushes item
procedure Push (Item : Item_Type);
-- Pops item
function Pop return Item_Type;
-- Gets topmost item without popping
function Get return Item_Type;
-- Swaps topmost items
procedure Swap;
-- Drops topmost item
procedure Drop;
-- Empties stack (drop all items)
procedure Empty;
-- Returns True if stack is empty and False otherwise
function Is_Empty return Boolean;
-- Return current capacity of stack
function Capacity return Natural;
Overflow_Error, Underflow_Error : exception;
end Stack;
|
