AdaPower Logged in as Guest
Ada Tools and Resources

Ada 95 Reference Manual
Ada Source Code Treasury
Bindings and Packages
Ada FAQ


Join >
Articles >
Ada FAQ >
Getting Started >
Home >
Books & Tutorials >
Source Treasury >
Packages for Reuse >
Latest Additions >
Ada Projects >
Press Releases >
Ada Audio / Video >
Home Pages >
Links >
Contact >
About >
Login >
Back
Ada Applications - AdaCalc
Source code of full Ada Applications

------------------------------------------------------------------------------
--                                                                          --
--                        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;


(c) 1998-2004 All Rights Reserved David Botton